From 9af46956d534d5fc3afbf60861049f1009b5eecf Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Thu, 12 Sep 2024 16:47:17 +0200 Subject: [PATCH 01/95] add poly1305 from https://github.com/grigorig/chachapoly --- examples/riscv/poly1305/poly1305.c | 263 +++++++++++++++++++++++++++++ examples/riscv/poly1305/poly1305.h | 32 ++++ 2 files changed, 295 insertions(+) create mode 100644 examples/riscv/poly1305/poly1305.c create mode 100644 examples/riscv/poly1305/poly1305.h diff --git a/examples/riscv/poly1305/poly1305.c b/examples/riscv/poly1305/poly1305.c new file mode 100644 index 000000000..499c4464c --- /dev/null +++ b/examples/riscv/poly1305/poly1305.c @@ -0,0 +1,263 @@ +/* +poly1305 implementation using 32 bit * 32 bit = 64 bit multiplication and 64 bit addition +public domain +*/ + +#include "poly1305.h" + +#if (USE_UNALIGNED == 1) +#define U8TO32(p) \ + (*((uint32_t *)(p))) +#define U32TO8(p, v) \ + do { \ + *((uint32_t *)(p)) = v; \ + } while (0) +#else +/* interpret four 8 bit unsigned integers as a 32 bit unsigned integer in little endian */ +static uint32_t +U8TO32(const unsigned char *p) +{ + return + (((uint32_t)(p[0] & 0xff) ) | + ((uint32_t)(p[1] & 0xff) << 8) | + ((uint32_t)(p[2] & 0xff) << 16) | + ((uint32_t)(p[3] & 0xff) << 24)); +} + +/* store a 32 bit unsigned integer as four 8 bit unsigned integers in little endian */ +static void +U32TO8(unsigned char *p, uint32_t v) +{ + p[0] = (v ) & 0xff; + p[1] = (v >> 8) & 0xff; + p[2] = (v >> 16) & 0xff; + p[3] = (v >> 24) & 0xff; +} +#endif + +void +poly1305_init(struct poly1305_context *st, const unsigned char key[32]) +{ + /* r &= 0xffffffc0ffffffc0ffffffc0fffffff */ + st->r[0] = (U8TO32(&key[ 0]) ) & 0x3ffffff; + st->r[1] = (U8TO32(&key[ 3]) >> 2) & 0x3ffff03; + st->r[2] = (U8TO32(&key[ 6]) >> 4) & 0x3ffc0ff; + st->r[3] = (U8TO32(&key[ 9]) >> 6) & 0x3f03fff; + st->r[4] = (U8TO32(&key[12]) >> 8) & 0x00fffff; + + /* h = 0 */ + st->h[0] = 0; + st->h[1] = 0; + st->h[2] = 0; + st->h[3] = 0; + st->h[4] = 0; + + /* save pad for later */ + st->pad[0] = U8TO32(&key[16]); + st->pad[1] = U8TO32(&key[20]); + st->pad[2] = U8TO32(&key[24]); + st->pad[3] = U8TO32(&key[28]); + + st->leftover = 0; + st->final = 0; +} + +static void +poly1305_blocks(struct poly1305_context *st, const unsigned char *m, size_t bytes) +{ + const uint32_t hibit = (st->final) ? 0 : (1 << 24); /* 1 << 128 */ + uint32_t r0,r1,r2,r3,r4; + uint32_t s1,s2,s3,s4; + uint32_t h0,h1,h2,h3,h4; + uint64_t d0,d1,d2,d3,d4; + uint32_t c; + + r0 = st->r[0]; + r1 = st->r[1]; + r2 = st->r[2]; + r3 = st->r[3]; + r4 = st->r[4]; + + s1 = r1 * 5; + s2 = r2 * 5; + s3 = r3 * 5; + s4 = r4 * 5; + + h0 = st->h[0]; + h1 = st->h[1]; + h2 = st->h[2]; + h3 = st->h[3]; + h4 = st->h[4]; + + while (bytes >= POLY1305_BLOCK_SIZE) { + /* h += m[i] */ + h0 += (U8TO32(m+ 0) ) & 0x3ffffff; + h1 += (U8TO32(m+ 3) >> 2) & 0x3ffffff; + h2 += (U8TO32(m+ 6) >> 4) & 0x3ffffff; + h3 += (U8TO32(m+ 9) >> 6) & 0x3ffffff; + h4 += (U8TO32(m+12) >> 8) | hibit; + + /* h *= r */ + d0 = ((uint64_t)h0 * r0) + ((uint64_t)h1 * s4) + ((uint64_t)h2 * s3) + ((uint64_t)h3 * s2) + ((uint64_t)h4 * s1); + d1 = ((uint64_t)h0 * r1) + ((uint64_t)h1 * r0) + ((uint64_t)h2 * s4) + ((uint64_t)h3 * s3) + ((uint64_t)h4 * s2); + d2 = ((uint64_t)h0 * r2) + ((uint64_t)h1 * r1) + ((uint64_t)h2 * r0) + ((uint64_t)h3 * s4) + ((uint64_t)h4 * s3); + d3 = ((uint64_t)h0 * r3) + ((uint64_t)h1 * r2) + ((uint64_t)h2 * r1) + ((uint64_t)h3 * r0) + ((uint64_t)h4 * s4); + d4 = ((uint64_t)h0 * r4) + ((uint64_t)h1 * r3) + ((uint64_t)h2 * r2) + ((uint64_t)h3 * r1) + ((uint64_t)h4 * r0); + + /* (partial) h %= p */ + c = (uint32_t)(d0 >> 26); h0 = (uint32_t)d0 & 0x3ffffff; + d1 += c; c = (uint32_t)(d1 >> 26); h1 = (uint32_t)d1 & 0x3ffffff; + d2 += c; c = (uint32_t)(d2 >> 26); h2 = (uint32_t)d2 & 0x3ffffff; + d3 += c; c = (uint32_t)(d3 >> 26); h3 = (uint32_t)d3 & 0x3ffffff; + d4 += c; c = (uint32_t)(d4 >> 26); h4 = (uint32_t)d4 & 0x3ffffff; + h0 += c * 5; c = (h0 >> 26); h0 = h0 & 0x3ffffff; + h1 += c; + + m += POLY1305_BLOCK_SIZE; + bytes -= POLY1305_BLOCK_SIZE; + } + + st->h[0] = h0; + st->h[1] = h1; + st->h[2] = h2; + st->h[3] = h3; + st->h[4] = h4; +} + +void +poly1305_finish(struct poly1305_context *st, unsigned char mac[16]) +{ + uint32_t h0,h1,h2,h3,h4,c; + uint32_t g0,g1,g2,g3,g4; + uint64_t f; + uint32_t mask; + + /* process the remaining block */ + if (st->leftover) { + size_t i = st->leftover; + st->buffer[i++] = 1; + for (; i < POLY1305_BLOCK_SIZE; i++) + st->buffer[i] = 0; + st->final = 1; + poly1305_blocks(st, st->buffer, POLY1305_BLOCK_SIZE); + } + + /* fully carry h */ + h0 = st->h[0]; + h1 = st->h[1]; + h2 = st->h[2]; + h3 = st->h[3]; + h4 = st->h[4]; + + c = h1 >> 26; h1 = h1 & 0x3ffffff; + h2 += c; c = h2 >> 26; h2 = h2 & 0x3ffffff; + h3 += c; c = h3 >> 26; h3 = h3 & 0x3ffffff; + h4 += c; c = h4 >> 26; h4 = h4 & 0x3ffffff; + h0 += c * 5; c = h0 >> 26; h0 = h0 & 0x3ffffff; + h1 += c; + + /* compute h + -p */ + g0 = h0 + 5; c = g0 >> 26; g0 &= 0x3ffffff; + g1 = h1 + c; c = g1 >> 26; g1 &= 0x3ffffff; + g2 = h2 + c; c = g2 >> 26; g2 &= 0x3ffffff; + g3 = h3 + c; c = g3 >> 26; g3 &= 0x3ffffff; + g4 = h4 + c - (1 << 26); + + /* select h if h < p, or h + -p if h >= p */ + mask = (g4 >> ((sizeof(uint32_t) * 8) - 1)) - 1; + g0 &= mask; + g1 &= mask; + g2 &= mask; + g3 &= mask; + g4 &= mask; + mask = ~mask; + h0 = (h0 & mask) | g0; + h1 = (h1 & mask) | g1; + h2 = (h2 & mask) | g2; + h3 = (h3 & mask) | g3; + h4 = (h4 & mask) | g4; + + /* h = h % (2^128) */ + h0 = ((h0 ) | (h1 << 26)) & 0xffffffff; + h1 = ((h1 >> 6) | (h2 << 20)) & 0xffffffff; + h2 = ((h2 >> 12) | (h3 << 14)) & 0xffffffff; + h3 = ((h3 >> 18) | (h4 << 8)) & 0xffffffff; + + /* mac = (h + pad) % (2^128) */ + f = (uint64_t)h0 + st->pad[0] ; h0 = (uint32_t)f; + f = (uint64_t)h1 + st->pad[1] + (f >> 32); h1 = (uint32_t)f; + f = (uint64_t)h2 + st->pad[2] + (f >> 32); h2 = (uint32_t)f; + f = (uint64_t)h3 + st->pad[3] + (f >> 32); h3 = (uint32_t)f; + + U32TO8(mac + 0, h0); + U32TO8(mac + 4, h1); + U32TO8(mac + 8, h2); + U32TO8(mac + 12, h3); + + /* zero out the state */ + st->h[0] = 0; + st->h[1] = 0; + st->h[2] = 0; + st->h[3] = 0; + st->h[4] = 0; + st->r[0] = 0; + st->r[1] = 0; + st->r[2] = 0; + st->r[3] = 0; + st->r[4] = 0; + st->pad[0] = 0; + st->pad[1] = 0; + st->pad[2] = 0; + st->pad[3] = 0; +} + + +void +poly1305_update(struct poly1305_context *st, const unsigned char *m, size_t bytes) +{ + size_t i; + + /* handle leftover */ + if (st->leftover) { + size_t want = (POLY1305_BLOCK_SIZE - st->leftover); + if (want > bytes) + want = bytes; + for (i = 0; i < want; i++) + st->buffer[st->leftover + i] = m[i]; + bytes -= want; + m += want; + st->leftover += want; + if (st->leftover < POLY1305_BLOCK_SIZE) + return; + poly1305_blocks(st, st->buffer, POLY1305_BLOCK_SIZE); + st->leftover = 0; + } + + /* process full blocks */ + if (bytes >= POLY1305_BLOCK_SIZE) { + size_t want = (bytes & ~(POLY1305_BLOCK_SIZE - 1)); + poly1305_blocks(st, m, want); + m += want; + bytes -= want; + } + + /* store leftover */ + if (bytes) { +#if (USE_MEMCPY == 1) + memcpy(st->buffer + st->leftover, m, bytes); +#else + for (i = 0; i < bytes; i++) + st->buffer[st->leftover + i] = m[i]; +#endif + st->leftover += bytes; + } +} + +void +poly1305_auth(unsigned char mac[16], const unsigned char *m, size_t bytes, const unsigned char key[32]) +{ + struct poly1305_context ctx; + poly1305_init(&ctx, key); + poly1305_update(&ctx, m, bytes); + poly1305_finish(&ctx, mac); +} diff --git a/examples/riscv/poly1305/poly1305.h b/examples/riscv/poly1305/poly1305.h new file mode 100644 index 000000000..b8ef1cfaa --- /dev/null +++ b/examples/riscv/poly1305/poly1305.h @@ -0,0 +1,32 @@ +#ifndef POLY1305_H +#define POLY1305_H + +#include +#include +#include + +#define POLY1305_KEYLEN 32 +#define POLY1305_TAGLEN 16 +#define POLY1305_BLOCK_SIZE 16 + +/* use memcpy() to copy blocks of memory (typically faster) */ +#define USE_MEMCPY 0 +/* use unaligned little-endian load/store (can be faster) */ +#define USE_UNALIGNED 0 + +struct poly1305_context { + uint32_t r[5]; + uint32_t h[5]; + uint32_t pad[4]; + size_t leftover; + unsigned char buffer[POLY1305_BLOCK_SIZE]; + unsigned char final; +}; + +void poly1305_init(struct poly1305_context *ctx, const unsigned char key[32]); +void poly1305_update(struct poly1305_context *ctx, const unsigned char *m, size_t bytes); +void poly1305_finish(struct poly1305_context *ctx, unsigned char mac[16]); +void poly1305_auth(unsigned char mac[16], const unsigned char *m, size_t bytes, const unsigned char key[32]); + +#endif /* POLY1305_H */ + From 1668b339c5ad6eae92693d19626eaefcd33bb6f6 Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Mon, 16 Sep 2024 15:16:52 +0200 Subject: [PATCH 02/95] basic lifting for pol1305 --- examples/riscv/poly1305/Holmakefile | 30 ++ examples/riscv/poly1305/poly1305.c | 4 + examples/riscv/poly1305/poly1305.da | 566 +++++++++++++++++++++ examples/riscv/poly1305/poly1305Script.sml | 20 + 4 files changed, 620 insertions(+) create mode 100644 examples/riscv/poly1305/Holmakefile create mode 100644 examples/riscv/poly1305/poly1305.da create mode 100644 examples/riscv/poly1305/poly1305Script.sml diff --git a/examples/riscv/poly1305/Holmakefile b/examples/riscv/poly1305/Holmakefile new file mode 100644 index 000000000..4d9d7dbfe --- /dev/null +++ b/examples/riscv/poly1305/Holmakefile @@ -0,0 +1,30 @@ +INCLUDES = $(HOLDIR)/examples/l3-machine-code/common \ + $(HOLDIR)/examples/l3-machine-code/arm8/model \ + $(HOLDIR)/examples/l3-machine-code/arm8/step \ + $(HOLDIR)/examples/l3-machine-code/m0/model \ + $(HOLDIR)/examples/l3-machine-code/m0/step \ + $(HOLDIR)/examples/l3-machine-code/riscv/model \ + $(HOLDIR)/examples/l3-machine-code/riscv/step \ + $(HOLBADIR)/src/theory/bir \ + $(HOLBADIR)/src/theory/bir-support \ + $(HOLBADIR)/src/theory/program_logic \ + $(HOLBADIR)/src/theory/tools/lifter \ + $(HOLBADIR)/src/theory/tools/backlifter \ + $(HOLBADIR)/src/tools/lifter \ + $(HOLBADIR)/src/tools/backlifter \ + $(HOLBADIR)/src/tools/exec \ + $(HOLBADIR)/src/tools/comp \ + $(HOLBADIR)/src/tools/wp \ + $(HOLBADIR)/src/tools/backlifter \ + $(HOLBADIR)/src/tools/symbexec \ + $(HOLBADIR)/src/tools/symbexec/examples/common \ + $(HOLBADIR)/src + +all: $(DEFAULT_TARGETS) +.PHONY: all + +ifdef POLY +ifndef HOLBA_POLYML_HEAPLESS +HOLHEAP = $(HOLBADIR)/src/holba-heap +endif +endif diff --git a/examples/riscv/poly1305/poly1305.c b/examples/riscv/poly1305/poly1305.c index 499c4464c..3d42b0aef 100644 --- a/examples/riscv/poly1305/poly1305.c +++ b/examples/riscv/poly1305/poly1305.c @@ -261,3 +261,7 @@ poly1305_auth(unsigned char mac[16], const unsigned char *m, size_t bytes, const poly1305_update(&ctx, m, bytes); poly1305_finish(&ctx, mac); } + +int main(void) { + return 0; +} diff --git a/examples/riscv/poly1305/poly1305.da b/examples/riscv/poly1305/poly1305.da new file mode 100644 index 000000000..8edfc4074 --- /dev/null +++ b/examples/riscv/poly1305/poly1305.da @@ -0,0 +1,566 @@ + +poly1305: file format elf64-littleriscv + + +Disassembly of section .text: + +0000000000010488 : + 10488: 00154783 lbu a5,1(a0) + 1048c: 0087979b slliw a5,a5,0x8 + 10490: 00254703 lbu a4,2(a0) + 10494: 0107171b slliw a4,a4,0x10 + 10498: 00e7e7b3 or a5,a5,a4 + 1049c: 00054703 lbu a4,0(a0) + 104a0: 00e7e7b3 or a5,a5,a4 + 104a4: 00354703 lbu a4,3(a0) + 104a8: 0187171b slliw a4,a4,0x18 + 104ac: 00e7e533 or a0,a5,a4 + 104b0: 0005051b sext.w a0,a0 + 104b4: 00008067 ret + +00000000000104b8 : + 104b8: f5010113 addi sp,sp,-176 + 104bc: 0a113423 sd ra,168(sp) + 104c0: 0a813023 sd s0,160(sp) + 104c4: 09213823 sd s2,144(sp) + 104c8: 09313423 sd s3,136(sp) + 104cc: 09413023 sd s4,128(sp) + 104d0: 07513c23 sd s5,120(sp) + 104d4: 07613823 sd s6,112(sp) + 104d8: 07713423 sd s7,104(sp) + 104dc: 07813023 sd s8,96(sp) + 104e0: 05a13823 sd s10,80(sp) + 104e4: 05b13423 sd s11,72(sp) + 104e8: 00050813 mv a6,a0 + 104ec: 02a13c23 sd a0,56(sp) + 104f0: 00058913 mv s2,a1 + 104f4: 05054783 lbu a5,80(a0) + 104f8: 0017b793 seqz a5,a5 + 104fc: 01879793 slli a5,a5,0x18 + 10500: 00f13423 sd a5,8(sp) + 10504: 00052b03 lw s6,0(a0) + 10508: 00452b83 lw s7,4(a0) + 1050c: 00852d03 lw s10,8(a0) + 10510: 00c52703 lw a4,12(a0) + 10514: 01052783 lw a5,16(a0) + 10518: 002b969b slliw a3,s7,0x2 + 1051c: 017686bb addw a3,a3,s7 + 10520: 002d159b slliw a1,s10,0x2 + 10524: 01a5853b addw a0,a1,s10 + 10528: 00271d9b slliw s11,a4,0x2 + 1052c: 00ed8dbb addw s11,s11,a4 + 10530: 00279c1b slliw s8,a5,0x2 + 10534: 00fc0c3b addw s8,s8,a5 + 10538: 01482a83 lw s5,20(a6) + 1053c: 01882403 lw s0,24(a6) + 10540: 01c82a03 lw s4,28(a6) + 10544: 02082983 lw s3,32(a6) + 10548: 02482583 lw a1,36(a6) + 1054c: 00b13023 sd a1,0(sp) + 10550: 00f00593 li a1,15 + 10554: 26c5f063 bgeu a1,a2,107b4 + 10558: 08913c23 sd s1,152(sp) + 1055c: 05913c23 sd s9,88(sp) + 10560: ff060613 addi a2,a2,-16 + 10564: ff067613 andi a2,a2,-16 + 10568: 01060613 addi a2,a2,16 + 1056c: 00c90633 add a2,s2,a2 + 10570: 02c13023 sd a2,32(sp) + 10574: 040004b7 lui s1,0x4000 + 10578: fff48493 addi s1,s1,-1 # 3ffffff <__global_pointer$+0x3fed7f7> + 1057c: 020b1b13 slli s6,s6,0x20 + 10580: 020b5b13 srli s6,s6,0x20 + 10584: 020c1c13 slli s8,s8,0x20 + 10588: 020c5c13 srli s8,s8,0x20 + 1058c: 02051613 slli a2,a0,0x20 + 10590: 02065613 srli a2,a2,0x20 + 10594: 00c13823 sd a2,16(sp) + 10598: 020d9d93 slli s11,s11,0x20 + 1059c: 020ddd93 srli s11,s11,0x20 + 105a0: 02069693 slli a3,a3,0x20 + 105a4: 0206d693 srli a3,a3,0x20 + 105a8: 02d13423 sd a3,40(sp) + 105ac: 020b9b93 slli s7,s7,0x20 + 105b0: 020bdb93 srli s7,s7,0x20 + 105b4: 020d1d13 slli s10,s10,0x20 + 105b8: 020d5d13 srli s10,s10,0x20 + 105bc: 02071713 slli a4,a4,0x20 + 105c0: 02075713 srli a4,a4,0x20 + 105c4: 00e13c23 sd a4,24(sp) + 105c8: 02079793 slli a5,a5,0x20 + 105cc: 0207d793 srli a5,a5,0x20 + 105d0: 02f13823 sd a5,48(sp) + 105d4: fff00c93 li s9,-1 + 105d8: 020cdc93 srli s9,s9,0x20 + 105dc: 00090513 mv a0,s2 + 105e0: ea9ff0ef jal 10488 + 105e4: 00957533 and a0,a0,s1 + 105e8: 01550abb addw s5,a0,s5 + 105ec: 00390513 addi a0,s2,3 + 105f0: e99ff0ef jal 10488 + 105f4: 0025551b srliw a0,a0,0x2 + 105f8: 00957533 and a0,a0,s1 + 105fc: 0085043b addw s0,a0,s0 + 10600: 00690513 addi a0,s2,6 + 10604: e85ff0ef jal 10488 + 10608: 0045551b srliw a0,a0,0x4 + 1060c: 00957533 and a0,a0,s1 + 10610: 01450a3b addw s4,a0,s4 + 10614: 00990513 addi a0,s2,9 + 10618: e71ff0ef jal 10488 + 1061c: 0065551b srliw a0,a0,0x6 + 10620: 013509bb addw s3,a0,s3 + 10624: 00c90513 addi a0,s2,12 + 10628: e61ff0ef jal 10488 + 1062c: 020a9693 slli a3,s5,0x20 + 10630: 0206d693 srli a3,a3,0x20 + 10634: 02041313 slli t1,s0,0x20 + 10638: 02035313 srli t1,t1,0x20 + 1063c: 02099893 slli a7,s3,0x20 + 10640: 0208d893 srli a7,a7,0x20 + 10644: 020a1813 slli a6,s4,0x20 + 10648: 02085813 srli a6,a6,0x20 + 1064c: 0085571b srliw a4,a0,0x8 + 10650: 00813783 ld a5,8(sp) + 10654: 00e7e733 or a4,a5,a4 + 10658: 00013783 ld a5,0(sp) + 1065c: 00f7073b addw a4,a4,a5 + 10660: 02071713 slli a4,a4,0x20 + 10664: 02075713 srli a4,a4,0x20 + 10668: 038307b3 mul a5,t1,s8 + 1066c: 01013503 ld a0,16(sp) + 10670: 02a88633 mul a2,a7,a0 + 10674: 00c787b3 add a5,a5,a2 + 10678: 03668633 mul a2,a3,s6 + 1067c: 00c787b3 add a5,a5,a2 + 10680: 03b80633 mul a2,a6,s11 + 10684: 00c787b3 add a5,a5,a2 + 10688: 02813603 ld a2,40(sp) + 1068c: 02e60633 mul a2,a2,a4 + 10690: 00c787b3 add a5,a5,a2 + 10694: 037685b3 mul a1,a3,s7 + 10698: 026b0633 mul a2,s6,t1 + 1069c: 00c585b3 add a1,a1,a2 + 106a0: 03b88633 mul a2,a7,s11 + 106a4: 00c585b3 add a1,a1,a2 + 106a8: 030c0633 mul a2,s8,a6 + 106ac: 00c585b3 add a1,a1,a2 + 106b0: 02e50633 mul a2,a0,a4 + 106b4: 00c585b3 add a1,a1,a2 + 106b8: 03a68533 mul a0,a3,s10 + 106bc: 03730633 mul a2,t1,s7 + 106c0: 00c50533 add a0,a0,a2 + 106c4: 030b0633 mul a2,s6,a6 + 106c8: 00c50533 add a0,a0,a2 + 106cc: 031c0633 mul a2,s8,a7 + 106d0: 00c50533 add a0,a0,a2 + 106d4: 02ed8633 mul a2,s11,a4 + 106d8: 00c50533 add a0,a0,a2 + 106dc: 01813e83 ld t4,24(sp) + 106e0: 03d68633 mul a2,a3,t4 + 106e4: 03a30e33 mul t3,t1,s10 + 106e8: 01c60633 add a2,a2,t3 + 106ec: 031b0e33 mul t3,s6,a7 + 106f0: 01c60633 add a2,a2,t3 + 106f4: 03780e33 mul t3,a6,s7 + 106f8: 01c60633 add a2,a2,t3 + 106fc: 02ec0e33 mul t3,s8,a4 + 10700: 01c60633 add a2,a2,t3 + 10704: 03013e03 ld t3,48(sp) + 10708: 02de06b3 mul a3,t3,a3 + 1070c: 03d30333 mul t1,t1,t4 + 10710: 006686b3 add a3,a3,t1 + 10714: 037888b3 mul a7,a7,s7 + 10718: 011686b3 add a3,a3,a7 + 1071c: 03a80833 mul a6,a6,s10 + 10720: 010686b3 add a3,a3,a6 + 10724: 02eb0733 mul a4,s6,a4 + 10728: 00e68733 add a4,a3,a4 + 1072c: 0097f6b3 and a3,a5,s1 + 10730: 01a7d793 srli a5,a5,0x1a + 10734: 0197f7b3 and a5,a5,s9 + 10738: 00b787b3 add a5,a5,a1 + 1073c: 0097f5b3 and a1,a5,s1 + 10740: 01a7d793 srli a5,a5,0x1a + 10744: 0197f7b3 and a5,a5,s9 + 10748: 00a787b3 add a5,a5,a0 + 1074c: 0097fa33 and s4,a5,s1 + 10750: 000a0a1b sext.w s4,s4 + 10754: 01a7d793 srli a5,a5,0x1a + 10758: 0197f7b3 and a5,a5,s9 + 1075c: 00c787b3 add a5,a5,a2 + 10760: 0097f9b3 and s3,a5,s1 + 10764: 0009899b sext.w s3,s3 + 10768: 01a7d793 srli a5,a5,0x1a + 1076c: 0197f7b3 and a5,a5,s9 + 10770: 00e787b3 add a5,a5,a4 + 10774: 0097f733 and a4,a5,s1 + 10778: 0007071b sext.w a4,a4 + 1077c: 00e13023 sd a4,0(sp) + 10780: 01a7d793 srli a5,a5,0x1a + 10784: 0027941b slliw s0,a5,0x2 + 10788: 00f4043b addw s0,s0,a5 + 1078c: 00d4043b addw s0,s0,a3 + 10790: 0084fab3 and s5,s1,s0 + 10794: 000a8a9b sext.w s5,s5 + 10798: 01a4541b srliw s0,s0,0x1a + 1079c: 00b4043b addw s0,s0,a1 + 107a0: 01090913 addi s2,s2,16 + 107a4: 02013783 ld a5,32(sp) + 107a8: e2f91ae3 bne s2,a5,105dc + 107ac: 09813483 ld s1,152(sp) + 107b0: 05813c83 ld s9,88(sp) + 107b4: 03813783 ld a5,56(sp) + 107b8: 0157aa23 sw s5,20(a5) + 107bc: 0087ac23 sw s0,24(a5) + 107c0: 0147ae23 sw s4,28(a5) + 107c4: 0337a023 sw s3,32(a5) + 107c8: 00013703 ld a4,0(sp) + 107cc: 02e7a223 sw a4,36(a5) + 107d0: 0a813083 ld ra,168(sp) + 107d4: 0a013403 ld s0,160(sp) + 107d8: 09013903 ld s2,144(sp) + 107dc: 08813983 ld s3,136(sp) + 107e0: 08013a03 ld s4,128(sp) + 107e4: 07813a83 ld s5,120(sp) + 107e8: 07013b03 ld s6,112(sp) + 107ec: 06813b83 ld s7,104(sp) + 107f0: 06013c03 ld s8,96(sp) + 107f4: 05013d03 ld s10,80(sp) + 107f8: 04813d83 ld s11,72(sp) + 107fc: 0b010113 addi sp,sp,176 + 10800: 00008067 ret + +0000000000010804 : + 10804: fe010113 addi sp,sp,-32 + 10808: 00113c23 sd ra,24(sp) + 1080c: 00813823 sd s0,16(sp) + 10810: 00913423 sd s1,8(sp) + 10814: 00050413 mv s0,a0 + 10818: 00058493 mv s1,a1 + 1081c: 00058513 mv a0,a1 + 10820: c69ff0ef jal 10488 + 10824: 02651513 slli a0,a0,0x26 + 10828: 02655513 srli a0,a0,0x26 + 1082c: 00a42023 sw a0,0(s0) + 10830: 00348513 addi a0,s1,3 + 10834: c55ff0ef jal 10488 + 10838: 0025551b srliw a0,a0,0x2 + 1083c: 040007b7 lui a5,0x4000 + 10840: f0378793 addi a5,a5,-253 # 3ffff03 <__global_pointer$+0x3fed6fb> + 10844: 00f57533 and a0,a0,a5 + 10848: 00a42223 sw a0,4(s0) + 1084c: 00648513 addi a0,s1,6 + 10850: c39ff0ef jal 10488 + 10854: 0045551b srliw a0,a0,0x4 + 10858: 03ffc7b7 lui a5,0x3ffc + 1085c: 0ff78793 addi a5,a5,255 # 3ffc0ff <__global_pointer$+0x3fe98f7> + 10860: 00f57533 and a0,a0,a5 + 10864: 00a42423 sw a0,8(s0) + 10868: 00948513 addi a0,s1,9 + 1086c: c1dff0ef jal 10488 + 10870: 0065551b srliw a0,a0,0x6 + 10874: 03f047b7 lui a5,0x3f04 + 10878: fff78793 addi a5,a5,-1 # 3f03fff <__global_pointer$+0x3ef17f7> + 1087c: 00f57533 and a0,a0,a5 + 10880: 00a42623 sw a0,12(s0) + 10884: 00c48513 addi a0,s1,12 + 10888: c01ff0ef jal 10488 + 1088c: 02451513 slli a0,a0,0x24 + 10890: 02c55513 srli a0,a0,0x2c + 10894: 00a42823 sw a0,16(s0) + 10898: 00042a23 sw zero,20(s0) + 1089c: 00042c23 sw zero,24(s0) + 108a0: 00042e23 sw zero,28(s0) + 108a4: 02042023 sw zero,32(s0) + 108a8: 02042223 sw zero,36(s0) + 108ac: 01048513 addi a0,s1,16 + 108b0: bd9ff0ef jal 10488 + 108b4: 02a42423 sw a0,40(s0) + 108b8: 01448513 addi a0,s1,20 + 108bc: bcdff0ef jal 10488 + 108c0: 02a42623 sw a0,44(s0) + 108c4: 01848513 addi a0,s1,24 + 108c8: bc1ff0ef jal 10488 + 108cc: 02a42823 sw a0,48(s0) + 108d0: 01c48513 addi a0,s1,28 + 108d4: bb5ff0ef jal 10488 + 108d8: 02a42a23 sw a0,52(s0) + 108dc: 02043c23 sd zero,56(s0) + 108e0: 04040823 sb zero,80(s0) + 108e4: 01813083 ld ra,24(sp) + 108e8: 01013403 ld s0,16(sp) + 108ec: 00813483 ld s1,8(sp) + 108f0: 02010113 addi sp,sp,32 + 108f4: 00008067 ret + +00000000000108f8 : + 108f8: fe010113 addi sp,sp,-32 + 108fc: 00113c23 sd ra,24(sp) + 10900: 00813823 sd s0,16(sp) + 10904: 00913423 sd s1,8(sp) + 10908: 00050413 mv s0,a0 + 1090c: 00058493 mv s1,a1 + 10910: 03853783 ld a5,56(a0) + 10914: 04078663 beqz a5,10960 + 10918: 00f50733 add a4,a0,a5 + 1091c: 00100693 li a3,1 + 10920: 04d70023 sb a3,64(a4) + 10924: 00178713 addi a4,a5,1 + 10928: 00f00693 li a3,15 + 1092c: 00e6ee63 bltu a3,a4,10948 + 10930: 04178793 addi a5,a5,65 + 10934: 00f507b3 add a5,a0,a5 + 10938: 05050713 addi a4,a0,80 + 1093c: 00078023 sb zero,0(a5) + 10940: 00178793 addi a5,a5,1 + 10944: fee79ce3 bne a5,a4,1093c + 10948: 00100793 li a5,1 + 1094c: 04f40823 sb a5,80(s0) + 10950: 01000613 li a2,16 + 10954: 04040593 addi a1,s0,64 + 10958: 00040513 mv a0,s0 + 1095c: b5dff0ef jal 104b8 + 10960: 01442603 lw a2,20(s0) + 10964: 01842783 lw a5,24(s0) + 10968: 01c42503 lw a0,28(s0) + 1096c: 02042583 lw a1,32(s0) + 10970: 02442703 lw a4,36(s0) + 10974: 04000337 lui t1,0x4000 + 10978: fff30313 addi t1,t1,-1 # 3ffffff <__global_pointer$+0x3fed7f7> + 1097c: 0067f6b3 and a3,a5,t1 + 10980: 01a7d79b srliw a5,a5,0x1a + 10984: 00a787bb addw a5,a5,a0 + 10988: 00f37eb3 and t4,t1,a5 + 1098c: 01a7d79b srliw a5,a5,0x1a + 10990: 00b787bb addw a5,a5,a1 + 10994: 00f37e33 and t3,t1,a5 + 10998: 01a7d79b srliw a5,a5,0x1a + 1099c: 00e787bb addw a5,a5,a4 + 109a0: 00f37f33 and t5,t1,a5 + 109a4: 01a7d79b srliw a5,a5,0x1a + 109a8: 0027971b slliw a4,a5,0x2 + 109ac: 00f707bb addw a5,a4,a5 + 109b0: 00c787bb addw a5,a5,a2 + 109b4: 00f372b3 and t0,t1,a5 + 109b8: 01a7d79b srliw a5,a5,0x1a + 109bc: 00d78fbb addw t6,a5,a3 + 109c0: 0052861b addiw a2,t0,5 + 109c4: 01a6579b srliw a5,a2,0x1a + 109c8: 01f787bb addw a5,a5,t6 + 109cc: 01a7d89b srliw a7,a5,0x1a + 109d0: 01d888bb addw a7,a7,t4 + 109d4: 01a8d69b srliw a3,a7,0x1a + 109d8: 01c686bb addw a3,a3,t3 + 109dc: 01a6d51b srliw a0,a3,0x1a + 109e0: fc000737 lui a4,0xfc000 + 109e4: 01e7073b addw a4,a4,t5 + 109e8: 00e5053b addw a0,a0,a4 + 109ec: 01f5581b srliw a6,a0,0x1f + 109f0: fff8081b addiw a6,a6,-1 + 109f4: 010675b3 and a1,a2,a6 + 109f8: 0005859b sext.w a1,a1 + 109fc: 0107f633 and a2,a5,a6 + 10a00: 0006061b sext.w a2,a2 + 10a04: 0108f7b3 and a5,a7,a6 + 10a08: 0007879b sext.w a5,a5 + 10a0c: 0106f6b3 and a3,a3,a6 + 10a10: 0006869b sext.w a3,a3 + 10a14: 41f5571b sraiw a4,a0,0x1f + 10a18: 00e2f2b3 and t0,t0,a4 + 10a1c: 0002829b sext.w t0,t0 + 10a20: 0065f5b3 and a1,a1,t1 + 10a24: 0055e5b3 or a1,a1,t0 + 10a28: 00efffb3 and t6,t6,a4 + 10a2c: 000f8f9b sext.w t6,t6 + 10a30: 00667633 and a2,a2,t1 + 10a34: 01f66633 or a2,a2,t6 + 10a38: 00eefeb3 and t4,t4,a4 + 10a3c: 000e8e9b sext.w t4,t4 + 10a40: 0067f7b3 and a5,a5,t1 + 10a44: 01d7e7b3 or a5,a5,t4 + 10a48: 00ee7e33 and t3,t3,a4 + 10a4c: 000e0e1b sext.w t3,t3 + 10a50: 0066f6b3 and a3,a3,t1 + 10a54: 01c6e6b3 or a3,a3,t3 + 10a58: 00ef7733 and a4,t5,a4 + 10a5c: 01a6189b slliw a7,a2,0x1a + 10a60: 0115e5b3 or a1,a1,a7 + 10a64: 0066561b srliw a2,a2,0x6 + 10a68: 00c7de9b srliw t4,a5,0xc + 10a6c: 0126d31b srliw t1,a3,0x12 + 10a70: 02842e03 lw t3,40(s0) + 10a74: 00be08bb addw a7,t3,a1 + 10a78: 02059593 slli a1,a1,0x20 + 10a7c: 0205d593 srli a1,a1,0x20 + 10a80: 020e1e13 slli t3,t3,0x20 + 10a84: 020e5e13 srli t3,t3,0x20 + 10a88: 01c585b3 add a1,a1,t3 + 10a8c: 0205d593 srli a1,a1,0x20 + 10a90: 0147979b slliw a5,a5,0x14 + 10a94: 00c7e7b3 or a5,a5,a2 + 10a98: 02079793 slli a5,a5,0x20 + 10a9c: 0207d793 srli a5,a5,0x20 + 10aa0: 02c46603 lwu a2,44(s0) + 10aa4: 00c787b3 add a5,a5,a2 + 10aa8: 00b787b3 add a5,a5,a1 + 10aac: 0207d613 srli a2,a5,0x20 + 10ab0: 00e6969b slliw a3,a3,0xe + 10ab4: 01d6e6b3 or a3,a3,t4 + 10ab8: 02069693 slli a3,a3,0x20 + 10abc: 0206d693 srli a3,a3,0x20 + 10ac0: 03046583 lwu a1,48(s0) + 10ac4: 00b686b3 add a3,a3,a1 + 10ac8: 00c686b3 add a3,a3,a2 + 10acc: 0206d613 srli a2,a3,0x20 + 10ad0: 01057533 and a0,a0,a6 + 10ad4: 00a76733 or a4,a4,a0 + 10ad8: 0087171b slliw a4,a4,0x8 + 10adc: 00676733 or a4,a4,t1 + 10ae0: 02071713 slli a4,a4,0x20 + 10ae4: 02075713 srli a4,a4,0x20 + 10ae8: 03446583 lwu a1,52(s0) + 10aec: 00b70733 add a4,a4,a1 + 10af0: 00c70733 add a4,a4,a2 + 10af4: 01148023 sb a7,0(s1) + 10af8: 0088d61b srliw a2,a7,0x8 + 10afc: 00c480a3 sb a2,1(s1) + 10b00: 0108d61b srliw a2,a7,0x10 + 10b04: 00c48123 sb a2,2(s1) + 10b08: 0188d89b srliw a7,a7,0x18 + 10b0c: 011481a3 sb a7,3(s1) + 10b10: 00f48223 sb a5,4(s1) + 10b14: 0087d61b srliw a2,a5,0x8 + 10b18: 00c482a3 sb a2,5(s1) + 10b1c: 0107d61b srliw a2,a5,0x10 + 10b20: 00c48323 sb a2,6(s1) + 10b24: 0187d79b srliw a5,a5,0x18 + 10b28: 00f483a3 sb a5,7(s1) + 10b2c: 00d48423 sb a3,8(s1) + 10b30: 0086d79b srliw a5,a3,0x8 + 10b34: 00f484a3 sb a5,9(s1) + 10b38: 0106d79b srliw a5,a3,0x10 + 10b3c: 00f48523 sb a5,10(s1) + 10b40: 0186d69b srliw a3,a3,0x18 + 10b44: 00d485a3 sb a3,11(s1) + 10b48: 00e48623 sb a4,12(s1) + 10b4c: 0087579b srliw a5,a4,0x8 + 10b50: 00f486a3 sb a5,13(s1) + 10b54: 0107579b srliw a5,a4,0x10 + 10b58: 00f48723 sb a5,14(s1) + 10b5c: 0187571b srliw a4,a4,0x18 + 10b60: 00e487a3 sb a4,15(s1) + 10b64: 00042a23 sw zero,20(s0) + 10b68: 00042c23 sw zero,24(s0) + 10b6c: 00042e23 sw zero,28(s0) + 10b70: 02042023 sw zero,32(s0) + 10b74: 02042223 sw zero,36(s0) + 10b78: 00042023 sw zero,0(s0) + 10b7c: 00042223 sw zero,4(s0) + 10b80: 00042423 sw zero,8(s0) + 10b84: 00042623 sw zero,12(s0) + 10b88: 00042823 sw zero,16(s0) + 10b8c: 02042423 sw zero,40(s0) + 10b90: 02042623 sw zero,44(s0) + 10b94: 02042823 sw zero,48(s0) + 10b98: 02042a23 sw zero,52(s0) + 10b9c: 01813083 ld ra,24(sp) + 10ba0: 01013403 ld s0,16(sp) + 10ba4: 00813483 ld s1,8(sp) + 10ba8: 02010113 addi sp,sp,32 + 10bac: 00008067 ret + +0000000000010bb0 : + 10bb0: fd010113 addi sp,sp,-48 + 10bb4: 02113423 sd ra,40(sp) + 10bb8: 02813023 sd s0,32(sp) + 10bbc: 00913c23 sd s1,24(sp) + 10bc0: 01213823 sd s2,16(sp) + 10bc4: 00050493 mv s1,a0 + 10bc8: 00058413 mv s0,a1 + 10bcc: 00060913 mv s2,a2 + 10bd0: 03853603 ld a2,56(a0) + 10bd4: 06060463 beqz a2,10c3c + 10bd8: 01000513 li a0,16 + 10bdc: 40c50533 sub a0,a0,a2 + 10be0: 00a97463 bgeu s2,a0,10be8 + 10be4: 00090513 mv a0,s2 + 10be8: 02050463 beqz a0,10c10 + 10bec: 00040793 mv a5,s0 + 10bf0: 04060713 addi a4,a2,64 + 10bf4: 00e48733 add a4,s1,a4 + 10bf8: 008505b3 add a1,a0,s0 + 10bfc: 0007c683 lbu a3,0(a5) + 10c00: 00d70023 sb a3,0(a4) # fffffffffc000000 <__global_pointer$+0xfffffffffbfed7f8> + 10c04: 00178793 addi a5,a5,1 + 10c08: 00170713 addi a4,a4,1 + 10c0c: feb798e3 bne a5,a1,10bfc + 10c10: 00a60633 add a2,a2,a0 + 10c14: 02c4bc23 sd a2,56(s1) + 10c18: 00f00793 li a5,15 + 10c1c: 06c7f063 bgeu a5,a2,10c7c + 10c20: 40a90933 sub s2,s2,a0 + 10c24: 00a40433 add s0,s0,a0 + 10c28: 01000613 li a2,16 + 10c2c: 04048593 addi a1,s1,64 + 10c30: 00048513 mv a0,s1 + 10c34: 885ff0ef jal 104b8 + 10c38: 0204bc23 sd zero,56(s1) + 10c3c: 00f00793 li a5,15 + 10c40: 0527ea63 bltu a5,s2,10c94 + 10c44: 02090c63 beqz s2,10c7c + 10c48: 00040793 mv a5,s0 + 10c4c: 0384b703 ld a4,56(s1) + 10c50: 04070713 addi a4,a4,64 + 10c54: 00e48733 add a4,s1,a4 + 10c58: 01240433 add s0,s0,s2 + 10c5c: 0007c683 lbu a3,0(a5) + 10c60: 00d70023 sb a3,0(a4) + 10c64: 00178793 addi a5,a5,1 + 10c68: 00170713 addi a4,a4,1 + 10c6c: fe8798e3 bne a5,s0,10c5c + 10c70: 0384b783 ld a5,56(s1) + 10c74: 012787b3 add a5,a5,s2 + 10c78: 02f4bc23 sd a5,56(s1) + 10c7c: 02813083 ld ra,40(sp) + 10c80: 02013403 ld s0,32(sp) + 10c84: 01813483 ld s1,24(sp) + 10c88: 01013903 ld s2,16(sp) + 10c8c: 03010113 addi sp,sp,48 + 10c90: 00008067 ret + 10c94: 01313423 sd s3,8(sp) + 10c98: ff097993 andi s3,s2,-16 + 10c9c: 00098613 mv a2,s3 + 10ca0: 00040593 mv a1,s0 + 10ca4: 00048513 mv a0,s1 + 10ca8: 811ff0ef jal 104b8 + 10cac: 01340433 add s0,s0,s3 + 10cb0: 41390933 sub s2,s2,s3 + 10cb4: 00813983 ld s3,8(sp) + 10cb8: f8dff06f j 10c44 + +0000000000010cbc : + 10cbc: f8010113 addi sp,sp,-128 + 10cc0: 06113c23 sd ra,120(sp) + 10cc4: 06813823 sd s0,112(sp) + 10cc8: 06913423 sd s1,104(sp) + 10ccc: 07213023 sd s2,96(sp) + 10cd0: 00050413 mv s0,a0 + 10cd4: 00058493 mv s1,a1 + 10cd8: 00060913 mv s2,a2 + 10cdc: 00068593 mv a1,a3 + 10ce0: 00810513 addi a0,sp,8 + 10ce4: b21ff0ef jal 10804 + 10ce8: 00090613 mv a2,s2 + 10cec: 00048593 mv a1,s1 + 10cf0: 00810513 addi a0,sp,8 + 10cf4: ebdff0ef jal 10bb0 + 10cf8: 00040593 mv a1,s0 + 10cfc: 00810513 addi a0,sp,8 + 10d00: bf9ff0ef jal 108f8 + 10d04: 07813083 ld ra,120(sp) + 10d08: 07013403 ld s0,112(sp) + 10d0c: 06813483 ld s1,104(sp) + 10d10: 06013903 ld s2,96(sp) + 10d14: 08010113 addi sp,sp,128 + 10d18: 00008067 ret diff --git a/examples/riscv/poly1305/poly1305Script.sml b/examples/riscv/poly1305/poly1305Script.sml new file mode 100644 index 000000000..88643a69e --- /dev/null +++ b/examples/riscv/poly1305/poly1305Script.sml @@ -0,0 +1,20 @@ +open HolKernel Parse; + +open bir_lifter_interfaceLib; +open birs_auxLib; + +val _ = Parse.current_backend := PPBackEnd.vt100_terminal; +val _ = set_trace "bir_inst_lifting.DEBUG_LEVEL" 2; + +val _ = new_theory "poly1305"; + +val _ = lift_da_and_store "poly1305" "poly1305.da" da_riscv ((Arbnum.fromInt 0x10488), (Arbnum.fromInt 0x10D1C)); + +(* ----------------------------------------- *) +(* Program variable definitions and theorems *) +(* ----------------------------------------- *) + +val bir_prog_def = DB.fetch "poly1305" "bir_poly1305_prog_def"; +val _ = gen_prog_vars_birenvtyl_defthms "poly1305" bir_prog_def; + +val _ = export_theory (); From 11727694e78abb263fec212010b147e8c864fe97 Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Mon, 16 Sep 2024 15:53:34 +0200 Subject: [PATCH 03/95] basic symbolic execution for poly1305 U8TO32 subroutine --- .../riscv/poly1305/poly1305_specScript.sml | 72 +++++++++++++++++++ .../poly1305/poly1305_symb_execScript.sml | 35 +++++++++ 2 files changed, 107 insertions(+) create mode 100644 examples/riscv/poly1305/poly1305_specScript.sml create mode 100644 examples/riscv/poly1305/poly1305_symb_execScript.sml diff --git a/examples/riscv/poly1305/poly1305_specScript.sml b/examples/riscv/poly1305/poly1305_specScript.sml new file mode 100644 index 000000000..c931dc41d --- /dev/null +++ b/examples/riscv/poly1305/poly1305_specScript.sml @@ -0,0 +1,72 @@ +open HolKernel boolLib Parse bossLib; + +open markerTheory; + +open wordsTheory; + +open bir_programSyntax bir_program_labelsTheory; +open bir_immTheory bir_valuesTheory bir_expTheory; +open bir_tsTheory bir_bool_expTheory bir_programTheory; + +open bir_riscv_backlifterTheory; +open bir_backlifterLib; +open bir_compositionLib; + +open bir_lifting_machinesTheory; +open bir_typing_expTheory; +open bir_htTheory; + +open bir_predLib; +open bir_smtLib; + +open bir_symbTheory birs_auxTheory; +open HolBACoreSimps; +open bir_program_transfTheory; + +open total_program_logicTheory; +open total_ext_program_logicTheory; +open symb_prop_transferTheory; + +open jgmt_rel_bir_contTheory; + +open pred_setTheory; + +open program_logicSimps; + +open bir_env_oldTheory; +open bir_program_varsTheory; + +val _ = new_theory "poly1305_spec"; + +(* ---------------- *) +(* Block boundaries *) +(* ---------------- *) + +(* U8TO32 *) + +Definition poly1305_u8to32_init_addr_def: + poly1305_u8to32_init_addr : word64 = 0x10488w +End + +Definition poly1305_u8to32_end_addr_def: + poly1305_u8to32_end_addr : word64 = 0x104b4w +End + +(* --------------- *) +(* BSPEC contracts *) +(* --------------- *) + +val bspec_poly1305_u8to32_pre_tm = bslSyntax.bandl [ + mem_addrs_aligned_prog_disj_bir_tm mem_params_standard "x10", + ``BExp_BinPred + BIExp_Equal + (BExp_Den (BVar "x15" (BType_Imm Bit64))) + (BExp_Const (Imm64 pre_x15))`` +]; + +Definition bspec_poly1305_u8to32_pre_def: + bspec_poly1305_u8to32_pre (pre_x15:word64) : bir_exp_t = + ^bspec_poly1305_u8to32_pre_tm +End + +val _ = export_theory (); diff --git a/examples/riscv/poly1305/poly1305_symb_execScript.sml b/examples/riscv/poly1305/poly1305_symb_execScript.sml new file mode 100644 index 000000000..393fe9e67 --- /dev/null +++ b/examples/riscv/poly1305/poly1305_symb_execScript.sml @@ -0,0 +1,35 @@ +open HolKernel Parse boolLib bossLib; + +open wordsTheory; + +open bir_symbLib; + +open poly1305Theory poly1305_specTheory; + +val _ = new_theory "poly1305_symb_exec"; + +(* --------------------------- *) +(* Symbolic analysis execution *) +(* --------------------------- *) + +val _ = show_tags := true; + +(* ------ *) +(* U8TO32 *) +(* ------ *) + +val (bsysprecond_thm, symb_analysis_thm) = + bir_symb_analysis_thm + bir_poly1305_prog_def + poly1305_u8to32_init_addr_def [poly1305_u8to32_end_addr_def] + bspec_poly1305_u8to32_pre_def poly1305_birenvtyl_def; + +val _ = Portable.pprint Tag.pp_tag (tag bsysprecond_thm); + +Theorem poly1305_u8to32_bsysprecond_thm = bsysprecond_thm + +val _ = Portable.pprint Tag.pp_tag (tag symb_analysis_thm); + +Theorem poly1305_u8to32_symb_analysis_thm = symb_analysis_thm + +val _ = export_theory (); From 752643901773ce117bc2a78a7ab6288e6b62024f Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Tue, 17 Sep 2024 17:50:17 +0200 Subject: [PATCH 04/95] split up symbolic execution for chacha --- examples/riscv/chacha/chacha_specScript.sml | 31 ++++++++++++++-- ...sml => chacha_symb_exec_ivsetupScript.sml} | 2 +- .../chacha_symb_exec_keysetupScript.sml | 35 +++++++++++++++++++ 3 files changed, 65 insertions(+), 3 deletions(-) rename examples/riscv/chacha/{chacha_symb_execScript.sml => chacha_symb_exec_ivsetupScript.sml} (94%) create mode 100644 examples/riscv/chacha/chacha_symb_exec_keysetupScript.sml diff --git a/examples/riscv/chacha/chacha_specScript.sml b/examples/riscv/chacha/chacha_specScript.sml index 7177034d7..f727f921d 100644 --- a/examples/riscv/chacha/chacha_specScript.sml +++ b/examples/riscv/chacha/chacha_specScript.sml @@ -42,6 +42,16 @@ val _ = new_theory "chacha_spec"; (* Block boundaries *) (* ---------------- *) +(* keysetup *) + +Definition chacha_keysetup_init_addr_def: + chacha_keysetup_init_addr : word64 = 0x10488w +End + +Definition chacha_keysetup_end_addr_def: + chacha_keysetup_end_addr : word64 = (*0x106a8w*) 0x1053cw +End + (* ivsetup *) Definition chacha_ivsetup_init_addr_def: @@ -56,7 +66,24 @@ End (* BSPEC contracts *) (* --------------- *) -val bspec_chacha_pre_tm = bslSyntax.bandl [ +(* keysetup *) + +val bspec_chacha_keysetup_pre_tm = bslSyntax.bandl [ + mem_addrs_aligned_prog_disj_bir_tm mem_params_standard "x10", + ``BExp_BinPred + BIExp_Equal + (BExp_Den (BVar "x15" (BType_Imm Bit64))) + (BExp_Const (Imm64 pre_x15))`` +]; + +Definition bspec_chacha_keysetup_pre_def: + bspec_chacha_keysetup_pre (pre_x15:word64) : bir_exp_t = + ^bspec_chacha_keysetup_pre_tm +End + +(* ivsetup *) + +val bspec_chacha_ivsetup_pre_tm = bslSyntax.bandl [ mem_addrs_aligned_prog_disj_bir_tm mem_params_standard "x10", ``BExp_BinPred BIExp_Equal @@ -66,7 +93,7 @@ val bspec_chacha_pre_tm = bslSyntax.bandl [ Definition bspec_chacha_ivsetup_pre_def: bspec_chacha_ivsetup_pre (pre_x15:word64) : bir_exp_t = - ^bspec_chacha_pre_tm + ^bspec_chacha_ivsetup_pre_tm End val _ = export_theory (); diff --git a/examples/riscv/chacha/chacha_symb_execScript.sml b/examples/riscv/chacha/chacha_symb_exec_ivsetupScript.sml similarity index 94% rename from examples/riscv/chacha/chacha_symb_execScript.sml rename to examples/riscv/chacha/chacha_symb_exec_ivsetupScript.sml index fb037c66d..eea5874e8 100644 --- a/examples/riscv/chacha/chacha_symb_execScript.sml +++ b/examples/riscv/chacha/chacha_symb_exec_ivsetupScript.sml @@ -6,7 +6,7 @@ open bir_symbLib; open chachaTheory chacha_specTheory; -val _ = new_theory "chacha_symb_exec"; +val _ = new_theory "chacha_symb_exec_ivsetup"; (* --------------------------- *) (* Symbolic analysis execution *) diff --git a/examples/riscv/chacha/chacha_symb_exec_keysetupScript.sml b/examples/riscv/chacha/chacha_symb_exec_keysetupScript.sml new file mode 100644 index 000000000..fae722243 --- /dev/null +++ b/examples/riscv/chacha/chacha_symb_exec_keysetupScript.sml @@ -0,0 +1,35 @@ +open HolKernel Parse boolLib bossLib; + +open wordsTheory; + +open bir_symbLib; + +open chachaTheory chacha_specTheory; + +val _ = new_theory "chacha_symb_exec_keysetup"; + +(* --------------------------- *) +(* Symbolic analysis execution *) +(* --------------------------- *) + +val _ = show_tags := true; + +(* -------- *) +(* keysetup *) +(* -------- *) + +val (bsysprecond_thm, symb_analysis_thm) = + bir_symb_analysis_thm + bir_chacha_prog_def + chacha_keysetup_init_addr_def [chacha_keysetup_end_addr_def] + bspec_chacha_keysetup_pre_def chacha_birenvtyl_def; + +val _ = Portable.pprint Tag.pp_tag (tag bsysprecond_thm); + +Theorem chacha_keysetup_bsysprecond_thm = bsysprecond_thm + +val _ = Portable.pprint Tag.pp_tag (tag symb_analysis_thm); + +Theorem chacha_keysetup_symb_analysis_thm = symb_analysis_thm + +val _ = export_theory (); From c077f3618bfeaa66026dc8d5163353aed3c83d7b Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Wed, 18 Sep 2024 16:09:24 +0200 Subject: [PATCH 05/95] add experimental ifelse example --- examples/riscv/ifelse/Holmakefile | 30 +++++++++ examples/riscv/ifelse/ifelse.c | 42 ++++++++++++ examples/riscv/ifelse/ifelse.da | 27 ++++++++ examples/riscv/ifelse/ifelseScript.sml | 20 ++++++ examples/riscv/ifelse/ifelse_specScript.sml | 67 +++++++++++++++++++ .../riscv/ifelse/ifelse_symb_execScript.sml | 31 +++++++++ 6 files changed, 217 insertions(+) create mode 100644 examples/riscv/ifelse/Holmakefile create mode 100644 examples/riscv/ifelse/ifelse.c create mode 100644 examples/riscv/ifelse/ifelse.da create mode 100644 examples/riscv/ifelse/ifelseScript.sml create mode 100644 examples/riscv/ifelse/ifelse_specScript.sml create mode 100644 examples/riscv/ifelse/ifelse_symb_execScript.sml diff --git a/examples/riscv/ifelse/Holmakefile b/examples/riscv/ifelse/Holmakefile new file mode 100644 index 000000000..4d9d7dbfe --- /dev/null +++ b/examples/riscv/ifelse/Holmakefile @@ -0,0 +1,30 @@ +INCLUDES = $(HOLDIR)/examples/l3-machine-code/common \ + $(HOLDIR)/examples/l3-machine-code/arm8/model \ + $(HOLDIR)/examples/l3-machine-code/arm8/step \ + $(HOLDIR)/examples/l3-machine-code/m0/model \ + $(HOLDIR)/examples/l3-machine-code/m0/step \ + $(HOLDIR)/examples/l3-machine-code/riscv/model \ + $(HOLDIR)/examples/l3-machine-code/riscv/step \ + $(HOLBADIR)/src/theory/bir \ + $(HOLBADIR)/src/theory/bir-support \ + $(HOLBADIR)/src/theory/program_logic \ + $(HOLBADIR)/src/theory/tools/lifter \ + $(HOLBADIR)/src/theory/tools/backlifter \ + $(HOLBADIR)/src/tools/lifter \ + $(HOLBADIR)/src/tools/backlifter \ + $(HOLBADIR)/src/tools/exec \ + $(HOLBADIR)/src/tools/comp \ + $(HOLBADIR)/src/tools/wp \ + $(HOLBADIR)/src/tools/backlifter \ + $(HOLBADIR)/src/tools/symbexec \ + $(HOLBADIR)/src/tools/symbexec/examples/common \ + $(HOLBADIR)/src + +all: $(DEFAULT_TARGETS) +.PHONY: all + +ifdef POLY +ifndef HOLBA_POLYML_HEAPLESS +HOLHEAP = $(HOLBADIR)/src/holba-heap +endif +endif diff --git a/examples/riscv/ifelse/ifelse.c b/examples/riscv/ifelse/ifelse.c new file mode 100644 index 000000000..4cd7bdcf0 --- /dev/null +++ b/examples/riscv/ifelse/ifelse.c @@ -0,0 +1,42 @@ +#include + +void ifelse(uint64_t *x,uint64_t *k,uint32_t kbits) +{ + uint64_t *constants; + *x += 1; + *x += 2; + *x += 3; + if (kbits == 256) { + constants = k; + } else { + constants = k + 4; + *x += 8; + } + *x += 1; + *x += 2; + *x += *constants; + *x += *constants; +} + +/* +uint64_t ifelse(uint64_t *i, uint64_t j) { + uint64_t ret; + *i += 3; + if (j == 256) { + i += 16; + ret = 0; + } else { + ret = 1; + } + ret += 4334; + ret -= 345; + return ret; +} +*/ + +int main(void) { + uint64_t i = 43434334; + uint64_t a = 0; + ifelse(&i, &a, 256); + return 0; +} diff --git a/examples/riscv/ifelse/ifelse.da b/examples/riscv/ifelse/ifelse.da new file mode 100644 index 000000000..23ec62310 --- /dev/null +++ b/examples/riscv/ifelse/ifelse.da @@ -0,0 +1,27 @@ + +ifelse: file format elf64-littleriscv + + +Disassembly of section .text: + +0000000000010488 : + 10488: 00053783 ld a5,0(a0) + 1048c: 10000713 li a4,256 + 10490: 02e60863 beq a2,a4,104c0 + 10494: 02058593 addi a1,a1,32 + 10498: 00e78793 addi a5,a5,14 + 1049c: 00378793 addi a5,a5,3 + 104a0: 00f53023 sd a5,0(a0) + 104a4: 0005b703 ld a4,0(a1) + 104a8: 00e787b3 add a5,a5,a4 + 104ac: 00f53023 sd a5,0(a0) + 104b0: 0005b703 ld a4,0(a1) + 104b4: 00f707b3 add a5,a4,a5 + 104b8: 00f53023 sd a5,0(a0) + 104bc: 00008067 ret + 104c0: 00678793 addi a5,a5,6 + 104c4: fd9ff06f j 1049c + +00000000000104c8
: + 104c8: 00000513 li a0,0 + 104cc: 00008067 ret diff --git a/examples/riscv/ifelse/ifelseScript.sml b/examples/riscv/ifelse/ifelseScript.sml new file mode 100644 index 000000000..75355212f --- /dev/null +++ b/examples/riscv/ifelse/ifelseScript.sml @@ -0,0 +1,20 @@ +open HolKernel Parse; + +open bir_lifter_interfaceLib; +open birs_auxLib; + +val _ = Parse.current_backend := PPBackEnd.vt100_terminal; +val _ = set_trace "bir_inst_lifting.DEBUG_LEVEL" 2; + +val _ = new_theory "ifelse"; + +val _ = lift_da_and_store "ifelse" "ifelse.da" da_riscv ((Arbnum.fromInt 0x10488), (Arbnum.fromInt 0x104D0)); + +(* ----------------------------------------- *) +(* Program variable definitions and theorems *) +(* ----------------------------------------- *) + +val bir_prog_def = DB.fetch "ifelse" "bir_ifelse_prog_def"; +val _ = gen_prog_vars_birenvtyl_defthms "ifelse" bir_prog_def; + +val _ = export_theory (); diff --git a/examples/riscv/ifelse/ifelse_specScript.sml b/examples/riscv/ifelse/ifelse_specScript.sml new file mode 100644 index 000000000..3b9d20210 --- /dev/null +++ b/examples/riscv/ifelse/ifelse_specScript.sml @@ -0,0 +1,67 @@ +open HolKernel boolLib Parse bossLib; + +open markerTheory; + +open wordsTheory; + +open bir_programSyntax bir_program_labelsTheory; +open bir_immTheory bir_valuesTheory bir_expTheory; +open bir_tsTheory bir_bool_expTheory bir_programTheory; + +open bir_riscv_backlifterTheory; +open bir_backlifterLib; +open bir_compositionLib; + +open bir_lifting_machinesTheory; +open bir_typing_expTheory; +open bir_htTheory; + +open bir_predLib; +open bir_smtLib; + +open bir_symbTheory birs_auxTheory; +open HolBACoreSimps; +open bir_program_transfTheory; + +open total_program_logicTheory; +open total_ext_program_logicTheory; +open symb_prop_transferTheory; + +open jgmt_rel_bir_contTheory; + +open pred_setTheory; + +open program_logicSimps; + +open bir_env_oldTheory; +open bir_program_varsTheory; + +val _ = new_theory "ifelse_spec"; + +(* ---------------- *) +(* Block boundaries *) +(* ---------------- *) + +Definition ifelse_init_addr_def: + ifelse_init_addr : word64 = 0x10488w +End + +Definition ifelse_end_addr_def: + ifelse_end_addr : word64 = 0x104bcw +End + +(* --------------- *) +(* BSPEC contracts *) +(* --------------- *) + +val bspec_ifelse_keysetup_pre_tm = bslSyntax.bandl [ + mem_addrs_aligned_prog_disj_bir_tm mem_params_standard "x10", + mem_addrs_aligned_prog_disj_bir_tm mem_params_standard "x11" +]; + +Definition bspec_ifelse_pre_def: + bspec_ifelse_pre : bir_exp_t = + ^bspec_ifelse_keysetup_pre_tm +End + +val _ = export_theory (); diff --git a/examples/riscv/ifelse/ifelse_symb_execScript.sml b/examples/riscv/ifelse/ifelse_symb_execScript.sml new file mode 100644 index 000000000..8f83e9441 --- /dev/null +++ b/examples/riscv/ifelse/ifelse_symb_execScript.sml @@ -0,0 +1,31 @@ +open HolKernel Parse boolLib bossLib; + +open wordsTheory; + +open bir_symbLib; + +open ifelseTheory ifelse_specTheory; + +val _ = new_theory "ifelse_symb_exec"; + +(* --------------------------- *) +(* Symbolic analysis execution *) +(* --------------------------- *) + +val _ = show_tags := true; + +val (bsysprecond_thm, symb_analysis_thm) = + bir_symb_analysis_thm + bir_ifelse_prog_def + ifelse_init_addr_def [ifelse_end_addr_def] + bspec_ifelse_pre_def ifelse_birenvtyl_def; + +val _ = Portable.pprint Tag.pp_tag (tag bsysprecond_thm); + +Theorem ifelse_bsysprecond_thm = bsysprecond_thm + +val _ = Portable.pprint Tag.pp_tag (tag symb_analysis_thm); + +Theorem ifelse_symb_analysis_thm = symb_analysis_thm + +val _ = export_theory (); From 2f581b62c93ec55bf10594c0b7ff2c26fcb93bf3 Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Wed, 18 Sep 2024 16:50:19 +0200 Subject: [PATCH 06/95] minimal failing example --- examples/riscv/ifelse/ifelse.c | 31 +++++++------------------ examples/riscv/ifelse/ifelse.da | 32 +++++++++++++------------- examples/riscv/ifelse/ifelseScript.sml | 2 +- 3 files changed, 25 insertions(+), 40 deletions(-) diff --git a/examples/riscv/ifelse/ifelse.c b/examples/riscv/ifelse/ifelse.c index 4cd7bdcf0..7e68d9b7d 100644 --- a/examples/riscv/ifelse/ifelse.c +++ b/examples/riscv/ifelse/ifelse.c @@ -1,42 +1,27 @@ #include -void ifelse(uint64_t *x,uint64_t *k,uint32_t kbits) +static const char sigma[16] = "expand 32-byte k"; +static const char tau[16] = "expand 16-byte k"; + +void ifelse(uint64_t *x,unsigned char *k,uint32_t kbits) { - uint64_t *constants; + const char *constants; *x += 1; *x += 2; *x += 3; if (kbits == 256) { - constants = k; + constants = sigma; } else { - constants = k + 4; - *x += 8; + constants = tau; } *x += 1; *x += 2; *x += *constants; *x += *constants; } - -/* -uint64_t ifelse(uint64_t *i, uint64_t j) { - uint64_t ret; - *i += 3; - if (j == 256) { - i += 16; - ret = 0; - } else { - ret = 1; - } - ret += 4334; - ret -= 345; - return ret; -} -*/ - int main(void) { uint64_t i = 43434334; - uint64_t a = 0; + unsigned char a = 0; ifelse(&i, &a, 256); return 0; } diff --git a/examples/riscv/ifelse/ifelse.da b/examples/riscv/ifelse/ifelse.da index 23ec62310..d5836e86b 100644 --- a/examples/riscv/ifelse/ifelse.da +++ b/examples/riscv/ifelse/ifelse.da @@ -1,27 +1,27 @@ ifelse: file format elf64-littleriscv - Disassembly of section .text: 0000000000010488 : - 10488: 00053783 ld a5,0(a0) - 1048c: 10000713 li a4,256 - 10490: 02e60863 beq a2,a4,104c0 - 10494: 02058593 addi a1,a1,32 - 10498: 00e78793 addi a5,a5,14 - 1049c: 00378793 addi a5,a5,3 - 104a0: 00f53023 sd a5,0(a0) - 104a4: 0005b703 ld a4,0(a1) - 104a8: 00e787b3 add a5,a5,a4 + 10488: 00053683 ld a3,0(a0) + 1048c: 10000793 li a5,256 + 10490: 02f60863 beq a2,a5,104c0 + 10494: 00010737 lui a4,0x10 + 10498: 4f070713 addi a4,a4,1264 # 104f0 + 1049c: 00968693 addi a3,a3,9 + 104a0: 00d53023 sd a3,0(a0) + 104a4: 00074783 lbu a5,0(a4) + 104a8: 00d787b3 add a5,a5,a3 104ac: 00f53023 sd a5,0(a0) - 104b0: 0005b703 ld a4,0(a1) + 104b0: 00074703 lbu a4,0(a4) 104b4: 00f707b3 add a5,a4,a5 104b8: 00f53023 sd a5,0(a0) 104bc: 00008067 ret - 104c0: 00678793 addi a5,a5,6 - 104c4: fd9ff06f j 1049c + 104c0: 00010737 lui a4,0x10 + 104c4: 4e070713 addi a4,a4,1248 # 104e0 + 104c8: fd5ff06f j 1049c -00000000000104c8
: - 104c8: 00000513 li a0,0 - 104cc: 00008067 ret +00000000000104cc
: + 104cc: 00000513 li a0,0 + 104d0: 00008067 ret diff --git a/examples/riscv/ifelse/ifelseScript.sml b/examples/riscv/ifelse/ifelseScript.sml index 75355212f..a31430172 100644 --- a/examples/riscv/ifelse/ifelseScript.sml +++ b/examples/riscv/ifelse/ifelseScript.sml @@ -8,7 +8,7 @@ val _ = set_trace "bir_inst_lifting.DEBUG_LEVEL" 2; val _ = new_theory "ifelse"; -val _ = lift_da_and_store "ifelse" "ifelse.da" da_riscv ((Arbnum.fromInt 0x10488), (Arbnum.fromInt 0x104D0)); +val _ = lift_da_and_store "ifelse" "ifelse.da" da_riscv ((Arbnum.fromInt 0x10488), (Arbnum.fromInt 0x104D4)); (* ----------------------------------------- *) (* Program variable definitions and theorems *) From e27ff53db05bd2028385c61e3b7733c445fac88f Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Mon, 23 Sep 2024 07:33:05 +0200 Subject: [PATCH 07/95] exclude aes from default riscv examples build due to taking too long to build --- examples/riscv/Holmakefile | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/examples/riscv/Holmakefile b/examples/riscv/Holmakefile index 7d3c8ff4c..b851610d2 100644 --- a/examples/riscv/Holmakefile +++ b/examples/riscv/Holmakefile @@ -4,8 +4,7 @@ INCLUDES = $(HOLBADIR)/examples/riscv/swap \ $(HOLBADIR)/examples/riscv/incr \ $(HOLBADIR)/examples/riscv/incr-mem \ $(HOLBADIR)/examples/riscv/mod2-mem \ - $(HOLBADIR)/examples/riscv/isqrt \ - $(HOLBADIR)/examples/riscv/aes + $(HOLBADIR)/examples/riscv/isqrt all: $(DEFAULT_TARGETS) test-riscv.exe .PHONY: all From 004edfcaa47fbab4b2505859c5a5d8a5e5f9797a Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Mon, 23 Sep 2024 07:54:30 +0200 Subject: [PATCH 08/95] adjust chacha spec --- examples/riscv/chacha/chacha_specScript.sml | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) diff --git a/examples/riscv/chacha/chacha_specScript.sml b/examples/riscv/chacha/chacha_specScript.sml index f727f921d..b8dedc968 100644 --- a/examples/riscv/chacha/chacha_specScript.sml +++ b/examples/riscv/chacha/chacha_specScript.sml @@ -70,14 +70,11 @@ End val bspec_chacha_keysetup_pre_tm = bslSyntax.bandl [ mem_addrs_aligned_prog_disj_bir_tm mem_params_standard "x10", - ``BExp_BinPred - BIExp_Equal - (BExp_Den (BVar "x15" (BType_Imm Bit64))) - (BExp_Const (Imm64 pre_x15))`` + mem_addrs_aligned_prog_disj_bir_tm mem_params_standard "x11" ]; Definition bspec_chacha_keysetup_pre_def: - bspec_chacha_keysetup_pre (pre_x15:word64) : bir_exp_t = + bspec_chacha_keysetup_pre : bir_exp_t = ^bspec_chacha_keysetup_pre_tm End @@ -85,14 +82,11 @@ End val bspec_chacha_ivsetup_pre_tm = bslSyntax.bandl [ mem_addrs_aligned_prog_disj_bir_tm mem_params_standard "x10", - ``BExp_BinPred - BIExp_Equal - (BExp_Den (BVar "x15" (BType_Imm Bit64))) - (BExp_Const (Imm64 pre_x15))`` + mem_addrs_aligned_prog_disj_bir_tm mem_params_standard "x11" ]; Definition bspec_chacha_ivsetup_pre_def: - bspec_chacha_ivsetup_pre (pre_x15:word64) : bir_exp_t = + bspec_chacha_ivsetup_pre : bir_exp_t = ^bspec_chacha_ivsetup_pre_tm End From 6c53efa261d0cfe75c1a6c6876315d818838225c Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Mon, 23 Sep 2024 08:11:15 +0200 Subject: [PATCH 09/95] add version of poly1305 with U8/U32 functions inlined --- examples/riscv/poly1305-inlined/Holmakefile | 30 + examples/riscv/poly1305-inlined/poly1305.c | 269 ++++++++ examples/riscv/poly1305-inlined/poly1305.da | 627 ++++++++++++++++++ .../riscv/poly1305-inlined/poly1305Script.sml | 20 + .../poly1305-inlined/poly1305_specScript.sml | 68 ++ .../poly1305_symb_execScript.sml | 35 + 6 files changed, 1049 insertions(+) create mode 100644 examples/riscv/poly1305-inlined/Holmakefile create mode 100644 examples/riscv/poly1305-inlined/poly1305.c create mode 100644 examples/riscv/poly1305-inlined/poly1305.da create mode 100644 examples/riscv/poly1305-inlined/poly1305Script.sml create mode 100644 examples/riscv/poly1305-inlined/poly1305_specScript.sml create mode 100644 examples/riscv/poly1305-inlined/poly1305_symb_execScript.sml diff --git a/examples/riscv/poly1305-inlined/Holmakefile b/examples/riscv/poly1305-inlined/Holmakefile new file mode 100644 index 000000000..4d9d7dbfe --- /dev/null +++ b/examples/riscv/poly1305-inlined/Holmakefile @@ -0,0 +1,30 @@ +INCLUDES = $(HOLDIR)/examples/l3-machine-code/common \ + $(HOLDIR)/examples/l3-machine-code/arm8/model \ + $(HOLDIR)/examples/l3-machine-code/arm8/step \ + $(HOLDIR)/examples/l3-machine-code/m0/model \ + $(HOLDIR)/examples/l3-machine-code/m0/step \ + $(HOLDIR)/examples/l3-machine-code/riscv/model \ + $(HOLDIR)/examples/l3-machine-code/riscv/step \ + $(HOLBADIR)/src/theory/bir \ + $(HOLBADIR)/src/theory/bir-support \ + $(HOLBADIR)/src/theory/program_logic \ + $(HOLBADIR)/src/theory/tools/lifter \ + $(HOLBADIR)/src/theory/tools/backlifter \ + $(HOLBADIR)/src/tools/lifter \ + $(HOLBADIR)/src/tools/backlifter \ + $(HOLBADIR)/src/tools/exec \ + $(HOLBADIR)/src/tools/comp \ + $(HOLBADIR)/src/tools/wp \ + $(HOLBADIR)/src/tools/backlifter \ + $(HOLBADIR)/src/tools/symbexec \ + $(HOLBADIR)/src/tools/symbexec/examples/common \ + $(HOLBADIR)/src + +all: $(DEFAULT_TARGETS) +.PHONY: all + +ifdef POLY +ifndef HOLBA_POLYML_HEAPLESS +HOLHEAP = $(HOLBADIR)/src/holba-heap +endif +endif diff --git a/examples/riscv/poly1305-inlined/poly1305.c b/examples/riscv/poly1305-inlined/poly1305.c new file mode 100644 index 000000000..f5f4cbb79 --- /dev/null +++ b/examples/riscv/poly1305-inlined/poly1305.c @@ -0,0 +1,269 @@ +/* +poly1305 implementation using 32 bit * 32 bit = 64 bit multiplication and 64 bit addition +public domain +*/ + +#include "poly1305.h" + +#if (USE_UNALIGNED == 1) +#define U8TO32(p) \ + (*((uint32_t *)(p))) +#define U32TO8(p, v) \ + do { \ + *((uint32_t *)(p)) = v; \ + } while (0) +#else +/* interpret four 8 bit unsigned integers as a 32 bit unsigned integer in little endian */ +static uint32_t +inline __attribute__((always_inline)) +U8TO32(const unsigned char *p) +{ + return + (((uint32_t)(p[0] & 0xff) ) | + ((uint32_t)(p[1] & 0xff) << 8) | + ((uint32_t)(p[2] & 0xff) << 16) | + ((uint32_t)(p[3] & 0xff) << 24)); +} + +/* store a 32 bit unsigned integer as four 8 bit unsigned integers in little endian */ +static void +inline __attribute__((always_inline)) +U32TO8(unsigned char *p, uint32_t v) +{ + p[0] = (v ) & 0xff; + p[1] = (v >> 8) & 0xff; + p[2] = (v >> 16) & 0xff; + p[3] = (v >> 24) & 0xff; +} +#endif + +void +poly1305_init(struct poly1305_context *st, const unsigned char key[32]) +{ + /* r &= 0xffffffc0ffffffc0ffffffc0fffffff */ + st->r[0] = (U8TO32(&key[ 0]) ) & 0x3ffffff; + st->r[1] = (U8TO32(&key[ 3]) >> 2) & 0x3ffff03; + st->r[2] = (U8TO32(&key[ 6]) >> 4) & 0x3ffc0ff; + st->r[3] = (U8TO32(&key[ 9]) >> 6) & 0x3f03fff; + st->r[4] = (U8TO32(&key[12]) >> 8) & 0x00fffff; + + /* h = 0 */ + st->h[0] = 0; + st->h[1] = 0; + st->h[2] = 0; + st->h[3] = 0; + st->h[4] = 0; + + /* save pad for later */ + st->pad[0] = U8TO32(&key[16]); + st->pad[1] = U8TO32(&key[20]); + st->pad[2] = U8TO32(&key[24]); + st->pad[3] = U8TO32(&key[28]); + + st->leftover = 0; + st->final = 0; +} + +static void +poly1305_blocks(struct poly1305_context *st, const unsigned char *m, size_t bytes) +{ + const uint32_t hibit = (st->final) ? 0 : (1 << 24); /* 1 << 128 */ + uint32_t r0,r1,r2,r3,r4; + uint32_t s1,s2,s3,s4; + uint32_t h0,h1,h2,h3,h4; + uint64_t d0,d1,d2,d3,d4; + uint32_t c; + + r0 = st->r[0]; + r1 = st->r[1]; + r2 = st->r[2]; + r3 = st->r[3]; + r4 = st->r[4]; + + s1 = r1 * 5; + s2 = r2 * 5; + s3 = r3 * 5; + s4 = r4 * 5; + + h0 = st->h[0]; + h1 = st->h[1]; + h2 = st->h[2]; + h3 = st->h[3]; + h4 = st->h[4]; + + while (bytes >= POLY1305_BLOCK_SIZE) { + /* h += m[i] */ + h0 += (U8TO32(m+ 0) ) & 0x3ffffff; + h1 += (U8TO32(m+ 3) >> 2) & 0x3ffffff; + h2 += (U8TO32(m+ 6) >> 4) & 0x3ffffff; + h3 += (U8TO32(m+ 9) >> 6) & 0x3ffffff; + h4 += (U8TO32(m+12) >> 8) | hibit; + + /* h *= r */ + d0 = ((uint64_t)h0 * r0) + ((uint64_t)h1 * s4) + ((uint64_t)h2 * s3) + ((uint64_t)h3 * s2) + ((uint64_t)h4 * s1); + d1 = ((uint64_t)h0 * r1) + ((uint64_t)h1 * r0) + ((uint64_t)h2 * s4) + ((uint64_t)h3 * s3) + ((uint64_t)h4 * s2); + d2 = ((uint64_t)h0 * r2) + ((uint64_t)h1 * r1) + ((uint64_t)h2 * r0) + ((uint64_t)h3 * s4) + ((uint64_t)h4 * s3); + d3 = ((uint64_t)h0 * r3) + ((uint64_t)h1 * r2) + ((uint64_t)h2 * r1) + ((uint64_t)h3 * r0) + ((uint64_t)h4 * s4); + d4 = ((uint64_t)h0 * r4) + ((uint64_t)h1 * r3) + ((uint64_t)h2 * r2) + ((uint64_t)h3 * r1) + ((uint64_t)h4 * r0); + + /* (partial) h %= p */ + c = (uint32_t)(d0 >> 26); h0 = (uint32_t)d0 & 0x3ffffff; + d1 += c; c = (uint32_t)(d1 >> 26); h1 = (uint32_t)d1 & 0x3ffffff; + d2 += c; c = (uint32_t)(d2 >> 26); h2 = (uint32_t)d2 & 0x3ffffff; + d3 += c; c = (uint32_t)(d3 >> 26); h3 = (uint32_t)d3 & 0x3ffffff; + d4 += c; c = (uint32_t)(d4 >> 26); h4 = (uint32_t)d4 & 0x3ffffff; + h0 += c * 5; c = (h0 >> 26); h0 = h0 & 0x3ffffff; + h1 += c; + + m += POLY1305_BLOCK_SIZE; + bytes -= POLY1305_BLOCK_SIZE; + } + + st->h[0] = h0; + st->h[1] = h1; + st->h[2] = h2; + st->h[3] = h3; + st->h[4] = h4; +} + +void +poly1305_finish(struct poly1305_context *st, unsigned char mac[16]) +{ + uint32_t h0,h1,h2,h3,h4,c; + uint32_t g0,g1,g2,g3,g4; + uint64_t f; + uint32_t mask; + + /* process the remaining block */ + if (st->leftover) { + size_t i = st->leftover; + st->buffer[i++] = 1; + for (; i < POLY1305_BLOCK_SIZE; i++) + st->buffer[i] = 0; + st->final = 1; + poly1305_blocks(st, st->buffer, POLY1305_BLOCK_SIZE); + } + + /* fully carry h */ + h0 = st->h[0]; + h1 = st->h[1]; + h2 = st->h[2]; + h3 = st->h[3]; + h4 = st->h[4]; + + c = h1 >> 26; h1 = h1 & 0x3ffffff; + h2 += c; c = h2 >> 26; h2 = h2 & 0x3ffffff; + h3 += c; c = h3 >> 26; h3 = h3 & 0x3ffffff; + h4 += c; c = h4 >> 26; h4 = h4 & 0x3ffffff; + h0 += c * 5; c = h0 >> 26; h0 = h0 & 0x3ffffff; + h1 += c; + + /* compute h + -p */ + g0 = h0 + 5; c = g0 >> 26; g0 &= 0x3ffffff; + g1 = h1 + c; c = g1 >> 26; g1 &= 0x3ffffff; + g2 = h2 + c; c = g2 >> 26; g2 &= 0x3ffffff; + g3 = h3 + c; c = g3 >> 26; g3 &= 0x3ffffff; + g4 = h4 + c - (1 << 26); + + /* select h if h < p, or h + -p if h >= p */ + mask = (g4 >> ((sizeof(uint32_t) * 8) - 1)) - 1; + g0 &= mask; + g1 &= mask; + g2 &= mask; + g3 &= mask; + g4 &= mask; + mask = ~mask; + h0 = (h0 & mask) | g0; + h1 = (h1 & mask) | g1; + h2 = (h2 & mask) | g2; + h3 = (h3 & mask) | g3; + h4 = (h4 & mask) | g4; + + /* h = h % (2^128) */ + h0 = ((h0 ) | (h1 << 26)) & 0xffffffff; + h1 = ((h1 >> 6) | (h2 << 20)) & 0xffffffff; + h2 = ((h2 >> 12) | (h3 << 14)) & 0xffffffff; + h3 = ((h3 >> 18) | (h4 << 8)) & 0xffffffff; + + /* mac = (h + pad) % (2^128) */ + f = (uint64_t)h0 + st->pad[0] ; h0 = (uint32_t)f; + f = (uint64_t)h1 + st->pad[1] + (f >> 32); h1 = (uint32_t)f; + f = (uint64_t)h2 + st->pad[2] + (f >> 32); h2 = (uint32_t)f; + f = (uint64_t)h3 + st->pad[3] + (f >> 32); h3 = (uint32_t)f; + + U32TO8(mac + 0, h0); + U32TO8(mac + 4, h1); + U32TO8(mac + 8, h2); + U32TO8(mac + 12, h3); + + /* zero out the state */ + st->h[0] = 0; + st->h[1] = 0; + st->h[2] = 0; + st->h[3] = 0; + st->h[4] = 0; + st->r[0] = 0; + st->r[1] = 0; + st->r[2] = 0; + st->r[3] = 0; + st->r[4] = 0; + st->pad[0] = 0; + st->pad[1] = 0; + st->pad[2] = 0; + st->pad[3] = 0; +} + + +void +poly1305_update(struct poly1305_context *st, const unsigned char *m, size_t bytes) +{ + size_t i; + + /* handle leftover */ + if (st->leftover) { + size_t want = (POLY1305_BLOCK_SIZE - st->leftover); + if (want > bytes) + want = bytes; + for (i = 0; i < want; i++) + st->buffer[st->leftover + i] = m[i]; + bytes -= want; + m += want; + st->leftover += want; + if (st->leftover < POLY1305_BLOCK_SIZE) + return; + poly1305_blocks(st, st->buffer, POLY1305_BLOCK_SIZE); + st->leftover = 0; + } + + /* process full blocks */ + if (bytes >= POLY1305_BLOCK_SIZE) { + size_t want = (bytes & ~(POLY1305_BLOCK_SIZE - 1)); + poly1305_blocks(st, m, want); + m += want; + bytes -= want; + } + + /* store leftover */ + if (bytes) { +#if (USE_MEMCPY == 1) + memcpy(st->buffer + st->leftover, m, bytes); +#else + for (i = 0; i < bytes; i++) + st->buffer[st->leftover + i] = m[i]; +#endif + st->leftover += bytes; + } +} + +void +poly1305_auth(unsigned char mac[16], const unsigned char *m, size_t bytes, const unsigned char key[32]) +{ + struct poly1305_context ctx; + poly1305_init(&ctx, key); + poly1305_update(&ctx, m, bytes); + poly1305_finish(&ctx, mac); +} + +int main(void) { + return 0; +} diff --git a/examples/riscv/poly1305-inlined/poly1305.da b/examples/riscv/poly1305-inlined/poly1305.da new file mode 100644 index 000000000..93695e13d --- /dev/null +++ b/examples/riscv/poly1305-inlined/poly1305.da @@ -0,0 +1,627 @@ + +poly1305: file format elf64-littleriscv + + +Disassembly of section .text: + +0000000000010488 : + 10488: fa010113 addi sp,sp,-96 + 1048c: 04813c23 sd s0,88(sp) + 10490: 04913823 sd s1,80(sp) + 10494: 05313023 sd s3,64(sp) + 10498: 03413c23 sd s4,56(sp) + 1049c: 03513823 sd s5,48(sp) + 104a0: 03713023 sd s7,32(sp) + 104a4: 01813c23 sd s8,24(sp) + 104a8: 05054383 lbu t2,80(a0) + 104ac: 00052683 lw a3,0(a0) + 104b0: 00452783 lw a5,4(a0) + 104b4: 00852303 lw t1,8(a0) + 104b8: 00c52e83 lw t4,12(a0) + 104bc: 01052403 lw s0,16(a0) + 104c0: 0027949b slliw s1,a5,0x2 + 104c4: 00f484bb addw s1,s1,a5 + 104c8: 00231f1b slliw t5,t1,0x2 + 104cc: 006f0f3b addw t5,t5,t1 + 104d0: 002e9e1b slliw t3,t4,0x2 + 104d4: 01de0e3b addw t3,t3,t4 + 104d8: 0024181b slliw a6,s0,0x2 + 104dc: 0088083b addw a6,a6,s0 + 104e0: 01452983 lw s3,20(a0) + 104e4: 01852c03 lw s8,24(a0) + 104e8: 01c52a03 lw s4,28(a0) + 104ec: 02052a83 lw s5,32(a0) + 104f0: 02452b83 lw s7,36(a0) + 104f4: 00f00713 li a4,15 + 104f8: 2cc77863 bgeu a4,a2,107c8 + 104fc: 05213423 sd s2,72(sp) + 10500: 03613423 sd s6,40(sp) + 10504: 01913823 sd s9,16(sp) + 10508: 01a13423 sd s10,8(sp) + 1050c: 0013b393 seqz t2,t2 + 10510: 01839393 slli t2,t2,0x18 + 10514: ff060f93 addi t6,a2,-16 + 10518: ff0fff93 andi t6,t6,-16 + 1051c: 010f8f93 addi t6,t6,16 + 10520: 01f58fb3 add t6,a1,t6 + 10524: 04000737 lui a4,0x4000 + 10528: fff70713 addi a4,a4,-1 # 3ffffff <__global_pointer$+0x3fed7f7> + 1052c: 02069693 slli a3,a3,0x20 + 10530: 0206d693 srli a3,a3,0x20 + 10534: 02081813 slli a6,a6,0x20 + 10538: 02085813 srli a6,a6,0x20 + 1053c: 020f1f13 slli t5,t5,0x20 + 10540: 020f5f13 srli t5,t5,0x20 + 10544: 020e1e13 slli t3,t3,0x20 + 10548: 020e5e13 srli t3,t3,0x20 + 1054c: 02049493 slli s1,s1,0x20 + 10550: 0204d493 srli s1,s1,0x20 + 10554: 02079613 slli a2,a5,0x20 + 10558: 02065613 srli a2,a2,0x20 + 1055c: 02031313 slli t1,t1,0x20 + 10560: 02035313 srli t1,t1,0x20 + 10564: 020e9e93 slli t4,t4,0x20 + 10568: 020ede93 srli t4,t4,0x20 + 1056c: 02041413 slli s0,s0,0x20 + 10570: 02045413 srli s0,s0,0x20 + 10574: fff00893 li a7,-1 + 10578: 0208d893 srli a7,a7,0x20 + 1057c: 0035cc83 lbu s9,3(a1) + 10580: 0065cb03 lbu s6,6(a1) + 10584: 0095c783 lbu a5,9(a1) + 10588: 00c5c903 lbu s2,12(a1) + 1058c: 0015c283 lbu t0,1(a1) + 10590: 0082929b slliw t0,t0,0x8 + 10594: 0025cd03 lbu s10,2(a1) + 10598: 010d1d1b slliw s10,s10,0x10 + 1059c: 01a2e2b3 or t0,t0,s10 + 105a0: 0005cd03 lbu s10,0(a1) + 105a4: 01a2e2b3 or t0,t0,s10 + 105a8: 018c9d1b slliw s10,s9,0x18 + 105ac: 01a2e2b3 or t0,t0,s10 + 105b0: 00e2f2b3 and t0,t0,a4 + 105b4: 013282bb addw t0,t0,s3 + 105b8: 02029293 slli t0,t0,0x20 + 105bc: 0202d293 srli t0,t0,0x20 + 105c0: 0045c983 lbu s3,4(a1) + 105c4: 0089999b slliw s3,s3,0x8 + 105c8: 0055cd03 lbu s10,5(a1) + 105cc: 010d1d1b slliw s10,s10,0x10 + 105d0: 01a9e9b3 or s3,s3,s10 + 105d4: 0199e9b3 or s3,s3,s9 + 105d8: 018b1c9b slliw s9,s6,0x18 + 105dc: 0199e9b3 or s3,s3,s9 + 105e0: 0029d99b srliw s3,s3,0x2 + 105e4: 00e9f9b3 and s3,s3,a4 + 105e8: 018989bb addw s3,s3,s8 + 105ec: 02099993 slli s3,s3,0x20 + 105f0: 0209d993 srli s3,s3,0x20 + 105f4: 00a5cc03 lbu s8,10(a1) + 105f8: 008c1c1b slliw s8,s8,0x8 + 105fc: 00b5cc83 lbu s9,11(a1) + 10600: 010c9c9b slliw s9,s9,0x10 + 10604: 019c6c33 or s8,s8,s9 + 10608: 00fc6c33 or s8,s8,a5 + 1060c: 0189191b slliw s2,s2,0x18 + 10610: 012c6c33 or s8,s8,s2 + 10614: 006c5c1b srliw s8,s8,0x6 + 10618: 015c0c3b addw s8,s8,s5 + 1061c: 020c1c13 slli s8,s8,0x20 + 10620: 020c5c13 srli s8,s8,0x20 + 10624: 0075c903 lbu s2,7(a1) + 10628: 0089191b slliw s2,s2,0x8 + 1062c: 0085ca83 lbu s5,8(a1) + 10630: 010a9a9b slliw s5,s5,0x10 + 10634: 01596933 or s2,s2,s5 + 10638: 01696933 or s2,s2,s6 + 1063c: 0187979b slliw a5,a5,0x18 + 10640: 00f96933 or s2,s2,a5 + 10644: 0049591b srliw s2,s2,0x4 + 10648: 00e97933 and s2,s2,a4 + 1064c: 0149093b addw s2,s2,s4 + 10650: 02091913 slli s2,s2,0x20 + 10654: 02095913 srli s2,s2,0x20 + 10658: 00d5cb03 lbu s6,13(a1) + 1065c: 008b1b1b slliw s6,s6,0x8 + 10660: 00e5c783 lbu a5,14(a1) + 10664: 0107979b slliw a5,a5,0x10 + 10668: 00fb6b33 or s6,s6,a5 + 1066c: 00f5c783 lbu a5,15(a1) + 10670: 0187979b slliw a5,a5,0x18 + 10674: 00fb6b33 or s6,s6,a5 + 10678: 008b5b1b srliw s6,s6,0x8 + 1067c: 0163eb33 or s6,t2,s6 + 10680: 017b0b3b addw s6,s6,s7 + 10684: 020b1b13 slli s6,s6,0x20 + 10688: 020b5b13 srli s6,s6,0x20 + 1068c: 030987b3 mul a5,s3,a6 + 10690: 03ec0a33 mul s4,s8,t5 + 10694: 014787b3 add a5,a5,s4 + 10698: 02d28a33 mul s4,t0,a3 + 1069c: 014787b3 add a5,a5,s4 + 106a0: 03c90a33 mul s4,s2,t3 + 106a4: 014787b3 add a5,a5,s4 + 106a8: 03648a33 mul s4,s1,s6 + 106ac: 014787b3 add a5,a5,s4 + 106b0: 02c28bb3 mul s7,t0,a2 + 106b4: 03368a33 mul s4,a3,s3 + 106b8: 014b8bb3 add s7,s7,s4 + 106bc: 03cc0a33 mul s4,s8,t3 + 106c0: 014b8bb3 add s7,s7,s4 + 106c4: 03280a33 mul s4,a6,s2 + 106c8: 014b8bb3 add s7,s7,s4 + 106cc: 036f0a33 mul s4,t5,s6 + 106d0: 014b8bb3 add s7,s7,s4 + 106d4: 02628a33 mul s4,t0,t1 + 106d8: 02c98ab3 mul s5,s3,a2 + 106dc: 015a0a33 add s4,s4,s5 + 106e0: 03268ab3 mul s5,a3,s2 + 106e4: 015a0a33 add s4,s4,s5 + 106e8: 03880ab3 mul s5,a6,s8 + 106ec: 015a0a33 add s4,s4,s5 + 106f0: 036e0ab3 mul s5,t3,s6 + 106f4: 015a0a33 add s4,s4,s5 + 106f8: 03d28ab3 mul s5,t0,t4 + 106fc: 02698cb3 mul s9,s3,t1 + 10700: 019a8ab3 add s5,s5,s9 + 10704: 03868cb3 mul s9,a3,s8 + 10708: 019a8ab3 add s5,s5,s9 + 1070c: 02c90cb3 mul s9,s2,a2 + 10710: 019a8ab3 add s5,s5,s9 + 10714: 03680cb3 mul s9,a6,s6 + 10718: 019a8ab3 add s5,s5,s9 + 1071c: 025402b3 mul t0,s0,t0 + 10720: 03d989b3 mul s3,s3,t4 + 10724: 013289b3 add s3,t0,s3 + 10728: 02cc0c33 mul s8,s8,a2 + 1072c: 018989b3 add s3,s3,s8 + 10730: 02690933 mul s2,s2,t1 + 10734: 012989b3 add s3,s3,s2 + 10738: 03668b33 mul s6,a3,s6 + 1073c: 016989b3 add s3,s3,s6 + 10740: 00e7f2b3 and t0,a5,a4 + 10744: 01a7d793 srli a5,a5,0x1a + 10748: 0117f7b3 and a5,a5,a7 + 1074c: 017787b3 add a5,a5,s7 + 10750: 00e7f933 and s2,a5,a4 + 10754: 01a7d793 srli a5,a5,0x1a + 10758: 0117f7b3 and a5,a5,a7 + 1075c: 014787b3 add a5,a5,s4 + 10760: 00e7fa33 and s4,a5,a4 + 10764: 000a0a1b sext.w s4,s4 + 10768: 01a7d793 srli a5,a5,0x1a + 1076c: 0117f7b3 and a5,a5,a7 + 10770: 015787b3 add a5,a5,s5 + 10774: 00e7fab3 and s5,a5,a4 + 10778: 000a8a9b sext.w s5,s5 + 1077c: 01a7d793 srli a5,a5,0x1a + 10780: 0117f7b3 and a5,a5,a7 + 10784: 013787b3 add a5,a5,s3 + 10788: 00e7fbb3 and s7,a5,a4 + 1078c: 000b8b9b sext.w s7,s7 + 10790: 01a7d793 srli a5,a5,0x1a + 10794: 00279c1b slliw s8,a5,0x2 + 10798: 00fc0c3b addw s8,s8,a5 + 1079c: 005c0c3b addw s8,s8,t0 + 107a0: 018779b3 and s3,a4,s8 + 107a4: 0009899b sext.w s3,s3 + 107a8: 01ac5c1b srliw s8,s8,0x1a + 107ac: 012c0c3b addw s8,s8,s2 + 107b0: 01058593 addi a1,a1,16 + 107b4: dcbf94e3 bne t6,a1,1057c + 107b8: 04813903 ld s2,72(sp) + 107bc: 02813b03 ld s6,40(sp) + 107c0: 01013c83 ld s9,16(sp) + 107c4: 00813d03 ld s10,8(sp) + 107c8: 01352a23 sw s3,20(a0) + 107cc: 01852c23 sw s8,24(a0) + 107d0: 01452e23 sw s4,28(a0) + 107d4: 03552023 sw s5,32(a0) + 107d8: 03752223 sw s7,36(a0) + 107dc: 05813403 ld s0,88(sp) + 107e0: 05013483 ld s1,80(sp) + 107e4: 04013983 ld s3,64(sp) + 107e8: 03813a03 ld s4,56(sp) + 107ec: 03013a83 ld s5,48(sp) + 107f0: 02013b83 ld s7,32(sp) + 107f4: 01813c03 ld s8,24(sp) + 107f8: 06010113 addi sp,sp,96 + 107fc: 00008067 ret + +0000000000010800 : + 10800: 0015c783 lbu a5,1(a1) + 10804: 0087979b slliw a5,a5,0x8 + 10808: 0025c703 lbu a4,2(a1) + 1080c: 0107171b slliw a4,a4,0x10 + 10810: 00e7e7b3 or a5,a5,a4 + 10814: 0005c703 lbu a4,0(a1) + 10818: 00e7e7b3 or a5,a5,a4 + 1081c: 0035c703 lbu a4,3(a1) + 10820: 0187171b slliw a4,a4,0x18 + 10824: 00e7e7b3 or a5,a5,a4 + 10828: 02679793 slli a5,a5,0x26 + 1082c: 0267d793 srli a5,a5,0x26 + 10830: 00f52023 sw a5,0(a0) + 10834: 0045c783 lbu a5,4(a1) + 10838: 0087979b slliw a5,a5,0x8 + 1083c: 0055c703 lbu a4,5(a1) + 10840: 0107171b slliw a4,a4,0x10 + 10844: 00e7e7b3 or a5,a5,a4 + 10848: 0035c703 lbu a4,3(a1) + 1084c: 00e7e7b3 or a5,a5,a4 + 10850: 0065c703 lbu a4,6(a1) + 10854: 0187171b slliw a4,a4,0x18 + 10858: 00e7e7b3 or a5,a5,a4 + 1085c: 0027d79b srliw a5,a5,0x2 + 10860: 04000737 lui a4,0x4000 + 10864: f0370713 addi a4,a4,-253 # 3ffff03 <__global_pointer$+0x3fed6fb> + 10868: 00e7f7b3 and a5,a5,a4 + 1086c: 00f52223 sw a5,4(a0) + 10870: 0075c783 lbu a5,7(a1) + 10874: 0087979b slliw a5,a5,0x8 + 10878: 0085c703 lbu a4,8(a1) + 1087c: 0107171b slliw a4,a4,0x10 + 10880: 00e7e7b3 or a5,a5,a4 + 10884: 0065c703 lbu a4,6(a1) + 10888: 00e7e7b3 or a5,a5,a4 + 1088c: 0095c703 lbu a4,9(a1) + 10890: 0187171b slliw a4,a4,0x18 + 10894: 00e7e7b3 or a5,a5,a4 + 10898: 0047d79b srliw a5,a5,0x4 + 1089c: 03ffc737 lui a4,0x3ffc + 108a0: 0ff70713 addi a4,a4,255 # 3ffc0ff <__global_pointer$+0x3fe98f7> + 108a4: 00e7f7b3 and a5,a5,a4 + 108a8: 00f52423 sw a5,8(a0) + 108ac: 00a5c783 lbu a5,10(a1) + 108b0: 0087979b slliw a5,a5,0x8 + 108b4: 00b5c703 lbu a4,11(a1) + 108b8: 0107171b slliw a4,a4,0x10 + 108bc: 00e7e7b3 or a5,a5,a4 + 108c0: 0095c703 lbu a4,9(a1) + 108c4: 00e7e7b3 or a5,a5,a4 + 108c8: 00c5c703 lbu a4,12(a1) + 108cc: 0187171b slliw a4,a4,0x18 + 108d0: 00e7e7b3 or a5,a5,a4 + 108d4: 0067d79b srliw a5,a5,0x6 + 108d8: 03f04737 lui a4,0x3f04 + 108dc: fff70713 addi a4,a4,-1 # 3f03fff <__global_pointer$+0x3ef17f7> + 108e0: 00e7f7b3 and a5,a5,a4 + 108e4: 00f52623 sw a5,12(a0) + 108e8: 00d5c783 lbu a5,13(a1) + 108ec: 0087979b slliw a5,a5,0x8 + 108f0: 00e5c703 lbu a4,14(a1) + 108f4: 0107171b slliw a4,a4,0x10 + 108f8: 00e7e7b3 or a5,a5,a4 + 108fc: 00f5c703 lbu a4,15(a1) + 10900: 0187171b slliw a4,a4,0x18 + 10904: 00e7e7b3 or a5,a5,a4 + 10908: 02479793 slli a5,a5,0x24 + 1090c: 02c7d793 srli a5,a5,0x2c + 10910: 00f52823 sw a5,16(a0) + 10914: 00052a23 sw zero,20(a0) + 10918: 00052c23 sw zero,24(a0) + 1091c: 00052e23 sw zero,28(a0) + 10920: 02052023 sw zero,32(a0) + 10924: 02052223 sw zero,36(a0) + 10928: 0115c783 lbu a5,17(a1) + 1092c: 0087979b slliw a5,a5,0x8 + 10930: 0125c703 lbu a4,18(a1) + 10934: 0107171b slliw a4,a4,0x10 + 10938: 00e7e7b3 or a5,a5,a4 + 1093c: 0105c703 lbu a4,16(a1) + 10940: 00e7e7b3 or a5,a5,a4 + 10944: 0135c703 lbu a4,19(a1) + 10948: 0187171b slliw a4,a4,0x18 + 1094c: 00e7e7b3 or a5,a5,a4 + 10950: 02f52423 sw a5,40(a0) + 10954: 0155c783 lbu a5,21(a1) + 10958: 0087979b slliw a5,a5,0x8 + 1095c: 0165c703 lbu a4,22(a1) + 10960: 0107171b slliw a4,a4,0x10 + 10964: 00e7e7b3 or a5,a5,a4 + 10968: 0145c703 lbu a4,20(a1) + 1096c: 00e7e7b3 or a5,a5,a4 + 10970: 0175c703 lbu a4,23(a1) + 10974: 0187171b slliw a4,a4,0x18 + 10978: 00e7e7b3 or a5,a5,a4 + 1097c: 02f52623 sw a5,44(a0) + 10980: 0195c783 lbu a5,25(a1) + 10984: 0087979b slliw a5,a5,0x8 + 10988: 01a5c703 lbu a4,26(a1) + 1098c: 0107171b slliw a4,a4,0x10 + 10990: 00e7e7b3 or a5,a5,a4 + 10994: 0185c703 lbu a4,24(a1) + 10998: 00e7e7b3 or a5,a5,a4 + 1099c: 01b5c703 lbu a4,27(a1) + 109a0: 0187171b slliw a4,a4,0x18 + 109a4: 00e7e7b3 or a5,a5,a4 + 109a8: 02f52823 sw a5,48(a0) + 109ac: 01e5c783 lbu a5,30(a1) + 109b0: 0107979b slliw a5,a5,0x10 + 109b4: 01d5c703 lbu a4,29(a1) + 109b8: 0087171b slliw a4,a4,0x8 + 109bc: 00e7e7b3 or a5,a5,a4 + 109c0: 01c5c703 lbu a4,28(a1) + 109c4: 00e7e7b3 or a5,a5,a4 + 109c8: 01f5c703 lbu a4,31(a1) + 109cc: 0187171b slliw a4,a4,0x18 + 109d0: 00e7e7b3 or a5,a5,a4 + 109d4: 02f52a23 sw a5,52(a0) + 109d8: 02053c23 sd zero,56(a0) + 109dc: 04050823 sb zero,80(a0) + 109e0: 00008067 ret + +00000000000109e4 : + 109e4: fe010113 addi sp,sp,-32 + 109e8: 00113c23 sd ra,24(sp) + 109ec: 00813823 sd s0,16(sp) + 109f0: 00913423 sd s1,8(sp) + 109f4: 00050413 mv s0,a0 + 109f8: 00058493 mv s1,a1 + 109fc: 03853783 ld a5,56(a0) + 10a00: 04078663 beqz a5,10a4c + 10a04: 00f50733 add a4,a0,a5 + 10a08: 00100693 li a3,1 + 10a0c: 04d70023 sb a3,64(a4) + 10a10: 00178713 addi a4,a5,1 + 10a14: 00f00693 li a3,15 + 10a18: 00e6ee63 bltu a3,a4,10a34 + 10a1c: 04178793 addi a5,a5,65 + 10a20: 00f507b3 add a5,a0,a5 + 10a24: 05050713 addi a4,a0,80 + 10a28: 00078023 sb zero,0(a5) + 10a2c: 00178793 addi a5,a5,1 + 10a30: fee79ce3 bne a5,a4,10a28 + 10a34: 00100793 li a5,1 + 10a38: 04f40823 sb a5,80(s0) + 10a3c: 01000613 li a2,16 + 10a40: 04040593 addi a1,s0,64 + 10a44: 00040513 mv a0,s0 + 10a48: a41ff0ef jal 10488 + 10a4c: 01442603 lw a2,20(s0) + 10a50: 01842783 lw a5,24(s0) + 10a54: 01c42503 lw a0,28(s0) + 10a58: 02042583 lw a1,32(s0) + 10a5c: 02442703 lw a4,36(s0) + 10a60: 04000337 lui t1,0x4000 + 10a64: fff30313 addi t1,t1,-1 # 3ffffff <__global_pointer$+0x3fed7f7> + 10a68: 0067f6b3 and a3,a5,t1 + 10a6c: 01a7d79b srliw a5,a5,0x1a + 10a70: 00a787bb addw a5,a5,a0 + 10a74: 00f37eb3 and t4,t1,a5 + 10a78: 01a7d79b srliw a5,a5,0x1a + 10a7c: 00b787bb addw a5,a5,a1 + 10a80: 00f37e33 and t3,t1,a5 + 10a84: 01a7d79b srliw a5,a5,0x1a + 10a88: 00e787bb addw a5,a5,a4 + 10a8c: 00f37f33 and t5,t1,a5 + 10a90: 01a7d79b srliw a5,a5,0x1a + 10a94: 0027971b slliw a4,a5,0x2 + 10a98: 00f707bb addw a5,a4,a5 + 10a9c: 00c787bb addw a5,a5,a2 + 10aa0: 00f372b3 and t0,t1,a5 + 10aa4: 01a7d79b srliw a5,a5,0x1a + 10aa8: 00d78fbb addw t6,a5,a3 + 10aac: 0052861b addiw a2,t0,5 + 10ab0: 01a6579b srliw a5,a2,0x1a + 10ab4: 01f787bb addw a5,a5,t6 + 10ab8: 01a7d89b srliw a7,a5,0x1a + 10abc: 01d888bb addw a7,a7,t4 + 10ac0: 01a8d69b srliw a3,a7,0x1a + 10ac4: 01c686bb addw a3,a3,t3 + 10ac8: 01a6d51b srliw a0,a3,0x1a + 10acc: fc000737 lui a4,0xfc000 + 10ad0: 01e7073b addw a4,a4,t5 + 10ad4: 00e5053b addw a0,a0,a4 + 10ad8: 01f5581b srliw a6,a0,0x1f + 10adc: fff8081b addiw a6,a6,-1 + 10ae0: 010675b3 and a1,a2,a6 + 10ae4: 0005859b sext.w a1,a1 + 10ae8: 0107f633 and a2,a5,a6 + 10aec: 0006061b sext.w a2,a2 + 10af0: 0108f7b3 and a5,a7,a6 + 10af4: 0007879b sext.w a5,a5 + 10af8: 0106f6b3 and a3,a3,a6 + 10afc: 0006869b sext.w a3,a3 + 10b00: 41f5571b sraiw a4,a0,0x1f + 10b04: 00e2f2b3 and t0,t0,a4 + 10b08: 0002829b sext.w t0,t0 + 10b0c: 0065f5b3 and a1,a1,t1 + 10b10: 0055e5b3 or a1,a1,t0 + 10b14: 00efffb3 and t6,t6,a4 + 10b18: 000f8f9b sext.w t6,t6 + 10b1c: 00667633 and a2,a2,t1 + 10b20: 01f66633 or a2,a2,t6 + 10b24: 00eefeb3 and t4,t4,a4 + 10b28: 000e8e9b sext.w t4,t4 + 10b2c: 0067f7b3 and a5,a5,t1 + 10b30: 01d7e7b3 or a5,a5,t4 + 10b34: 00ee7e33 and t3,t3,a4 + 10b38: 000e0e1b sext.w t3,t3 + 10b3c: 0066f6b3 and a3,a3,t1 + 10b40: 01c6e6b3 or a3,a3,t3 + 10b44: 00ef7733 and a4,t5,a4 + 10b48: 01a6189b slliw a7,a2,0x1a + 10b4c: 0115e5b3 or a1,a1,a7 + 10b50: 0066561b srliw a2,a2,0x6 + 10b54: 00c7de9b srliw t4,a5,0xc + 10b58: 0126d31b srliw t1,a3,0x12 + 10b5c: 02842e03 lw t3,40(s0) + 10b60: 00be08bb addw a7,t3,a1 + 10b64: 02059593 slli a1,a1,0x20 + 10b68: 0205d593 srli a1,a1,0x20 + 10b6c: 020e1e13 slli t3,t3,0x20 + 10b70: 020e5e13 srli t3,t3,0x20 + 10b74: 01c585b3 add a1,a1,t3 + 10b78: 0205d593 srli a1,a1,0x20 + 10b7c: 0147979b slliw a5,a5,0x14 + 10b80: 00c7e7b3 or a5,a5,a2 + 10b84: 02079793 slli a5,a5,0x20 + 10b88: 0207d793 srli a5,a5,0x20 + 10b8c: 02c46603 lwu a2,44(s0) + 10b90: 00c787b3 add a5,a5,a2 + 10b94: 00b787b3 add a5,a5,a1 + 10b98: 0207d613 srli a2,a5,0x20 + 10b9c: 00e6969b slliw a3,a3,0xe + 10ba0: 01d6e6b3 or a3,a3,t4 + 10ba4: 02069693 slli a3,a3,0x20 + 10ba8: 0206d693 srli a3,a3,0x20 + 10bac: 03046583 lwu a1,48(s0) + 10bb0: 00b686b3 add a3,a3,a1 + 10bb4: 00c686b3 add a3,a3,a2 + 10bb8: 0206d613 srli a2,a3,0x20 + 10bbc: 01057533 and a0,a0,a6 + 10bc0: 00a76733 or a4,a4,a0 + 10bc4: 0087171b slliw a4,a4,0x8 + 10bc8: 00676733 or a4,a4,t1 + 10bcc: 02071713 slli a4,a4,0x20 + 10bd0: 02075713 srli a4,a4,0x20 + 10bd4: 03446583 lwu a1,52(s0) + 10bd8: 00b70733 add a4,a4,a1 + 10bdc: 00c70733 add a4,a4,a2 + 10be0: 01148023 sb a7,0(s1) + 10be4: 0088d61b srliw a2,a7,0x8 + 10be8: 00c480a3 sb a2,1(s1) + 10bec: 0108d61b srliw a2,a7,0x10 + 10bf0: 00c48123 sb a2,2(s1) + 10bf4: 0188d89b srliw a7,a7,0x18 + 10bf8: 011481a3 sb a7,3(s1) + 10bfc: 00f48223 sb a5,4(s1) + 10c00: 0087d61b srliw a2,a5,0x8 + 10c04: 00c482a3 sb a2,5(s1) + 10c08: 0107d61b srliw a2,a5,0x10 + 10c0c: 00c48323 sb a2,6(s1) + 10c10: 0187d79b srliw a5,a5,0x18 + 10c14: 00f483a3 sb a5,7(s1) + 10c18: 00d48423 sb a3,8(s1) + 10c1c: 0086d79b srliw a5,a3,0x8 + 10c20: 00f484a3 sb a5,9(s1) + 10c24: 0106d79b srliw a5,a3,0x10 + 10c28: 00f48523 sb a5,10(s1) + 10c2c: 0186d69b srliw a3,a3,0x18 + 10c30: 00d485a3 sb a3,11(s1) + 10c34: 00e48623 sb a4,12(s1) + 10c38: 0087579b srliw a5,a4,0x8 + 10c3c: 00f486a3 sb a5,13(s1) + 10c40: 0107579b srliw a5,a4,0x10 + 10c44: 00f48723 sb a5,14(s1) + 10c48: 0187571b srliw a4,a4,0x18 + 10c4c: 00e487a3 sb a4,15(s1) + 10c50: 00042a23 sw zero,20(s0) + 10c54: 00042c23 sw zero,24(s0) + 10c58: 00042e23 sw zero,28(s0) + 10c5c: 02042023 sw zero,32(s0) + 10c60: 02042223 sw zero,36(s0) + 10c64: 00042023 sw zero,0(s0) + 10c68: 00042223 sw zero,4(s0) + 10c6c: 00042423 sw zero,8(s0) + 10c70: 00042623 sw zero,12(s0) + 10c74: 00042823 sw zero,16(s0) + 10c78: 02042423 sw zero,40(s0) + 10c7c: 02042623 sw zero,44(s0) + 10c80: 02042823 sw zero,48(s0) + 10c84: 02042a23 sw zero,52(s0) + 10c88: 01813083 ld ra,24(sp) + 10c8c: 01013403 ld s0,16(sp) + 10c90: 00813483 ld s1,8(sp) + 10c94: 02010113 addi sp,sp,32 + 10c98: 00008067 ret + +0000000000010c9c : + 10c9c: fd010113 addi sp,sp,-48 + 10ca0: 02113423 sd ra,40(sp) + 10ca4: 02813023 sd s0,32(sp) + 10ca8: 00913c23 sd s1,24(sp) + 10cac: 01213823 sd s2,16(sp) + 10cb0: 00050493 mv s1,a0 + 10cb4: 00058413 mv s0,a1 + 10cb8: 00060913 mv s2,a2 + 10cbc: 03853603 ld a2,56(a0) + 10cc0: 06060463 beqz a2,10d28 + 10cc4: 01000513 li a0,16 + 10cc8: 40c50533 sub a0,a0,a2 + 10ccc: 00a97463 bgeu s2,a0,10cd4 + 10cd0: 00090513 mv a0,s2 + 10cd4: 02050463 beqz a0,10cfc + 10cd8: 00040793 mv a5,s0 + 10cdc: 04060713 addi a4,a2,64 + 10ce0: 00e48733 add a4,s1,a4 + 10ce4: 008505b3 add a1,a0,s0 + 10ce8: 0007c683 lbu a3,0(a5) + 10cec: 00d70023 sb a3,0(a4) # fffffffffc000000 <__global_pointer$+0xfffffffffbfed7f8> + 10cf0: 00178793 addi a5,a5,1 + 10cf4: 00170713 addi a4,a4,1 + 10cf8: feb798e3 bne a5,a1,10ce8 + 10cfc: 00a60633 add a2,a2,a0 + 10d00: 02c4bc23 sd a2,56(s1) + 10d04: 00f00793 li a5,15 + 10d08: 06c7f063 bgeu a5,a2,10d68 + 10d0c: 40a90933 sub s2,s2,a0 + 10d10: 00a40433 add s0,s0,a0 + 10d14: 01000613 li a2,16 + 10d18: 04048593 addi a1,s1,64 + 10d1c: 00048513 mv a0,s1 + 10d20: f68ff0ef jal 10488 + 10d24: 0204bc23 sd zero,56(s1) + 10d28: 00f00793 li a5,15 + 10d2c: 0527ea63 bltu a5,s2,10d80 + 10d30: 02090c63 beqz s2,10d68 + 10d34: 00040793 mv a5,s0 + 10d38: 0384b703 ld a4,56(s1) + 10d3c: 04070713 addi a4,a4,64 + 10d40: 00e48733 add a4,s1,a4 + 10d44: 01240433 add s0,s0,s2 + 10d48: 0007c683 lbu a3,0(a5) + 10d4c: 00d70023 sb a3,0(a4) + 10d50: 00178793 addi a5,a5,1 + 10d54: 00170713 addi a4,a4,1 + 10d58: fe8798e3 bne a5,s0,10d48 + 10d5c: 0384b783 ld a5,56(s1) + 10d60: 012787b3 add a5,a5,s2 + 10d64: 02f4bc23 sd a5,56(s1) + 10d68: 02813083 ld ra,40(sp) + 10d6c: 02013403 ld s0,32(sp) + 10d70: 01813483 ld s1,24(sp) + 10d74: 01013903 ld s2,16(sp) + 10d78: 03010113 addi sp,sp,48 + 10d7c: 00008067 ret + 10d80: 01313423 sd s3,8(sp) + 10d84: ff097993 andi s3,s2,-16 + 10d88: 00098613 mv a2,s3 + 10d8c: 00040593 mv a1,s0 + 10d90: 00048513 mv a0,s1 + 10d94: ef4ff0ef jal 10488 + 10d98: 01340433 add s0,s0,s3 + 10d9c: 41390933 sub s2,s2,s3 + 10da0: 00813983 ld s3,8(sp) + 10da4: f8dff06f j 10d30 + +0000000000010da8 : + 10da8: f8010113 addi sp,sp,-128 + 10dac: 06113c23 sd ra,120(sp) + 10db0: 06813823 sd s0,112(sp) + 10db4: 06913423 sd s1,104(sp) + 10db8: 07213023 sd s2,96(sp) + 10dbc: 00050413 mv s0,a0 + 10dc0: 00058493 mv s1,a1 + 10dc4: 00060913 mv s2,a2 + 10dc8: 00068593 mv a1,a3 + 10dcc: 00810513 addi a0,sp,8 + 10dd0: a31ff0ef jal 10800 + 10dd4: 00090613 mv a2,s2 + 10dd8: 00048593 mv a1,s1 + 10ddc: 00810513 addi a0,sp,8 + 10de0: ebdff0ef jal 10c9c + 10de4: 00040593 mv a1,s0 + 10de8: 00810513 addi a0,sp,8 + 10dec: bf9ff0ef jal 109e4 + 10df0: 07813083 ld ra,120(sp) + 10df4: 07013403 ld s0,112(sp) + 10df8: 06813483 ld s1,104(sp) + 10dfc: 06013903 ld s2,96(sp) + 10e00: 08010113 addi sp,sp,128 + 10e04: 00008067 ret + +0000000000010e08
: + 10e08: 00000513 li a0,0 + 10e0c: 00008067 ret diff --git a/examples/riscv/poly1305-inlined/poly1305Script.sml b/examples/riscv/poly1305-inlined/poly1305Script.sml new file mode 100644 index 000000000..c6061a1de --- /dev/null +++ b/examples/riscv/poly1305-inlined/poly1305Script.sml @@ -0,0 +1,20 @@ +open HolKernel Parse; + +open bir_lifter_interfaceLib; +open birs_auxLib; + +val _ = Parse.current_backend := PPBackEnd.vt100_terminal; +val _ = set_trace "bir_inst_lifting.DEBUG_LEVEL" 2; + +val _ = new_theory "poly1305"; + +val _ = lift_da_and_store "poly1305" "poly1305.da" da_riscv ((Arbnum.fromInt 0x10488), (Arbnum.fromInt 0x10E10)); + +(* ----------------------------------------- *) +(* Program variable definitions and theorems *) +(* ----------------------------------------- *) + +val bir_prog_def = DB.fetch "poly1305" "bir_poly1305_prog_def"; +val _ = gen_prog_vars_birenvtyl_defthms "poly1305" bir_prog_def; + +val _ = export_theory (); diff --git a/examples/riscv/poly1305-inlined/poly1305_specScript.sml b/examples/riscv/poly1305-inlined/poly1305_specScript.sml new file mode 100644 index 000000000..3806aa35c --- /dev/null +++ b/examples/riscv/poly1305-inlined/poly1305_specScript.sml @@ -0,0 +1,68 @@ +open HolKernel boolLib Parse bossLib; + +open markerTheory; + +open wordsTheory; + +open bir_programSyntax bir_program_labelsTheory; +open bir_immTheory bir_valuesTheory bir_expTheory; +open bir_tsTheory bir_bool_expTheory bir_programTheory; + +open bir_riscv_backlifterTheory; +open bir_backlifterLib; +open bir_compositionLib; + +open bir_lifting_machinesTheory; +open bir_typing_expTheory; +open bir_htTheory; + +open bir_predLib; +open bir_smtLib; + +open bir_symbTheory birs_auxTheory; +open HolBACoreSimps; +open bir_program_transfTheory; + +open total_program_logicTheory; +open total_ext_program_logicTheory; +open symb_prop_transferTheory; + +open jgmt_rel_bir_contTheory; + +open pred_setTheory; + +open program_logicSimps; + +open bir_env_oldTheory; +open bir_program_varsTheory; + +val _ = new_theory "poly1305_spec"; + +(* ---------------- *) +(* Block boundaries *) +(* ---------------- *) + +(* init *) + +Definition poly1305_init_init_addr_def: + poly1305_init_init_addr : word64 = 0x10800w +End + +Definition poly1305_init_end_addr_def: + poly1305_init_end_addr : word64 = 0x109e0w +End + +(* --------------- *) +(* BSPEC contracts *) +(* --------------- *) + +val bspec_poly1305_init_pre_tm = bslSyntax.bandl [ + mem_addrs_aligned_prog_disj_bir_tm mem_params_standard "x10" +]; + +Definition bspec_poly1305_init_pre_def: + bspec_poly1305_init_pre : bir_exp_t = + ^bspec_poly1305_init_pre_tm +End + +val _ = export_theory (); diff --git a/examples/riscv/poly1305-inlined/poly1305_symb_execScript.sml b/examples/riscv/poly1305-inlined/poly1305_symb_execScript.sml new file mode 100644 index 000000000..88500df7c --- /dev/null +++ b/examples/riscv/poly1305-inlined/poly1305_symb_execScript.sml @@ -0,0 +1,35 @@ +open HolKernel Parse boolLib bossLib; + +open wordsTheory; + +open bir_symbLib; + +open poly1305Theory poly1305_specTheory; + +val _ = new_theory "poly1305_symb_exec"; + +(* --------------------------- *) +(* Symbolic analysis execution *) +(* --------------------------- *) + +val _ = show_tags := true; + +(* ------ *) +(* init *) +(* ------ *) + +val (bsysprecond_thm, symb_analysis_thm) = + bir_symb_analysis_thm + bir_poly1305_prog_def + poly1305_init_init_addr_def [poly1305_init_end_addr_def] + bspec_poly1305_init_pre_def poly1305_birenvtyl_def; + +val _ = Portable.pprint Tag.pp_tag (tag bsysprecond_thm); + +Theorem poly1305_init_bsysprecond_thm = bsysprecond_thm + +val _ = Portable.pprint Tag.pp_tag (tag symb_analysis_thm); + +Theorem poly1305_init_symb_analysis_thm = symb_analysis_thm + +val _ = export_theory (); From 481d2dda00662acc77a1776c31788cc15fe2f83f Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Mon, 23 Sep 2024 08:25:23 +0200 Subject: [PATCH 10/95] adjust non-inlined poly1305 spec --- examples/riscv/poly1305/poly1305_specScript.sml | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/examples/riscv/poly1305/poly1305_specScript.sml b/examples/riscv/poly1305/poly1305_specScript.sml index c931dc41d..8077bf46d 100644 --- a/examples/riscv/poly1305/poly1305_specScript.sml +++ b/examples/riscv/poly1305/poly1305_specScript.sml @@ -57,15 +57,11 @@ End (* --------------- *) val bspec_poly1305_u8to32_pre_tm = bslSyntax.bandl [ - mem_addrs_aligned_prog_disj_bir_tm mem_params_standard "x10", - ``BExp_BinPred - BIExp_Equal - (BExp_Den (BVar "x15" (BType_Imm Bit64))) - (BExp_Const (Imm64 pre_x15))`` + mem_addrs_aligned_prog_disj_bir_tm mem_params_standard "x10" ]; Definition bspec_poly1305_u8to32_pre_def: - bspec_poly1305_u8to32_pre (pre_x15:word64) : bir_exp_t = + bspec_poly1305_u8to32_pre : bir_exp_t = ^bspec_poly1305_u8to32_pre_tm End From 8ca4cff551584531413f6ae6e4955f0ea0d70ef5 Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Mon, 23 Sep 2024 09:00:38 +0200 Subject: [PATCH 11/95] WIP proving fmap-based contract transfer --- .../distribute_generic_stuffScript.sml | 38 ++++++++++++++++++- 1 file changed, 36 insertions(+), 2 deletions(-) diff --git a/src/tools/symbexec/distribute_generic_stuffScript.sml b/src/tools/symbexec/distribute_generic_stuffScript.sml index 2bcd68838..3846afa49 100644 --- a/src/tools/symbexec/distribute_generic_stuffScript.sml +++ b/src/tools/symbexec/distribute_generic_stuffScript.sml @@ -292,7 +292,7 @@ Proof METIS_TAC [] QED -Theorem prop_holds_TO_step_n_in_L_BIR_fmap_thm[local]: +Theorem prop_holds_TO_step_n_in_L_BIR_fmap_thm: !p start_lbl L envtyl vars bpre fm. (prop_holds (bir_symb_rec_sbir p) start_lbl L (P_bircont envtyl bpre) @@ -305,7 +305,13 @@ Theorem prop_holds_TO_step_n_in_L_BIR_fmap_thm[local]: st n L st' /\ (ITFMAP (\exit_albl bpost pLs. pLs \/ post_bircont_nL exit_albl vars bpost st st') fm F)) Proof - cheat + REPEAT STRIP_TAC >> + IMP_RES_TAC prop_holds_TO_step_n_in_L_thm >> + + FULL_SIMP_TAC std_ss [birs_symb_concst_pc_thm, P_bircont_pre_nL_thm, Q_bircont_post_nL_thm] >> + PAT_X_ASSUM ``!x. A`` IMP_RES_TAC >> + FULL_SIMP_TAC std_ss [P_bircont_pre_nL_thm, Q_bircont_post_nL_thm, birs_symb_concst_pc_thm, combinTheory.o_DEF, GSYM bir_programTheory.bir_exec_step_state_def] >> + METIS_TAC [] QED Theorem prop_holds_TO_step_n_in_L_BIR_two_thm: @@ -405,7 +411,35 @@ Theorem bir_step_n_in_L_jgmt_TO_abstract_jgmt_rel_SPEC_fmap_thm[local]: (pre_bircont_nL envtyl bpre) (\st st'. ITFMAP (\exit_albl bpost pLs. pLs \/ post_bircont_nL <|bpc_label := BL_Address exit_albl; bpc_index := 0|> vars bpost st st') fm F)) Proof + REPEAT STRIP_TAC >> + + IMP_RES_TAC ( + (REWRITE_RULE + [bir_programTheory.bir_block_pc_def] + bir_program_transfTheory.bir_step_n_in_L_jgmt_TO_abstract_jgmt_rel_thm)) >> + + FULL_SIMP_TAC std_ss [pre_bircont_nL_def] >> + POP_ASSUM (ASSUME_TAC o Q.SPEC `IMAGE (\exit_albl. BL_Address exit_albl) (FDOM (fm : bir_imm_t |-> bir_exp_t))`) >> cheat + + (* + sg `L INTER {<|bpc_label := BL_Address exit_albl_1; bpc_index := 0|>; <|bpc_label := BL_Address exit_albl_2; bpc_index := 0|>} = {}` >- + (REWRITE_TAC [GSYM DISJOINT_DEF, IN_DISJOINT] >> + REPEAT STRIP_TAC >> + FULL_SIMP_TAC (std_ss++pred_setLib.PRED_SET_ss) [] >> rw [] >> fs []) >> + FULL_SIMP_TAC (std_ss++pred_setLib.PRED_SET_ss) [IMAGE_DEF,bir_block_pc_def] >> + + `!st st'. post_bircont_nL + <|bpc_label := BL_Address exit_albl_1; bpc_index := 0|> vars bpost_1 st st' \/ + post_bircont_nL <|bpc_label := BL_Address exit_albl_2; bpc_index := 0|> vars bpost_2 st st' ==> + ?x. st'.bst_pc = <|bpc_label := x; bpc_index := 0|> /\ (x = BL_Address exit_albl_1 ∨ x = BL_Address exit_albl_2)` + by METIS_TAC [post_bircont_nL_def] >> + `!st st'. post_bircont_nL + <|bpc_label := BL_Address exit_albl_1; bpc_index := 0|> vars bpost_1 st st' \/ + post_bircont_nL <|bpc_label := BL_Address exit_albl_2; bpc_index := 0|> vars bpost_2 st st' ==> + ~bir_state_is_terminated st'` by (METIS_TAC [post_bircont_nL_def,bir_state_is_terminated_def]) >> + METIS_TAC [] + *) QED (* use the reasoning on label sets to get to abstract_jgmt_rel *) From 7c09de4064cdce1dc3aeb53162ff596047f8b43c Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Mon, 23 Sep 2024 11:06:31 +0200 Subject: [PATCH 12/95] move riscv aes test to aes directory for now --- examples/riscv/aes/Holmakefile | 8 ++++++++ examples/riscv/aes/test-aes.sml | 26 ++++++++++++++++++++++++++ examples/riscv/test-riscv.sml | 18 ------------------ 3 files changed, 34 insertions(+), 18 deletions(-) create mode 100644 examples/riscv/aes/test-aes.sml diff --git a/examples/riscv/aes/Holmakefile b/examples/riscv/aes/Holmakefile index a4e3a5025..f0de51fdd 100644 --- a/examples/riscv/aes/Holmakefile +++ b/examples/riscv/aes/Holmakefile @@ -22,6 +22,14 @@ INCLUDES = $(HOLDIR)/examples/l3-machine-code/common \ all: $(DEFAULT_TARGETS) .PHONY: all +test-aes.exe: test-aes.uo + $(HOLMOSMLC) -o $@ $< + +test: test-aes.exe + ./test-aes.exe + +EXTRA_CLEANS = test-aes.exe + ifdef POLY ifndef HOLBA_POLYML_HEAPLESS HOLHEAP = $(HOLBADIR)/src/holba-heap diff --git a/examples/riscv/aes/test-aes.sml b/examples/riscv/aes/test-aes.sml new file mode 100644 index 000000000..9de6005d6 --- /dev/null +++ b/examples/riscv/aes/test-aes.sml @@ -0,0 +1,26 @@ +open HolKernel Parse boolLib bossLib; + +val _ = Parse.current_backend := PPBackEnd.vt100_terminal; +val _ = Globals.show_tags := true; + +open wordsTheory; + +open bir_programSyntax bir_program_labelsTheory bir_immTheory; + +open aes_symb_execTheory; + +(* for now we just have a leightweight check; this is to include aes into the test *) +val _ = print "checking aes_symb_analysis_thm:\n"; + +val _ = if term_size (concl aes_symb_analysis_thm) = 23400 then () else + raise Fail "term size of aes symbolic execution theorem is not as expected"; + +val triple_tm = ((snd o dest_comb o concl) aes_symb_analysis_thm); +val (init_st_tm, pair_tm) = pairSyntax.dest_pair triple_tm; +val (prog_frag_L_tm, final_sts_tm) = pairSyntax.dest_pair pair_tm; +val final_sts_birs_tm = (snd o dest_comb) final_sts_tm; + +val _ = if (length o pred_setSyntax.strip_set) final_sts_birs_tm = 1 then () else + raise Fail "number of final states is not as expected"; + +val _ = print "ok!\n"; diff --git a/examples/riscv/test-riscv.sml b/examples/riscv/test-riscv.sml index 172b3c527..ab23909de 100644 --- a/examples/riscv/test-riscv.sml +++ b/examples/riscv/test-riscv.sml @@ -11,8 +11,6 @@ open swapTheory swap_symb_transfTheory swap_propTheory; open mod2Theory mod2_symb_transfTheory mod2_propTheory; open incrTheory incr_symb_transfTheory incr_propTheory; -open aes_symb_execTheory; - fun print_and_check_thm name thm t_concl = let val _ = print (name ^ ":\n"); @@ -143,19 +141,3 @@ val _ = print_and_check_thm bir_mod2_progbin mod2_init_addr {mod2_end_addr} (riscv_mod2_pre pre_x10) (riscv_mod2_post pre_x10)``; - -(* for now we just have a leightweight check; this is to include aes into the test *) -val _ = print "checking aes_symb_analysis_thm:\n"; - -val _ = if term_size (concl aes_symb_analysis_thm) = 23400 then () else - raise Fail "term size of aes symbolic execution theorem is not as expected"; - -val triple_tm = ((snd o dest_comb o concl) aes_symb_analysis_thm); -val (init_st_tm, pair_tm) = pairSyntax.dest_pair triple_tm; -val (prog_frag_L_tm, final_sts_tm) = pairSyntax.dest_pair pair_tm; -val final_sts_birs_tm = (snd o dest_comb) final_sts_tm; - -val _ = if (length o pred_setSyntax.strip_set) final_sts_birs_tm = 1 then () else - raise Fail "number of final states is not as expected"; - -val _ = print "ok!\n"; From f8199f68340ee125c09aadcc2bf1b5e2bde27173 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 23 Sep 2024 11:24:25 +0200 Subject: [PATCH 13/95] Enable default m0 models for lifting with lifting interface library --- src/tools/lifter/bir_lifter_interfaceLib.sig | 2 ++ src/tools/lifter/bir_lifter_interfaceLib.sml | 6 ++++++ 2 files changed, 8 insertions(+) diff --git a/src/tools/lifter/bir_lifter_interfaceLib.sig b/src/tools/lifter/bir_lifter_interfaceLib.sig index c5ce3a3a1..8c775f15c 100644 --- a/src/tools/lifter/bir_lifter_interfaceLib.sig +++ b/src/tools/lifter/bir_lifter_interfaceLib.sig @@ -3,6 +3,8 @@ sig datatype da_isa = da_arm8 + | da_cm0 + | da_cm0_mod | da_riscv val lift_da_and_store : string -> string -> da_isa -> Arbnum.num * Arbnum.num -> unit; diff --git a/src/tools/lifter/bir_lifter_interfaceLib.sml b/src/tools/lifter/bir_lifter_interfaceLib.sml index 75012f3d1..2935ea542 100644 --- a/src/tools/lifter/bir_lifter_interfaceLib.sml +++ b/src/tools/lifter/bir_lifter_interfaceLib.sml @@ -3,6 +3,8 @@ struct datatype da_isa = da_arm8 +| da_cm0 +| da_cm0_mod | da_riscv local @@ -38,11 +40,15 @@ in fun prog_gen_of_isa isa = case isa of da_arm8 => bmil_arm8.bir_lift_prog_gen + | da_cm0 => bmil_m0_LittleEnd_Process.bir_lift_prog_gen + | da_cm0_mod => bmil_m0_mod_LittleEnd_Process.bir_lift_prog_gen | da_riscv => bmil_riscv.bir_lift_prog_gen fun string_of_isa isa = case isa of da_arm8 => "arm8" + | da_cm0 => "cm0" + | da_cm0_mod => "cm0_mod" | da_riscv => "riscv" (* Debug values: From 409470116a0cb584e2bb701e468e6c87532f95ca Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 23 Sep 2024 11:25:35 +0200 Subject: [PATCH 14/95] Provide faster variable set computation for larger programs --- src/extra/holba_auxiliaryScript.sml | 37 ++++++++++++++++- src/theory/bir/bir_typing_progScript.sml | 51 ++++++++++++++++++++++++ src/tools/symbexec/birs_auxLib.sml | 13 ++++-- 3 files changed, 96 insertions(+), 5 deletions(-) diff --git a/src/extra/holba_auxiliaryScript.sml b/src/extra/holba_auxiliaryScript.sml index 5a223c24a..23b69103f 100644 --- a/src/extra/holba_auxiliaryScript.sml +++ b/src/extra/holba_auxiliaryScript.sml @@ -4,6 +4,7 @@ open holba_auxiliaryLib; open wordsTheory bitstringTheory ASCIInumbersTheory; open pred_setTheory; +open listTheory; val _ = new_theory "holba_auxiliary"; @@ -366,9 +367,43 @@ METIS_TAC [ ] QED +Theorem BIGUNION_IMAGE_BIGUNION_thm: + !s. + BIGUNION (IMAGE BIGUNION s) = BIGUNION (BIGUNION s) +Proof + gen_tac >> + rewrite_tac [BIGUNION_IMAGE] >> + fs [BIGUNION, EXTENSION] >> + metis_tac [] +QED + +(* -------------------------------------------------------------------------- *) +(* lat_setlist (flat to set) computation helper *) +(* -------------------------------------------------------------------------- *) + +Definition flat_setlist_def: + flat_setlist l <=> + FOLDL (\acc x. x UNION acc) EMPTY l +End + +Theorem flat_setlist_thm: + !l. + flat_setlist l = BIGUNION (set l) +Proof + GEN_TAC >> + REWRITE_TAC [flat_setlist_def] >> + REWRITE_TAC [(REWRITE_RULE [combinTheory.I_THM] o CONV_RULE (LAND_CONV (REWRITE_CONV [Once UNION_COMM])) o Q.SPECL [‘I’, ‘l’, ‘EMPTY’] o INST_TYPE [alpha |-> ``:'b -> bool``]) FOLDL_UNION_BIGUNION] >> + fs [] +QED + +Theorem flat_setlist_thm2: + flat_setlist = BIGUNION o set +Proof + fs [FUN_EQ_THM, flat_setlist_thm] +QED (* -------------------------------------------------------------------------- *) -(* Arithmetic *) +(* Arithmetic *) (* -------------------------------------------------------------------------- *) Theorem MOD_ADD_EQ_SUB: diff --git a/src/theory/bir/bir_typing_progScript.sml b/src/theory/bir/bir_typing_progScript.sml index c3efa4bfd..238942216 100644 --- a/src/theory/bir/bir_typing_progScript.sml +++ b/src/theory/bir/bir_typing_progScript.sml @@ -184,6 +184,57 @@ SIMP_TAC std_ss [bir_vars_of_program_def, bir_stmts_of_prog_def, METIS_TAC[] QED +(* alternative defintinition of bir_vars_of_block and bir_vars_of_prog to support faster collection for bigger programs *) +Definition bir_vars_of_block_as_setlist_def: + bir_vars_of_block_as_setlist bl <=> + ((bir_vars_of_stmtE bl.bb_last_statement)::(MAP bir_vars_of_stmtB bl.bb_statements)) +End + +local + open listTheory; +in +Theorem bir_vars_of_block_ALT_thm: + !bl. + (bir_vars_of_block bl = flat_setlist (bir_vars_of_block_as_setlist bl)) +Proof + GEN_TAC >> + REWRITE_TAC [bir_vars_of_block_def, bir_vars_of_block_as_setlist_def, flat_setlist_thm] >> + fs [LIST_TO_SET_MAP] >> + REWRITE_TAC [Once UNION_COMM] +QED + +Theorem bir_vars_of_block_ALT_IMAGE_set_thm: + !l. + (IMAGE bir_vars_of_block (set l) = IMAGE (flat_setlist o bir_vars_of_block_as_setlist) (set l)) +Proof + GEN_TAC >> + REWRITE_TAC [Once (prove(“bir_vars_of_block = \x. bir_vars_of_block x”, METIS_TAC[]))] >> + REWRITE_TAC [combinTheory.o_DEF, bir_vars_of_block_ALT_thm] +QED +end + +Definition bir_vars_of_program_as_setlist_def: + bir_vars_of_program_as_setlist (BirProgram p) <=> + (flat_setlist (FLAT (MAP bir_vars_of_block_as_setlist p))) +End + +local + open listTheory; +in +Theorem bir_vars_of_program_ALT_thm: + !p. + (bir_vars_of_program p = bir_vars_of_program_as_setlist p) +Proof + Cases_on ‘p’ >> + REWRITE_TAC [bir_vars_of_program_def, bir_vars_of_program_as_setlist_def, flat_setlist_thm] >> + + REWRITE_TAC [LIST_TO_SET_FLAT, LIST_TO_SET_MAP] >> + REWRITE_TAC [bir_vars_of_block_ALT_IMAGE_set_thm, flat_setlist_thm2] >> + + REWRITE_TAC [IMAGE_COMPOSE, BIGUNION_IMAGE_BIGUNION_thm] +QED +end + Theorem bir_get_current_statement_vars_of: !p pc stmt. (bir_get_current_statement p pc = SOME stmt) ==> diff --git a/src/tools/symbexec/birs_auxLib.sml b/src/tools/symbexec/birs_auxLib.sml index 33433e52a..7eb2d5bdf 100644 --- a/src/tools/symbexec/birs_auxLib.sml +++ b/src/tools/symbexec/birs_auxLib.sml @@ -50,11 +50,16 @@ in fun gen_prog_vars_set_thm bir_prog_def = let val prog_tm = (fst o dest_eq o concl) bir_prog_def; + val _ = print "\ncollecting program variables"; + val timer = holba_miscLib.timer_start 0; + val var_set_thm = + (REWRITE_CONV [bir_typing_progTheory.bir_vars_of_program_ALT_thm] THENC + EVAL) + ``bir_vars_of_program ^prog_tm``; + val _ = holba_miscLib.timer_stop + (fn delta_s => print (" - " ^ delta_s ^ "\n")) timer; in - (SIMP_CONV (std_ss++HolBASimps.VARS_OF_PROG_ss++pred_setLib.PRED_SET_ss) - [bir_prog_def] THENC - EVAL) - ``bir_vars_of_program ^prog_tm`` + var_set_thm end; fun gen_prog_vars_list_def_thm progname prog_vars_set_thm = From 5ae4ce24be6e83bb6dd3918a488538a89b726b1d Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Mon, 23 Sep 2024 15:35:22 +0200 Subject: [PATCH 15/95] add chachapoly example with lifting --- examples/riscv/chachapoly/Holmakefile | 36 +++ examples/riscv/chachapoly/chacha.c | 227 +++++++++++++++ examples/riscv/chachapoly/chacha.h | 38 +++ examples/riscv/chachapoly/chachapoly.c | 185 ++++++++++++ examples/riscv/chachapoly/chachapoly.h | 82 ++++++ .../riscv/chachapoly/chachapolyScript.sml | 20 ++ examples/riscv/chachapoly/poly1305.c | 263 ++++++++++++++++++ examples/riscv/chachapoly/poly1305.h | 32 +++ 8 files changed, 883 insertions(+) create mode 100644 examples/riscv/chachapoly/Holmakefile create mode 100644 examples/riscv/chachapoly/chacha.c create mode 100644 examples/riscv/chachapoly/chacha.h create mode 100644 examples/riscv/chachapoly/chachapoly.c create mode 100644 examples/riscv/chachapoly/chachapoly.h create mode 100644 examples/riscv/chachapoly/chachapolyScript.sml create mode 100644 examples/riscv/chachapoly/poly1305.c create mode 100644 examples/riscv/chachapoly/poly1305.h diff --git a/examples/riscv/chachapoly/Holmakefile b/examples/riscv/chachapoly/Holmakefile new file mode 100644 index 000000000..7e04a3a61 --- /dev/null +++ b/examples/riscv/chachapoly/Holmakefile @@ -0,0 +1,36 @@ +INCLUDES = $(HOLDIR)/examples/l3-machine-code/common \ + $(HOLDIR)/examples/l3-machine-code/arm8/model \ + $(HOLDIR)/examples/l3-machine-code/arm8/step \ + $(HOLDIR)/examples/l3-machine-code/m0/model \ + $(HOLDIR)/examples/l3-machine-code/m0/step \ + $(HOLDIR)/examples/l3-machine-code/riscv/model \ + $(HOLDIR)/examples/l3-machine-code/riscv/step \ + $(HOLBADIR)/src/theory/bir \ + $(HOLBADIR)/src/theory/bir-support \ + $(HOLBADIR)/src/theory/program_logic \ + $(HOLBADIR)/src/theory/tools/lifter \ + $(HOLBADIR)/src/theory/tools/backlifter \ + $(HOLBADIR)/src/tools/lifter \ + $(HOLBADIR)/src/tools/backlifter \ + $(HOLBADIR)/src/tools/exec \ + $(HOLBADIR)/src/tools/comp \ + $(HOLBADIR)/src/tools/wp \ + $(HOLBADIR)/src/tools/backlifter \ + $(HOLBADIR)/src/tools/symbexec \ + $(HOLBADIR)/src/tools/symbexec/examples/common \ + $(HOLBADIR)/src + +all: $(DEFAULT_TARGETS) +.PHONY: all + +chachapoly: + riscv64-unknown-linux-gnu-gcc -std=gnu99 -Wall -fno-builtin -fno-stack-protector -march=rv64g -O1 -o chachapoly chachapoly.c poly1305.c chacha.c + +chachapoly.da: + riscv64-unknown-linux-gnu-objdump -d chachapoly > chachapoly.da + +ifdef POLY +ifndef HOLBA_POLYML_HEAPLESS +HOLHEAP = $(HOLBADIR)/src/holba-heap +endif +endif diff --git a/examples/riscv/chachapoly/chacha.c b/examples/riscv/chachapoly/chacha.c new file mode 100644 index 000000000..ee35f8e9c --- /dev/null +++ b/examples/riscv/chachapoly/chacha.c @@ -0,0 +1,227 @@ +/* +chacha-merged.c version 20080118 +D. J. Bernstein +Public domain. +*/ + +#include "chacha.h" + +#define U8C(v) (v##U) +#define U32C(v) (v##U) + +#define U8V(v) ((unsigned char)(v) & U8C(0xFF)) +#define U32V(v) ((uint32_t)(v) & U32C(0xFFFFFFFF)) + +#define ROTL32(v, n) \ + (U32V((v) << (n)) | ((v) >> (32 - (n)))) + +#if (USE_UNALIGNED == 1) +#define U8TO32_LITTLE(p) \ + (*((uint32_t *)(p))) +#define U32TO8_LITTLE(p, v) \ + do { \ + *((uint32_t *)(p)) = v; \ + } while (0) +#else +#define U8TO32_LITTLE(p) \ + (((uint32_t)((p)[0]) ) | \ + ((uint32_t)((p)[1]) << 8) | \ + ((uint32_t)((p)[2]) << 16) | \ + ((uint32_t)((p)[3]) << 24)) +#define U32TO8_LITTLE(p, v) \ + do { \ + (p)[0] = U8V((v) ); \ + (p)[1] = U8V((v) >> 8); \ + (p)[2] = U8V((v) >> 16); \ + (p)[3] = U8V((v) >> 24); \ + } while (0) +#endif + +#define ROTATE(v,c) (ROTL32(v,c)) +#define XOR(v,w) ((v) ^ (w)) +#define PLUS(v,w) (U32V((v) + (w))) +#define PLUSONE(v) (PLUS((v),1)) + +#define QUARTERROUND(a,b,c,d) \ + a = PLUS(a,b); d = ROTATE(XOR(d,a),16); \ + c = PLUS(c,d); b = ROTATE(XOR(b,c),12); \ + a = PLUS(a,b); d = ROTATE(XOR(d,a), 8); \ + c = PLUS(c,d); b = ROTATE(XOR(b,c), 7); + +static const char sigma[16] = "expand 32-byte k"; +static const char tau[16] = "expand 16-byte k"; + +void +chacha_keysetup(struct chacha_ctx *x,const unsigned char *k,uint32_t kbits) +{ + const char *constants; + + x->input[4] = U8TO32_LITTLE(k + 0); + x->input[5] = U8TO32_LITTLE(k + 4); + x->input[6] = U8TO32_LITTLE(k + 8); + x->input[7] = U8TO32_LITTLE(k + 12); + if (kbits == 256) { /* recommended */ + k += 16; + constants = sigma; + } else { /* kbits == 128 */ + constants = tau; + } + x->input[8] = U8TO32_LITTLE(k + 0); + x->input[9] = U8TO32_LITTLE(k + 4); + x->input[10] = U8TO32_LITTLE(k + 8); + x->input[11] = U8TO32_LITTLE(k + 12); + x->input[0] = U8TO32_LITTLE(constants + 0); + x->input[1] = U8TO32_LITTLE(constants + 4); + x->input[2] = U8TO32_LITTLE(constants + 8); + x->input[3] = U8TO32_LITTLE(constants + 12); +} + +void +chacha_ivsetup(struct chacha_ctx *x, const unsigned char *iv, const unsigned char *counter) +{ + x->input[12] = counter == NULL ? 0 : U8TO32_LITTLE(counter + 0); + //x->input[13] = counter == NULL ? 0 : U8TO32_LITTLE(counter + 4); + x->input[13] = U8TO32_LITTLE(iv + 0); + x->input[14] = U8TO32_LITTLE(iv + 4); + x->input[15] = U8TO32_LITTLE(iv + 8); +} + +void +chacha_encrypt_bytes(struct chacha_ctx *x,const unsigned char *m,unsigned char *c,uint32_t bytes) +{ + uint32_t x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15; + uint32_t j0, j1, j2, j3, j4, j5, j6, j7, j8, j9, j10, j11, j12, j13, j14, j15; + unsigned char *ctarget = NULL; + unsigned char tmp[64]; + u_int i; + + if (!bytes) return; + + j0 = x->input[0]; + j1 = x->input[1]; + j2 = x->input[2]; + j3 = x->input[3]; + j4 = x->input[4]; + j5 = x->input[5]; + j6 = x->input[6]; + j7 = x->input[7]; + j8 = x->input[8]; + j9 = x->input[9]; + j10 = x->input[10]; + j11 = x->input[11]; + j12 = x->input[12]; + j13 = x->input[13]; + j14 = x->input[14]; + j15 = x->input[15]; + + for (;;) { + if (bytes < 64) { +#if (USE_MEMCPY == 1) + memcpy(tmp, m, bytes); +#else + for (i = 0;i < bytes;++i) tmp[i] = m[i]; +#endif + m = tmp; + ctarget = c; + c = tmp; + } + x0 = j0; + x1 = j1; + x2 = j2; + x3 = j3; + x4 = j4; + x5 = j5; + x6 = j6; + x7 = j7; + x8 = j8; + x9 = j9; + x10 = j10; + x11 = j11; + x12 = j12; + x13 = j13; + x14 = j14; + x15 = j15; + for (i = 20;i > 0;i -= 2) { + QUARTERROUND( x0, x4, x8,x12) + QUARTERROUND( x1, x5, x9,x13) + QUARTERROUND( x2, x6,x10,x14) + QUARTERROUND( x3, x7,x11,x15) + QUARTERROUND( x0, x5,x10,x15) + QUARTERROUND( x1, x6,x11,x12) + QUARTERROUND( x2, x7, x8,x13) + QUARTERROUND( x3, x4, x9,x14) + } + x0 = PLUS(x0,j0); + x1 = PLUS(x1,j1); + x2 = PLUS(x2,j2); + x3 = PLUS(x3,j3); + x4 = PLUS(x4,j4); + x5 = PLUS(x5,j5); + x6 = PLUS(x6,j6); + x7 = PLUS(x7,j7); + x8 = PLUS(x8,j8); + x9 = PLUS(x9,j9); + x10 = PLUS(x10,j10); + x11 = PLUS(x11,j11); + x12 = PLUS(x12,j12); + x13 = PLUS(x13,j13); + x14 = PLUS(x14,j14); + x15 = PLUS(x15,j15); + + x0 = XOR(x0,U8TO32_LITTLE(m + 0)); + x1 = XOR(x1,U8TO32_LITTLE(m + 4)); + x2 = XOR(x2,U8TO32_LITTLE(m + 8)); + x3 = XOR(x3,U8TO32_LITTLE(m + 12)); + x4 = XOR(x4,U8TO32_LITTLE(m + 16)); + x5 = XOR(x5,U8TO32_LITTLE(m + 20)); + x6 = XOR(x6,U8TO32_LITTLE(m + 24)); + x7 = XOR(x7,U8TO32_LITTLE(m + 28)); + x8 = XOR(x8,U8TO32_LITTLE(m + 32)); + x9 = XOR(x9,U8TO32_LITTLE(m + 36)); + x10 = XOR(x10,U8TO32_LITTLE(m + 40)); + x11 = XOR(x11,U8TO32_LITTLE(m + 44)); + x12 = XOR(x12,U8TO32_LITTLE(m + 48)); + x13 = XOR(x13,U8TO32_LITTLE(m + 52)); + x14 = XOR(x14,U8TO32_LITTLE(m + 56)); + x15 = XOR(x15,U8TO32_LITTLE(m + 60)); + + j12 = PLUSONE(j12); + if (!j12) { + j13 = PLUSONE(j13); + /* stopping at 2^70 bytes per nonce is user's responsibility */ + } + + U32TO8_LITTLE(c + 0,x0); + U32TO8_LITTLE(c + 4,x1); + U32TO8_LITTLE(c + 8,x2); + U32TO8_LITTLE(c + 12,x3); + U32TO8_LITTLE(c + 16,x4); + U32TO8_LITTLE(c + 20,x5); + U32TO8_LITTLE(c + 24,x6); + U32TO8_LITTLE(c + 28,x7); + U32TO8_LITTLE(c + 32,x8); + U32TO8_LITTLE(c + 36,x9); + U32TO8_LITTLE(c + 40,x10); + U32TO8_LITTLE(c + 44,x11); + U32TO8_LITTLE(c + 48,x12); + U32TO8_LITTLE(c + 52,x13); + U32TO8_LITTLE(c + 56,x14); + U32TO8_LITTLE(c + 60,x15); + + if (bytes <= 64) { + if (bytes < 64) { +#if (USE_MEMCPY == 1) + memcpy(ctarget, c, bytes); +#else + for (i = 0;i < bytes;++i) ctarget[i] = c[i]; +#endif + } + x->input[12] = j12; + x->input[13] = j13; + return; + } + bytes -= 64; + c += 64; + m += 64; + } +} diff --git a/examples/riscv/chachapoly/chacha.h b/examples/riscv/chachapoly/chacha.h new file mode 100644 index 000000000..e316a8657 --- /dev/null +++ b/examples/riscv/chachapoly/chacha.h @@ -0,0 +1,38 @@ +/* +chacha-merged.c version 20080118 +D. J. Bernstein +Public domain. +*/ + +#ifndef CHACHA_H +#define CHACHA_H + +#include +#include +#include +#include + +#define CHACHA_MINKEYLEN 16 +#define CHACHA_NONCELEN 8 +#define CHACHA_CTRLEN 8 +#define CHACHA_STATELEN (CHACHA_NONCELEN+CHACHA_CTRLEN) +#define CHACHA_BLOCKLEN 64 + +/* use memcpy() to copy blocks of memory (typically faster) */ +#define USE_MEMCPY 0 +/* use unaligned little-endian load/store (can be faster) */ +#define USE_UNALIGNED 0 + +struct chacha_ctx { + uint32_t input[16]; +}; + +void chacha_keysetup(struct chacha_ctx *x, const unsigned char *k, + uint32_t kbits); +void chacha_ivsetup(struct chacha_ctx *x, const unsigned char *iv, + const unsigned char *ctr); +void chacha_encrypt_bytes(struct chacha_ctx *x, const unsigned char *m, + unsigned char *c, uint32_t bytes); + +#endif /* CHACHA_H */ + diff --git a/examples/riscv/chachapoly/chachapoly.c b/examples/riscv/chachapoly/chachapoly.c new file mode 100644 index 000000000..8f9e73dc9 --- /dev/null +++ b/examples/riscv/chachapoly/chachapoly.c @@ -0,0 +1,185 @@ +/* + * The MIT License (MIT) + * + * Copyright (c) 2015 Grigori Goronzy + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in all + * copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include +#include +#include +#include + +#include "chachapoly.h" + +/** + * Constant-time memory compare. This should help to protect against + * side-channel attacks. + * + * \param av input 1 + * \param bv input 2 + * \param n bytes to compare + * \return 0 if inputs are equal + */ +static int memcmp_eq(const void *av, const void *bv, int n) +{ + const unsigned char *a = (const unsigned char*) av; + const unsigned char *b = (const unsigned char*) bv; + unsigned char res = 0; + int i; + + for (i = 0; i < n; i++) { + res |= *a ^ *b; + a++; + b++; + } + + return res; +} + +/** + * Poly1305 tag generation. This concatenates a string according to the rules + * outlined in RFC 7539 and calculates the tag. + * + * \param poly_key 32 byte secret one-time key for poly1305 + * \param ad associated data + * \param ad_len associated data length in bytes + * \param ct ciphertext + * \param ct_len ciphertext length in bytes + * \param tag pointer to 16 bytes for tag storage + */ +static void poly1305_get_tag(unsigned char *poly_key, const void *ad, + int ad_len, const void *ct, int ct_len, unsigned char *tag) +{ + struct poly1305_context poly; + unsigned left_over; + uint64_t len; + unsigned char pad[16]; + + poly1305_init(&poly, poly_key); + memset(&pad, 0, sizeof(pad)); + + /* associated data and padding */ + poly1305_update(&poly, ad, ad_len); + left_over = ad_len % 16; + if (left_over) + poly1305_update(&poly, pad, 16 - left_over); + + /* payload and padding */ + poly1305_update(&poly, ct, ct_len); + left_over = ct_len % 16; + if (left_over) + poly1305_update(&poly, pad, 16 - left_over); + + /* lengths */ + len = ad_len; + poly1305_update(&poly, (unsigned char *)&len, 8); + len = ct_len; + poly1305_update(&poly, (unsigned char *)&len, 8); + + poly1305_finish(&poly, tag); +} + +int chachapoly_init(struct chachapoly_ctx *ctx, const void *key, int key_len) +{ + assert (key_len == 128 || key_len == 256); + + memset(ctx, 0, sizeof(*ctx)); + chacha_keysetup(&ctx->cha_ctx, key, key_len); + return CHACHAPOLY_OK; +} + +int chachapoly_crypt(struct chachapoly_ctx *ctx, const void *nonce, + const void *ad, int ad_len, void *input, int input_len, + void *output, void *tag, int tag_len, int encrypt) +{ + unsigned char poly_key[CHACHA_BLOCKLEN]; + unsigned char calc_tag[POLY1305_TAGLEN]; + const unsigned char one[4] = { 1, 0, 0, 0 }; + + /* initialize keystream and generate poly1305 key */ + memset(poly_key, 0, sizeof(poly_key)); + chacha_ivsetup(&ctx->cha_ctx, nonce, NULL); + chacha_encrypt_bytes(&ctx->cha_ctx, poly_key, poly_key, sizeof(poly_key)); + + /* check tag if decrypting */ + if (encrypt == 0 && tag_len) { + poly1305_get_tag(poly_key, ad, ad_len, input, input_len, calc_tag); + if (memcmp_eq(calc_tag, tag, tag_len) != 0) { + return CHACHAPOLY_INVALID_MAC; + } + } + + /* crypt data */ + chacha_ivsetup(&ctx->cha_ctx, nonce, one); + chacha_encrypt_bytes(&ctx->cha_ctx, (unsigned char *)input, + (unsigned char *)output, input_len); + + /* add tag if encrypting */ + if (encrypt && tag_len) { + poly1305_get_tag(poly_key, ad, ad_len, output, input_len, calc_tag); + memcpy(tag, calc_tag, tag_len); + } + + return CHACHAPOLY_OK; +} + +int chachapoly_crypt_short(struct chachapoly_ctx *ctx, const void *nonce, + const void *ad, int ad_len, void *input, int input_len, + void *output, void *tag, int tag_len, int encrypt) +{ + unsigned char keystream[CHACHA_BLOCKLEN]; + unsigned char calc_tag[POLY1305_TAGLEN]; + int i; + + assert(input_len <= 32); + + /* initialize keystream and generate poly1305 key */ + memset(keystream, 0, sizeof(keystream)); + chacha_ivsetup(&ctx->cha_ctx, nonce, NULL); + chacha_encrypt_bytes(&ctx->cha_ctx, keystream, keystream, + sizeof(keystream)); + + /* check tag if decrypting */ + if (encrypt == 0 && tag_len) { + poly1305_get_tag(keystream, ad, ad_len, input, input_len, calc_tag); + if (memcmp_eq(calc_tag, tag, tag_len) != 0) { + return CHACHAPOLY_INVALID_MAC; + } + } + + /* crypt data */ + for (i = 0; i < input_len; i++) { + ((unsigned char *)output)[i] = + ((unsigned char *)input)[i] ^ keystream[32 + i]; + } + + /* add tag if encrypting */ + if (encrypt && tag_len) { + poly1305_get_tag(keystream, ad, ad_len, output, input_len, calc_tag); + memcpy(tag, calc_tag, tag_len); + } + + return CHACHAPOLY_OK; +} + +int main(void) { + return 0; +} diff --git a/examples/riscv/chachapoly/chachapoly.h b/examples/riscv/chachapoly/chachapoly.h new file mode 100644 index 000000000..f26d2c41f --- /dev/null +++ b/examples/riscv/chachapoly/chachapoly.h @@ -0,0 +1,82 @@ +/* + * The MIT License (MIT) + * + * Copyright (c) 2015 Grigori Goronzy + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in all + * copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#ifndef CHACHAPOLY_H +#define CHACHAPOLY_H + +#include "chacha.h" +#include "poly1305.h" + +#define CHACHAPOLY_OK 0 +#define CHACHAPOLY_INVALID_MAC -1 + +struct chachapoly_ctx { + struct chacha_ctx cha_ctx; +}; + +/** + * Initialize ChaCha20-Poly1305 AEAD. + * For RFC 7539 conformant AEAD, 256 bit keys must be used. + * + * \param ctx context data + * \param key 16 or 32 bytes of key material + * \param key_len key length, 256 or 512 bits + * \return success if 0 + */ +int chachapoly_init(struct chachapoly_ctx *ctx, const void *key, int key_len); + +/** + * Encrypt or decrypt with ChaCha20-Poly1305. The AEAD construction conforms + * to RFC 7539. + * + * \param ctx context data + * \param nonce nonce (12 bytes) + * \param ad associated data + * \param ad_len associated data length in bytes + * \param input plaintext/ciphertext input + * \param input_len input length in bytes; + * \param output plaintext/ciphertext output + * \param tag tag output + * \param tag_len tag length in bytes (0-16); + if 0, authentification is skipped + * \param encrypt decrypt if 0, else encrypt + * \return CHACHAPOLY_OK if no error, CHACHAPOLY_INVALID_MAC if auth + * failed when decrypting + */ +int chachapoly_crypt(struct chachapoly_ctx *ctx, const void *nonce, + const void *ad, int ad_len, void *input, int input_len, + void *output, void *tag, int tag_len, int encrypt); + +/** + * Encrypt or decrypt with Chacha20-Poly1305 for short messages. + * The AEAD construction is different from chachapoly_crypt, but more + * efficient for small messages. Up to 32 bytes can be encrypted. The size + * of associated data is not restricted. The interface is similar to + * chachapoly_crypt. + */ +int chachapoly_crypt_short(struct chachapoly_ctx *ctx, const void *nonce, + const void *ad, int ad_len, void *input, int input_len, + void *output, void *tag, int tag_len, int encrypt); + +#endif diff --git a/examples/riscv/chachapoly/chachapolyScript.sml b/examples/riscv/chachapoly/chachapolyScript.sml new file mode 100644 index 000000000..d0e1949a9 --- /dev/null +++ b/examples/riscv/chachapoly/chachapolyScript.sml @@ -0,0 +1,20 @@ +open HolKernel Parse; + +open bir_lifter_interfaceLib; +open birs_auxLib; + +val _ = Parse.current_backend := PPBackEnd.vt100_terminal; +val _ = set_trace "bir_inst_lifting.DEBUG_LEVEL" 2; + +val _ = new_theory "chachapoly"; + +val _ = lift_da_and_store "chachapoly" "chachapoly.da" da_riscv ((Arbnum.fromInt 0x105a8), (Arbnum.fromInt 0x120BC)); + +(* ----------------------------------------- *) +(* Program variable definitions and theorems *) +(* ----------------------------------------- *) + +val bir_prog_def = DB.fetch "chachapoly" "bir_chachapoly_prog_def"; +val _ = gen_prog_vars_birenvtyl_defthms "chachapoly" bir_prog_def; + +val _ = export_theory (); diff --git a/examples/riscv/chachapoly/poly1305.c b/examples/riscv/chachapoly/poly1305.c new file mode 100644 index 000000000..499c4464c --- /dev/null +++ b/examples/riscv/chachapoly/poly1305.c @@ -0,0 +1,263 @@ +/* +poly1305 implementation using 32 bit * 32 bit = 64 bit multiplication and 64 bit addition +public domain +*/ + +#include "poly1305.h" + +#if (USE_UNALIGNED == 1) +#define U8TO32(p) \ + (*((uint32_t *)(p))) +#define U32TO8(p, v) \ + do { \ + *((uint32_t *)(p)) = v; \ + } while (0) +#else +/* interpret four 8 bit unsigned integers as a 32 bit unsigned integer in little endian */ +static uint32_t +U8TO32(const unsigned char *p) +{ + return + (((uint32_t)(p[0] & 0xff) ) | + ((uint32_t)(p[1] & 0xff) << 8) | + ((uint32_t)(p[2] & 0xff) << 16) | + ((uint32_t)(p[3] & 0xff) << 24)); +} + +/* store a 32 bit unsigned integer as four 8 bit unsigned integers in little endian */ +static void +U32TO8(unsigned char *p, uint32_t v) +{ + p[0] = (v ) & 0xff; + p[1] = (v >> 8) & 0xff; + p[2] = (v >> 16) & 0xff; + p[3] = (v >> 24) & 0xff; +} +#endif + +void +poly1305_init(struct poly1305_context *st, const unsigned char key[32]) +{ + /* r &= 0xffffffc0ffffffc0ffffffc0fffffff */ + st->r[0] = (U8TO32(&key[ 0]) ) & 0x3ffffff; + st->r[1] = (U8TO32(&key[ 3]) >> 2) & 0x3ffff03; + st->r[2] = (U8TO32(&key[ 6]) >> 4) & 0x3ffc0ff; + st->r[3] = (U8TO32(&key[ 9]) >> 6) & 0x3f03fff; + st->r[4] = (U8TO32(&key[12]) >> 8) & 0x00fffff; + + /* h = 0 */ + st->h[0] = 0; + st->h[1] = 0; + st->h[2] = 0; + st->h[3] = 0; + st->h[4] = 0; + + /* save pad for later */ + st->pad[0] = U8TO32(&key[16]); + st->pad[1] = U8TO32(&key[20]); + st->pad[2] = U8TO32(&key[24]); + st->pad[3] = U8TO32(&key[28]); + + st->leftover = 0; + st->final = 0; +} + +static void +poly1305_blocks(struct poly1305_context *st, const unsigned char *m, size_t bytes) +{ + const uint32_t hibit = (st->final) ? 0 : (1 << 24); /* 1 << 128 */ + uint32_t r0,r1,r2,r3,r4; + uint32_t s1,s2,s3,s4; + uint32_t h0,h1,h2,h3,h4; + uint64_t d0,d1,d2,d3,d4; + uint32_t c; + + r0 = st->r[0]; + r1 = st->r[1]; + r2 = st->r[2]; + r3 = st->r[3]; + r4 = st->r[4]; + + s1 = r1 * 5; + s2 = r2 * 5; + s3 = r3 * 5; + s4 = r4 * 5; + + h0 = st->h[0]; + h1 = st->h[1]; + h2 = st->h[2]; + h3 = st->h[3]; + h4 = st->h[4]; + + while (bytes >= POLY1305_BLOCK_SIZE) { + /* h += m[i] */ + h0 += (U8TO32(m+ 0) ) & 0x3ffffff; + h1 += (U8TO32(m+ 3) >> 2) & 0x3ffffff; + h2 += (U8TO32(m+ 6) >> 4) & 0x3ffffff; + h3 += (U8TO32(m+ 9) >> 6) & 0x3ffffff; + h4 += (U8TO32(m+12) >> 8) | hibit; + + /* h *= r */ + d0 = ((uint64_t)h0 * r0) + ((uint64_t)h1 * s4) + ((uint64_t)h2 * s3) + ((uint64_t)h3 * s2) + ((uint64_t)h4 * s1); + d1 = ((uint64_t)h0 * r1) + ((uint64_t)h1 * r0) + ((uint64_t)h2 * s4) + ((uint64_t)h3 * s3) + ((uint64_t)h4 * s2); + d2 = ((uint64_t)h0 * r2) + ((uint64_t)h1 * r1) + ((uint64_t)h2 * r0) + ((uint64_t)h3 * s4) + ((uint64_t)h4 * s3); + d3 = ((uint64_t)h0 * r3) + ((uint64_t)h1 * r2) + ((uint64_t)h2 * r1) + ((uint64_t)h3 * r0) + ((uint64_t)h4 * s4); + d4 = ((uint64_t)h0 * r4) + ((uint64_t)h1 * r3) + ((uint64_t)h2 * r2) + ((uint64_t)h3 * r1) + ((uint64_t)h4 * r0); + + /* (partial) h %= p */ + c = (uint32_t)(d0 >> 26); h0 = (uint32_t)d0 & 0x3ffffff; + d1 += c; c = (uint32_t)(d1 >> 26); h1 = (uint32_t)d1 & 0x3ffffff; + d2 += c; c = (uint32_t)(d2 >> 26); h2 = (uint32_t)d2 & 0x3ffffff; + d3 += c; c = (uint32_t)(d3 >> 26); h3 = (uint32_t)d3 & 0x3ffffff; + d4 += c; c = (uint32_t)(d4 >> 26); h4 = (uint32_t)d4 & 0x3ffffff; + h0 += c * 5; c = (h0 >> 26); h0 = h0 & 0x3ffffff; + h1 += c; + + m += POLY1305_BLOCK_SIZE; + bytes -= POLY1305_BLOCK_SIZE; + } + + st->h[0] = h0; + st->h[1] = h1; + st->h[2] = h2; + st->h[3] = h3; + st->h[4] = h4; +} + +void +poly1305_finish(struct poly1305_context *st, unsigned char mac[16]) +{ + uint32_t h0,h1,h2,h3,h4,c; + uint32_t g0,g1,g2,g3,g4; + uint64_t f; + uint32_t mask; + + /* process the remaining block */ + if (st->leftover) { + size_t i = st->leftover; + st->buffer[i++] = 1; + for (; i < POLY1305_BLOCK_SIZE; i++) + st->buffer[i] = 0; + st->final = 1; + poly1305_blocks(st, st->buffer, POLY1305_BLOCK_SIZE); + } + + /* fully carry h */ + h0 = st->h[0]; + h1 = st->h[1]; + h2 = st->h[2]; + h3 = st->h[3]; + h4 = st->h[4]; + + c = h1 >> 26; h1 = h1 & 0x3ffffff; + h2 += c; c = h2 >> 26; h2 = h2 & 0x3ffffff; + h3 += c; c = h3 >> 26; h3 = h3 & 0x3ffffff; + h4 += c; c = h4 >> 26; h4 = h4 & 0x3ffffff; + h0 += c * 5; c = h0 >> 26; h0 = h0 & 0x3ffffff; + h1 += c; + + /* compute h + -p */ + g0 = h0 + 5; c = g0 >> 26; g0 &= 0x3ffffff; + g1 = h1 + c; c = g1 >> 26; g1 &= 0x3ffffff; + g2 = h2 + c; c = g2 >> 26; g2 &= 0x3ffffff; + g3 = h3 + c; c = g3 >> 26; g3 &= 0x3ffffff; + g4 = h4 + c - (1 << 26); + + /* select h if h < p, or h + -p if h >= p */ + mask = (g4 >> ((sizeof(uint32_t) * 8) - 1)) - 1; + g0 &= mask; + g1 &= mask; + g2 &= mask; + g3 &= mask; + g4 &= mask; + mask = ~mask; + h0 = (h0 & mask) | g0; + h1 = (h1 & mask) | g1; + h2 = (h2 & mask) | g2; + h3 = (h3 & mask) | g3; + h4 = (h4 & mask) | g4; + + /* h = h % (2^128) */ + h0 = ((h0 ) | (h1 << 26)) & 0xffffffff; + h1 = ((h1 >> 6) | (h2 << 20)) & 0xffffffff; + h2 = ((h2 >> 12) | (h3 << 14)) & 0xffffffff; + h3 = ((h3 >> 18) | (h4 << 8)) & 0xffffffff; + + /* mac = (h + pad) % (2^128) */ + f = (uint64_t)h0 + st->pad[0] ; h0 = (uint32_t)f; + f = (uint64_t)h1 + st->pad[1] + (f >> 32); h1 = (uint32_t)f; + f = (uint64_t)h2 + st->pad[2] + (f >> 32); h2 = (uint32_t)f; + f = (uint64_t)h3 + st->pad[3] + (f >> 32); h3 = (uint32_t)f; + + U32TO8(mac + 0, h0); + U32TO8(mac + 4, h1); + U32TO8(mac + 8, h2); + U32TO8(mac + 12, h3); + + /* zero out the state */ + st->h[0] = 0; + st->h[1] = 0; + st->h[2] = 0; + st->h[3] = 0; + st->h[4] = 0; + st->r[0] = 0; + st->r[1] = 0; + st->r[2] = 0; + st->r[3] = 0; + st->r[4] = 0; + st->pad[0] = 0; + st->pad[1] = 0; + st->pad[2] = 0; + st->pad[3] = 0; +} + + +void +poly1305_update(struct poly1305_context *st, const unsigned char *m, size_t bytes) +{ + size_t i; + + /* handle leftover */ + if (st->leftover) { + size_t want = (POLY1305_BLOCK_SIZE - st->leftover); + if (want > bytes) + want = bytes; + for (i = 0; i < want; i++) + st->buffer[st->leftover + i] = m[i]; + bytes -= want; + m += want; + st->leftover += want; + if (st->leftover < POLY1305_BLOCK_SIZE) + return; + poly1305_blocks(st, st->buffer, POLY1305_BLOCK_SIZE); + st->leftover = 0; + } + + /* process full blocks */ + if (bytes >= POLY1305_BLOCK_SIZE) { + size_t want = (bytes & ~(POLY1305_BLOCK_SIZE - 1)); + poly1305_blocks(st, m, want); + m += want; + bytes -= want; + } + + /* store leftover */ + if (bytes) { +#if (USE_MEMCPY == 1) + memcpy(st->buffer + st->leftover, m, bytes); +#else + for (i = 0; i < bytes; i++) + st->buffer[st->leftover + i] = m[i]; +#endif + st->leftover += bytes; + } +} + +void +poly1305_auth(unsigned char mac[16], const unsigned char *m, size_t bytes, const unsigned char key[32]) +{ + struct poly1305_context ctx; + poly1305_init(&ctx, key); + poly1305_update(&ctx, m, bytes); + poly1305_finish(&ctx, mac); +} diff --git a/examples/riscv/chachapoly/poly1305.h b/examples/riscv/chachapoly/poly1305.h new file mode 100644 index 000000000..b8ef1cfaa --- /dev/null +++ b/examples/riscv/chachapoly/poly1305.h @@ -0,0 +1,32 @@ +#ifndef POLY1305_H +#define POLY1305_H + +#include +#include +#include + +#define POLY1305_KEYLEN 32 +#define POLY1305_TAGLEN 16 +#define POLY1305_BLOCK_SIZE 16 + +/* use memcpy() to copy blocks of memory (typically faster) */ +#define USE_MEMCPY 0 +/* use unaligned little-endian load/store (can be faster) */ +#define USE_UNALIGNED 0 + +struct poly1305_context { + uint32_t r[5]; + uint32_t h[5]; + uint32_t pad[4]; + size_t leftover; + unsigned char buffer[POLY1305_BLOCK_SIZE]; + unsigned char final; +}; + +void poly1305_init(struct poly1305_context *ctx, const unsigned char key[32]); +void poly1305_update(struct poly1305_context *ctx, const unsigned char *m, size_t bytes); +void poly1305_finish(struct poly1305_context *ctx, unsigned char mac[16]); +void poly1305_auth(unsigned char mac[16], const unsigned char *m, size_t bytes, const unsigned char key[32]); + +#endif /* POLY1305_H */ + From 9940099cabdc67fc4b7a8f493169215d7608cb96 Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Mon, 23 Sep 2024 18:11:30 +0200 Subject: [PATCH 16/95] increase CI test timeout --- .github/workflows/build.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/build.yaml b/.github/workflows/build.yaml index 981e61ecb..ceb1bdb54 100644 --- a/.github/workflows/build.yaml +++ b/.github/workflows/build.yaml @@ -60,7 +60,7 @@ jobs: ./scripts/ci/run_holmake.sh - name: Run tests - timeout-minutes: 40 + timeout-minutes: 55 run: | ./scripts/ci/run_make.sh tests From a3aa16593a1f82ea3633cd50de94bc3fcd273e60 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 23 Sep 2024 21:17:50 +0200 Subject: [PATCH 17/95] Improve (handle program labels with other width and more output) --- src/tools/symbexec/bir_symbLib.sml | 28 ++++++++++++++++------------ src/tools/symbexec/birs_auxLib.sml | 4 ++++ 2 files changed, 20 insertions(+), 12 deletions(-) diff --git a/src/tools/symbexec/bir_symbLib.sml b/src/tools/symbexec/bir_symbLib.sml index 83dac6cc6..87cea27bf 100644 --- a/src/tools/symbexec/bir_symbLib.sml +++ b/src/tools/symbexec/bir_symbLib.sml @@ -10,6 +10,7 @@ local open birs_composeLib; open birs_driveLib; open birs_auxTheory; + open bir_immSyntax; in fun bir_symb_analysis bprog_tm birs_state_init_lbl @@ -85,12 +86,12 @@ fun bir_symb_analysis_thm bir_prog_def val bprog_tm = (fst o dest_eq o concl) bir_prog_def; val init_addr_tm = (snd o dest_eq o concl) init_addr_def; val birs_state_init_lbl_tm = - (snd o dest_eq o concl o EVAL) ``bir_block_pc (BL_Address (Imm64 ^init_addr_tm))``; + (snd o dest_eq o concl o EVAL) ``bir_block_pc (BL_Address ^(gen_mk_Imm init_addr_tm))``; val birs_state_end_tm_lbls = List.map (fn end_addr_def => let val end_addr_tm = (snd o dest_eq o concl) end_addr_def in - (snd o dest_eq o concl o EVAL) ``bir_block_pc (BL_Address (Imm64 ^end_addr_tm))`` + (snd o dest_eq o concl o EVAL) ``bir_block_pc (BL_Address ^(gen_mk_Imm end_addr_tm))`` end) end_addr_defs; val bspec_pre_tm = (lhs o snd o strip_forall o concl) bspec_pre_def; val bprog_envtyl_tm = (fst o dest_eq o concl) birenvtyl_def; @@ -141,6 +142,7 @@ local open bir_env_oldTheory; open bir_program_varsTheory; open distribute_generic_stuffTheory; + open bir_immSyntax; in fun bir_symb_transfer init_addr_tm end_addr_tm bspec_pre_tm bspec_post_tm @@ -151,10 +153,12 @@ fun bir_symb_transfer init_addr_tm end_addr_tm bspec_pre_tm bspec_post_tm val bprog_tm = (fst o dest_eq o concl) bir_prog_def; val prog_vars_list_tm = (fst o dest_eq o concl) prog_vars_list_def; val birenvtyl_tm = (fst o dest_eq o concl) birenvtyl_def; + val bir_init_lbl_tm = ``BL_Address ^(gen_mk_Imm init_addr_tm)``; + val bir_end_lbl_tm = ``BL_Address ^(gen_mk_Imm end_addr_tm)``; val bir_state_init_lbl_tm = (snd o dest_eq o concl o EVAL) - ``bir_block_pc (BL_Address (Imm64 ^init_addr_tm))``; + ``bir_block_pc (BL_Address ^(gen_mk_Imm init_addr_tm))``; val birs_state_end_lbl_tm = (snd o dest_eq o concl o EVAL) - ``bir_block_pc (BL_Address (Imm64 ^end_addr_tm))``; + ``bir_block_pc (BL_Address ^(gen_mk_Imm end_addr_tm))``; val birs_state_init_pre_tm = ``birs_state_init_pre_GEN ^bir_state_init_lbl_tm ^birenvtyl_tm (mk_bsysprecond ^bspec_pre_tm ^birenvtyl_tm)``; @@ -315,10 +319,10 @@ fun bir_symb_transfer init_addr_tm end_addr_tm bspec_pre_tm bspec_post_tm val abstract_jgmt_rel_thm = prove (``abstract_jgmt_rel (bir_ts ^bprog_tm) - (BL_Address (Imm64 ^init_addr_tm)) {BL_Address (Imm64 ^end_addr_tm)} + (^bir_init_lbl_tm) {^bir_end_lbl_tm} (\st. bir_exec_to_labels_triple_precond st ^bspec_pre_tm ^bprog_tm) (\st st'. bir_exec_to_labels_triple_postcond st' - (\l. if l = BL_Address (Imm64 ^end_addr_tm) + (\l. if l = ^bir_end_lbl_tm then ^bspec_post_tm else bir_exp_false) ^bprog_tm)``, @@ -358,18 +362,18 @@ fun bir_symb_transfer init_addr_tm end_addr_tm bspec_pre_tm bspec_post_tm val bspec_cont_thm = prove (``bir_cont ^bprog_tm bir_exp_true - (BL_Address (Imm64 ^init_addr_tm)) {BL_Address (Imm64 ^end_addr_tm)} {} + (^bir_init_lbl_tm) {^bir_end_lbl_tm} {} ^bspec_pre_tm - (\l. if l = BL_Address (Imm64 ^end_addr_tm) + (\l. if l = ^bir_end_lbl_tm then ^bspec_post_tm else bir_exp_false)``, - `{BL_Address (Imm64 ^end_addr_tm)} <> {}` by fs [] >> + `{^bir_end_lbl_tm} <> {}` by fs [] >> MP_TAC ((Q.SPECL [ - `BL_Address (Imm64 ^init_addr_tm)`, - `{BL_Address (Imm64 ^end_addr_tm)}`, + `^bir_init_lbl_tm`, + `{^bir_end_lbl_tm}`, `^bspec_pre_tm`, - `\l. if l = BL_Address (Imm64 ^end_addr_tm) + `\l. if l = ^bir_end_lbl_tm then ^bspec_post_tm else bir_exp_false` ] o SPEC bprog_tm o INST_TYPE [Type.alpha |-> Type`:'observation_type`]) diff --git a/src/tools/symbexec/birs_auxLib.sml b/src/tools/symbexec/birs_auxLib.sml index 7eb2d5bdf..7530c1f35 100644 --- a/src/tools/symbexec/birs_auxLib.sml +++ b/src/tools/symbexec/birs_auxLib.sml @@ -240,10 +240,14 @@ fun gen_lookup_functions (stmt_thms, label_mem_thms) = fun prepare_program_lookups bir_lift_thm = let + val _ = print "\npreparing program lookups"; + val timer = holba_miscLib.timer_start 0; val prep_structure = gen_exec_prep_thms_from_lift_thm bir_lift_thm; val (stmt_lookup_fun, l_mem_lookup_fun) = gen_lookup_functions prep_structure; val _ = cur_stmt_lookup_fun := stmt_lookup_fun; val _ = cur_l_mem_lookup_fun := l_mem_lookup_fun; + val _ = holba_miscLib.timer_stop + (fn delta_s => print (" - " ^ delta_s ^ "\n")) timer; in () end; From 7e9317fdd0c58cf5ad1fe99f92b26aeb47149db7 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Tue, 24 Sep 2024 10:47:43 +0200 Subject: [PATCH 18/95] Enable run-time switch for smt debug outputs --- src/shared/smt/bir_smtLib.sml | 2 +- src/shared/smt/holba_z3Lib.sml | 20 ++++++++++---------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/shared/smt/bir_smtLib.sml b/src/shared/smt/bir_smtLib.sml index f8fd018fb..d3cfb179d 100644 --- a/src/shared/smt/bir_smtLib.sml +++ b/src/shared/smt/bir_smtLib.sml @@ -180,7 +180,7 @@ fun bir_smt_set_trace use_holsmt = if use_holsmt then (fn x => HolBA_Library.trace := x) (* same as Feedback.set_trace "HolBA_HolSmtLib" *) else - (fn _ => ()); + (fn x => if x > 0 then (holba_z3Lib.debug_print := true) else (holba_z3Lib.debug_print := false)); (* TODO: should not be operating on word expressions in this library, just bir expressions *) fun bir_smt_get_model use_holsmt = diff --git a/src/shared/smt/holba_z3Lib.sml b/src/shared/smt/holba_z3Lib.sml index f63fbe14a..10b534701 100644 --- a/src/shared/smt/holba_z3Lib.sml +++ b/src/shared/smt/holba_z3Lib.sml @@ -35,7 +35,7 @@ val prelude_z3_path = holpathdb.subst_pathvars "$(HOLBADIR)/src/shared/smt/holba val prelude_z3 = read_from_file prelude_z3_path; val prelude_z3_n = prelude_z3 ^ "\n"; val use_stack = true; -val debug_print = false; +val debug_print = ref false; fun get_z3proc z3bin = let val z3proc_ = !z3proc_o; @@ -49,7 +49,7 @@ fun get_z3proc z3bin = end; val p = if isSome z3proc_ then check_and_restart (valOf z3proc_) else let - val _ = if not debug_print then () else + val _ = if not (!debug_print) then () else print ("starting: " ^ z3bin ^ "\n"); val p = openz3 z3bin; val _ = z3proc_bin_o := SOME z3bin; @@ -76,7 +76,7 @@ fun get_z3wrapproc () = val z3wrap = case OS.Process.getEnv "HOL4_Z3_WRAPPED_EXECUTABLE" of SOME x => x | NONE => raise ERR "get_z3wrapproc" "variable HOL4_Z3_WRAPPED_EXECUTABLE not defined"; - val _ = if not debug_print then () else + val _ = if not (!debug_print) then () else print ("starting: " ^ z3wrap ^ "\n"); val p = openz3wrap z3wrap prelude_z3_path; in (z3wrapproc_o := SOME p; p) end; @@ -92,7 +92,7 @@ fun inputLines_until m ins acc = val _ = if isSome line_o then () else raise ERR "inputLines_until" "stream ended before reaching the marker"; val line = valOf line_o; - val _ = if not debug_print then () else + val _ = if not (!debug_print) then () else (print "collecting: "; print line); in if line = m then @@ -103,7 +103,7 @@ fun inputLines_until m ins acc = fun sendreceive_query z3bin q = let - val _ = if not debug_print then () else + val _ = if not (!debug_print) then () else (print q; print "\n"); val p = get_z3proc z3bin; val (s_in,s_out) = get_streams p; @@ -115,10 +115,10 @@ fun sendreceive_query z3bin q = val z3_done_marker = "holba_z3 qdm"; val () = TextIO.output (s_out, q ^ "(echo \"" ^ z3_done_marker ^ "\")\n"); val out_lines = inputLines_until (z3_done_marker ^ "\n") s_in []; - val _ = if debug_print then holba_miscLib.timer_stop + val _ = if !debug_print then holba_miscLib.timer_stop (fn delta_s => print (" query took " ^ delta_s ^ "\n")) timer else (); - val _ = if not debug_print then () else + val _ = if not (!debug_print) then () else (map print out_lines; print "\n\n"); (* https://microsoft.github.io/z3guide/docs/logic/basiccommands/ *) val _ = if not use_stack then @@ -136,17 +136,17 @@ fun sendreceive_wrap_query q = val (s_in,s_out) = get_streams p; val q_fixed = String.concat (List.map (fn c => if c = #"\n" then "\\n" else str c) (String.explode q)); - val _ = if not debug_print then () else + val _ = if not (!debug_print) then () else (print "sending: "; print q_fixed; print "\n"); val timer = holba_miscLib.timer_start 0; val z3wrap_done_marker = "z3_wrapper query done"; val () = TextIO.output (s_out, q_fixed ^ "\n"); val out_lines = inputLines_until (z3wrap_done_marker ^ "\n") s_in []; - val _ = if debug_print then holba_miscLib.timer_stop + val _ = if !debug_print then holba_miscLib.timer_stop (fn delta_s => print (" wrapped query took " ^ delta_s ^ "\n")) timer else (); - val _ = if not debug_print then () else + val _ = if not (!debug_print) then () else (map print out_lines; print "\n\n"); in out_lines From 0f464ed1b9a5cbcee937d9529360f39710cfc2fa Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Tue, 24 Sep 2024 18:23:58 +0200 Subject: [PATCH 19/95] Improve speed of property transfer for larger variable sets and states Add outputs to track progress per leaf (and when generating and discharging strong postcondition implications with smt solver) --- src/tools/symbexec/bir_symbLib.sml | 15 ++++++++-- .../symbexec/distribute_generic_stuffLib.sml | 29 +++++++++++++------ 2 files changed, 33 insertions(+), 11 deletions(-) diff --git a/src/tools/symbexec/bir_symbLib.sml b/src/tools/symbexec/bir_symbLib.sml index 87cea27bf..0e31ac28a 100644 --- a/src/tools/symbexec/bir_symbLib.sml +++ b/src/tools/symbexec/bir_symbLib.sml @@ -265,10 +265,21 @@ fun bir_symb_transfer init_addr_tm end_addr_tm bspec_pre_tm bspec_post_tm bir_eval_exp ^bspec_post_tm bs'.bst_environ = SOME bir_val_true``) sys2s; + val _ = print "\nproving strong postcondition implications for each symbolic execution leaf with the smt solver"; val strongpostcond_thms = List.map (fn goal => prove(``^goal``, birs_strongpostcond_impl_TAC)) strongpostcond_goals; + val _ = print " - done\n"; + val Pi_thms_idx = ref 0; val Pi_thms = List.map (fn sys2 => + let + val idx = (!Pi_thms_idx); + (* + val sys2 = List.nth(sys2s, idx); + *) + val _ = print ("proving leaf #" ^ (Int.toString idx) ^ "\n"); + val _ = Pi_thms_idx := idx + 1; + in prove(`` sys1 = ^sys1 ==> sys2 = ^sys2 ==> @@ -280,11 +291,11 @@ fun bir_symb_transfer init_addr_tm end_addr_tm bspec_pre_tm bspec_post_tm (birs_symb_to_concst bs) (birs_symb_to_concst bs')``, REPEAT STRIP_TAC >> - Q_bircont_SOLVE3CONJS_TAC prog_vars_thm >> + Q_bircont_SOLVE3CONJS_TAC prog_vars_thm >> (* val varset_thm = prog_vars_thm; *) `birs_symb_matchstate sys1 H' bs` by METIS_TAC [bir_symb_soundTheory.birs_symb_matchstate_interpr_ext_IMP_matchstate_thm] >> FULL_SIMP_TAC std_ss [P_bircont_thm] >> - METIS_TAC strongpostcond_thms)) + METIS_TAC strongpostcond_thms) end) sys2s; val bprog_Pi_overapprox_Q_thm = diff --git a/src/tools/symbexec/distribute_generic_stuffLib.sml b/src/tools/symbexec/distribute_generic_stuffLib.sml index 670c26c30..cabe6251a 100644 --- a/src/tools/symbexec/distribute_generic_stuffLib.sml +++ b/src/tools/symbexec/distribute_generic_stuffLib.sml @@ -18,7 +18,6 @@ local in - (* TODO: MOVE AWAY !!!!! GENERIC DEFINITIONS AND THEOREMS *) (* val varset_thm = incr_prog_vars_thm; @@ -49,18 +48,30 @@ fun Q_bircont_SOLVE3CONJS_TAC varset_thm = ( REPEAT (POP_ASSUM (K ALL_TAC)) >> (* concretize and normalize *) - FULL_SIMP_TAC (std_ss++birs_state_ss) [birs_symb_symbols_thm, birs_auxTheory.birs_exps_of_senv_thm] >> + (* --- first the variable set *) + REWRITE_TAC [GSYM varset_thm] >> + CONV_TAC (RAND_CONV (EVAL)) >> + (* --- then the symbolic environment *) FULL_SIMP_TAC (std_ss++holBACore_ss++listSimps.LIST_ss) [birs_gen_env_def, birs_gen_env_fun_def, birs_gen_env_fun_def, bir_envTheory.bir_env_lookup_def] >> - FULL_SIMP_TAC (std_ss++holBACore_ss++listSimps.LIST_ss) [birs_auxTheory.birs_exps_of_senv_COMP_thm] >> + (* --- then the symbol set *) + FULL_SIMP_TAC (std_ss++birs_state_ss) [birs_symb_symbols_thm, birs_auxTheory.birs_exps_of_senv_thm] >> + REPEAT (CHANGED_TAC (fn x => ( + FULL_SIMP_TAC (std_ss++holBACore_ss++listSimps.LIST_ss++pred_setLib.PRED_SET_ss++stringSimps.STRING_ss) [Once birs_auxTheory.birs_exps_of_senv_COMP_thm] + ) x)) >> CONV_TAC (RATOR_CONV (RAND_CONV (computeLib.RESTR_EVAL_CONV [``bir_vars_of_exp``] THENC SIMP_CONV (std_ss++holBACore_ss) [] THENC EVAL))) >> - (* TODO: improve this *) - CONV_TAC (RAND_CONV (computeLib.RESTR_EVAL_CONV [``bir_vars_of_program``] THENC SIMP_CONV (std_ss++HolBASimps.VARS_OF_PROG_ss++pred_setLib.PRED_SET_ss) [] THENC EVAL)) >> (* finish the proof *) - REWRITE_TAC [birs_env_vars_are_initialised_INSERT_thm, birs_env_vars_are_initialised_EMPTY_thm, birs_env_var_is_initialised_def] >> - EVAL_TAC >> - SIMP_TAC (std_ss++holBACore_ss) [] >> - EVAL_TAC + REPEAT (CHANGED_TAC (fn x => ( + REWRITE_TAC [Once birs_env_vars_are_initialised_INSERT_thm, birs_env_vars_are_initialised_EMPTY_thm, birs_env_var_is_initialised_def] >> + let + val fix_tac = + EVAL_TAC >> + SIMP_TAC (std_ss++holBACore_ss) [bir_valuesTheory.BType_Bool_def] >> + EVAL_TAC; + in + (CONJ_TAC >- fix_tac) ORELSE (fix_tac) + end + ) x)) ) ); From b24cd162a871108e20b62f323fb3bee13d2629a6 Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Thu, 26 Sep 2024 19:29:31 +0200 Subject: [PATCH 20/95] bir_symb_transfer_two function in bir_symbLib, applied to isqrt --- .../riscv/isqrt/isqrt_symb_transfScript.sml | 360 +----------------- src/tools/symbexec/bir_symbLib.sig | 18 +- src/tools/symbexec/bir_symbLib.sml | 345 ++++++++++++++++- 3 files changed, 365 insertions(+), 358 deletions(-) diff --git a/examples/riscv/isqrt/isqrt_symb_transfScript.sml b/examples/riscv/isqrt/isqrt_symb_transfScript.sml index 5ee6027d3..d896e878b 100644 --- a/examples/riscv/isqrt/isqrt_symb_transfScript.sml +++ b/examples/riscv/isqrt/isqrt_symb_transfScript.sml @@ -76,358 +76,12 @@ val bspec_pre_tm = (lhs o snd o strip_forall o concl) bspec_isqrt_pre_3_def; val bspec_post_1_tm = (lhs o snd o strip_forall o concl) bspec_isqrt_post_3_loop_def; val bspec_post_2_tm = (lhs o snd o strip_forall o concl) bspec_isqrt_post_3_ret_def; -val bir_prog_def = bir_isqrt_prog_def; -val birenvtyl_def = isqrt_birenvtyl_def; -val bspec_pre_def = bspec_isqrt_pre_3_def; -val bspec_post_1_def = bspec_isqrt_post_3_loop_def; -val bspec_post_2_def = bspec_isqrt_post_3_ret_def; -val prog_vars_list_def = isqrt_prog_vars_list_def; -val symb_analysis_thm = isqrt_symb_analysis_3_thm; -val bsysprecond_thm = isqrt_bsysprecond_3_thm; -val prog_vars_thm = isqrt_prog_vars_thm; - -(* ---- *) - -open birsSyntax; -open birs_stepLib; -open birs_composeLib; -open birs_driveLib; -open birs_auxTheory; - -open HolBACoreSimps; -open bir_typing_expTheory; - -open pred_setTheory; -open distribute_generic_stuffTheory; -open distribute_generic_stuffLib; - -open bir_symb_sound_coreTheory; -open bir_typing_expTheory; -open bir_env_oldTheory; -open bir_envTheory; - -open jgmt_rel_bir_contTheory; - -val birs_state_ss = rewrites (type_rws ``:birs_state_t``); - -val bprog_tm = (fst o dest_eq o concl) bir_prog_def; -val prog_vars_list_tm = (fst o dest_eq o concl) prog_vars_list_def; -val birenvtyl_tm = (fst o dest_eq o concl) birenvtyl_def; -val bir_state_init_lbl_tm = (snd o dest_eq o concl o EVAL) - ``bir_block_pc (BL_Address (Imm64 ^init_addr_tm))``; - -val birs_state_end_lbl_1_tm = (snd o dest_eq o concl o EVAL) - ``bir_block_pc (BL_Address (Imm64 ^end_addr_1_tm))``; -val birs_state_end_lbl_2_tm = (snd o dest_eq o concl o EVAL) - ``bir_block_pc (BL_Address (Imm64 ^end_addr_2_tm))``; - -val birs_state_init_pre_tm = -``birs_state_init_pre_GEN ^bir_state_init_lbl_tm ^birenvtyl_tm - (mk_bsysprecond ^bspec_pre_tm ^birenvtyl_tm)``; - -val (sys_i, L_s, Pi_f) = (symb_sound_struct_get_sysLPi_fun o concl) symb_analysis_thm; - -Theorem analysis_L_INTER_EMPTY[local]: - {^birs_state_end_lbl_1_tm; ^birs_state_end_lbl_2_tm} INTER ^L_s = {} -Proof - EVAL_TAC -QED - -Theorem analysis_L_NOTIN_thm_1[local]: - ^birs_state_end_lbl_1_tm NOTIN ^L_s -Proof - EVAL_TAC -QED - -Theorem analysis_L_NOTIN_thm_2[local]: - ^birs_state_end_lbl_2_tm NOTIN ^L_s -Proof - EVAL_TAC -QED - -val birs_state_init_pre_EQ_thm = - prove (``^((snd o dest_comb) sys_i) = ^birs_state_init_pre_tm``, - REWRITE_TAC [birs_state_init_pre_GEN_def, mk_bsysprecond_def, bsysprecond_thm] >> - CONV_TAC (computeLib.RESTR_EVAL_CONV [``birs_eval_exp``] THENC birs_stepLib.birs_eval_exp_CONV)); - -val analysis_thm = - REWRITE_RULE [birs_state_init_pre_EQ_thm, GSYM bir_prog_def] symb_analysis_thm; - -val birenvtyl_EVAL_thm = - (REWRITE_CONV [ - birenvtyl_def, - bir_lifting_machinesTheory.riscv_bmr_vars_EVAL, - bir_lifting_machinesTheory.riscv_bmr_temp_vars_EVAL] THENC EVAL) - birenvtyl_tm; - -val birs_state_thm = REWRITE_CONV [birenvtyl_EVAL_thm] birs_state_init_pre_tm; - -val birs_symb_symbols_f_sound_prog_thm = - (SPEC (inst [Type`:'observation_type` |-> Type.alpha] bprog_tm) - bir_symb_soundTheory.birs_symb_symbols_f_sound_thm); - -val birs_prop_transfer_thm = - (MATCH_MP symb_prop_transferTheory.symb_prop_transfer_thm - birs_symb_symbols_f_sound_prog_thm); - -val type_of_bir_exp_thms = - let - open bir_immTheory - open bir_valuesTheory - open bir_envTheory - open bir_exp_memTheory - open bir_bool_expTheory - open bir_extra_expsTheory - open bir_nzcv_expTheory - open bir_interval_expTheory - in [ - type_of_bir_exp_def, - bir_var_type_def, - bir_type_is_Imm_def, - type_of_bir_imm_def, - BExp_Aligned_type_of, - BExp_unchanged_mem_interval_distinct_type_of, - bir_number_of_mem_splits_REWRS, - BType_Bool_def, - bir_exp_true_def, - bir_exp_false_def, - BExp_MSB_type_of, - BExp_nzcv_ADD_DEFS, - BExp_nzcv_SUB_DEFS, - n2bs_def, - BExp_word_bit_def, - BExp_Align_type_of, - BExp_ror_type_of, - BExp_LSB_type_of, - BExp_word_bit_exp_type_of, - BExp_ADD_WITH_CARRY_type_of, - BExp_word_reverse_type_of, - BExp_ror_exp_type_of - ] end; - -val bprog_P_entails_thm = - prove (``P_entails_an_interpret - (bir_symb_rec_sbir ^bprog_tm) - (P_bircont ^birenvtyl_tm ^bspec_pre_tm) - (birs_symb_to_symbst ^birs_state_init_pre_tm)``, - - ASSUME_TAC (GSYM prog_vars_thm) >> - `^prog_vars_list_tm = MAP PairToBVar ^birenvtyl_tm` by ( - SIMP_TAC std_ss [birenvtyl_def, listTheory.MAP_MAP_o, - PairToBVar_BVarToPair_I_thm, listTheory.MAP_ID]) >> - POP_ASSUM (fn thm => FULL_SIMP_TAC std_ss [thm]) >> - IMP_RES_TAC (SIMP_RULE std_ss [] P_bircont_entails_thm) >> - SIMP_TAC std_ss [] >> - POP_ASSUM (ASSUME_TAC o SPEC bspec_pre_tm) >> - `bir_vars_of_exp ^bspec_pre_tm SUBSET set (MAP PairToBVar ^birenvtyl_tm)` by EVAL_TAC >> - POP_ASSUM (fn thm => FULL_SIMP_TAC std_ss [thm]) >> - `ALL_DISTINCT (MAP FST ^birenvtyl_tm)` by EVAL_TAC >> - POP_ASSUM (fn thm => FULL_SIMP_TAC std_ss [thm]) >> - `IS_SOME (type_of_bir_exp ^bspec_pre_tm)` by ( - SIMP_TAC std_ss [bspec_pre_def] >> - CONV_TAC (RAND_CONV (SIMP_CONV (srw_ss()) type_of_bir_exp_thms)) >> - SIMP_TAC (std_ss++holBACore_ss) [optionTheory.option_CLAUSES] - ) >> - POP_ASSUM (fn thm => FULL_SIMP_TAC std_ss [thm])); - -val sys1 = (snd o dest_eq o concl o REWRITE_CONV [bsysprecond_thm]) birs_state_init_pre_tm; - -val (Pi_func, Pi_set) = dest_comb Pi_f; - -val sys2s = pred_setSyntax.strip_set Pi_set; - -(* FIXME *) -val sys2ps = [ - (List.nth (sys2s,0), bspec_post_1_tm, birs_state_end_lbl_1_tm), - (List.nth (sys2s,1), bspec_post_2_tm, birs_state_end_lbl_2_tm) -]; - -val strongpostcond_goals = List.map (fn (sys2,post_tm,_) => `` - sys1 = ^sys1 ==> - sys2 = ^sys2 ==> - birs_symb_matchstate sys1 H' bs ==> - bir_eval_exp ^bspec_pre_tm bs.bst_environ = SOME bir_val_true ==> - birs_symb_matchstate sys2 H' bs' ==> - bir_eval_exp ^post_tm bs'.bst_environ = SOME bir_val_true``) -sys2ps; - -val strongpostcond_thms = List.map (fn goal => - prove(``^goal``, birs_strongpostcond_impl_TAC)) strongpostcond_goals; - -val Pi_thms = List.map (fn (sys2,post_tm,birs_state_end_lbl_tm) => - prove(`` - sys1 = ^sys1 ==> - sys2 = ^sys2 ==> - birs_symb_matchstate sys1 H bs ==> - P_bircont ^birenvtyl_tm ^bspec_pre_tm (birs_symb_to_concst bs) ==> - symb_interpr_ext H' H ==> - birs_symb_matchstate sys2 H' bs' ==> - Q_bircont ^birs_state_end_lbl_tm (set ^prog_vars_list_tm) ^post_tm - (birs_symb_to_concst bs) (birs_symb_to_concst bs')``, - - REPEAT STRIP_TAC >> - - FULL_SIMP_TAC (std_ss) [Q_bircont_thm] >> - CONJ_TAC >- ( - REV_FULL_SIMP_TAC (std_ss++birs_state_ss) [birs_symb_matchstate_def] - ) >> - - CONJ_TAC >- ( - REV_FULL_SIMP_TAC (std_ss++birs_state_ss) [birs_symb_matchstate_def] - ) >> - - CONJ_TAC >- ( - PAT_X_ASSUM ``A = B`` (fn thm => FULL_SIMP_TAC std_ss [thm]) >> - PAT_X_ASSUM ``A = B`` (K ALL_TAC) >> - FULL_SIMP_TAC (std_ss++birs_state_ss) [birs_symb_matchstate_def, prog_vars_thm] >> - - IMP_RES_TAC birs_env_vars_are_initialised_IMP_thm >> - POP_ASSUM (K ALL_TAC) >> - PAT_X_ASSUM ``!x. A`` (ASSUME_TAC o SPEC ((snd o dest_eq o concl) prog_vars_thm)) >> - POP_ASSUM (MATCH_MP_TAC) >> - - REPEAT (POP_ASSUM (K ALL_TAC)) >> - - FULL_SIMP_TAC (std_ss++birs_state_ss) [birs_symb_symbols_thm, birs_auxTheory.birs_exps_of_senv_thm] >> - FULL_SIMP_TAC (std_ss++holBACore_ss++listSimps.LIST_ss) [birs_gen_env_def, birs_gen_env_fun_def, birs_gen_env_fun_def, bir_envTheory.bir_env_lookup_def] >> - - FULL_SIMP_TAC (std_ss++holBACore_ss++listSimps.LIST_ss) [birs_auxTheory.birs_exps_of_senv_COMP_thm] >> - CONV_TAC (RATOR_CONV (RAND_CONV (computeLib.RESTR_EVAL_CONV [``bir_vars_of_exp``] THENC SIMP_CONV (std_ss++holBACore_ss) [] THENC EVAL))) >> - CONV_TAC (RAND_CONV (computeLib.RESTR_EVAL_CONV [``bir_vars_of_program``] THENC SIMP_CONV (std_ss++HolBASimps.VARS_OF_PROG_ss++pred_setLib.PRED_SET_ss) [] THENC EVAL)) >> - REWRITE_TAC [birs_env_vars_are_initialised_INSERT_thm, birs_env_vars_are_initialised_EMPTY_thm, birs_env_var_is_initialised_def] >> - - EVAL_TAC >> - SIMP_TAC (std_ss++holBACore_ss++pred_setLib.PRED_SET_ss) [] >> - EVAL_TAC) >> - - `birs_symb_matchstate sys1 H' bs` by - METIS_TAC [bir_symb_soundTheory.birs_symb_matchstate_interpr_ext_IMP_matchstate_thm] >> - FULL_SIMP_TAC std_ss [P_bircont_thm] >> - METIS_TAC strongpostcond_thms)) -sys2ps; - -(* -val label_0 = (snd o dest_eq o concl o EVAL) `` ^(List.nth (sys2s,0)).bsst_pc``; -val label_1 = (snd o dest_eq o concl o EVAL) `` ^(List.nth (sys2s,1)).bsst_pc``; -*) - -(* FIXME *) -val bprog_Q_birconts_tm = - ``\st st'. - Q_bircont ^(#3 (List.nth (sys2ps,0))) (set ^prog_vars_list_tm) - ^(#2 (List.nth (sys2ps,0))) st st' \/ - Q_bircont ^(#3 (List.nth (sys2ps,1))) (set ^prog_vars_list_tm) - ^(#2 (List.nth (sys2ps,1))) st st'``; - -val bprog_Pi_overapprox_Q_thm = - prove (``Pi_overapprox_Q - (bir_symb_rec_sbir ^bprog_tm) - (P_bircont ^birenvtyl_tm ^bspec_pre_tm) - (birs_symb_to_symbst ^birs_state_init_pre_tm) ^Pi_f - ^bprog_Q_birconts_tm``, - - REWRITE_TAC [bir_prop_transferTheory.bir_Pi_overapprox_Q_thm, bsysprecond_thm] >> - REPEAT GEN_TAC >> - REWRITE_TAC [pred_setTheory.IMAGE_INSERT, pred_setTheory.IMAGE_EMPTY, pred_setTheory.IN_INSERT, pred_setTheory.NOT_IN_EMPTY] >> - REPEAT STRIP_TAC >> ( - FULL_SIMP_TAC std_ss [] >> - METIS_TAC Pi_thms)); - -val bprog_prop_holds_thm = - SIMP_RULE (std_ss++birs_state_ss) - [birs_state_init_pre_GEN_def, birs_symb_symbst_pc_thm] ( - MATCH_MP - (MATCH_MP - (MATCH_MP - birs_prop_transfer_thm - bprog_P_entails_thm) - bprog_Pi_overapprox_Q_thm) - analysis_thm); - -val bir_abstract_jgmt_rel_thm = - (MATCH_MP - (MATCH_MP - (MATCH_MP prop_holds_TO_abstract_jgmt_rel_two_thm analysis_L_NOTIN_thm_1) analysis_L_NOTIN_thm_2) - (REWRITE_RULE [] bprog_prop_holds_thm)); - -val abstract_jgmt_rel_thm = - prove (``abstract_jgmt_rel (bir_ts ^bprog_tm) - (BL_Address (Imm64 ^init_addr_tm)) - {BL_Address (Imm64 ^end_addr_1_tm); BL_Address (Imm64 ^end_addr_2_tm);} - (\st. bir_exec_to_labels_triple_precond st ^bspec_pre_tm ^bprog_tm) - (\st st'. bir_exec_to_labels_triple_postcond st' - (\l. if l = BL_Address (Imm64 ^end_addr_1_tm) then ^bspec_post_1_tm - else if l = BL_Address (Imm64 ^end_addr_2_tm) then ^bspec_post_2_tm - else bir_exp_false) ^bprog_tm)``, - - MATCH_MP_TAC (REWRITE_RULE - [boolTheory.AND_IMP_INTRO] abstract_jgmt_rel_bir_exec_to_two_labels_triple_thm) >> - SIMP_TAC std_ss [] >> - EXISTS_TAC birenvtyl_tm >> - CONJ_TAC >- rw [] >> - CONJ_TAC >- ( - (* bpre subset *) - REWRITE_TAC [bspec_pre_def] >> - SIMP_TAC (std_ss++pred_setLib.PRED_SET_ss) [GSYM prog_vars_thm, prog_vars_list_def] >> - SIMP_TAC (std_ss++pred_setLib.PRED_SET_ss++holBACore_ss) [listTheory.MEM, pred_setTheory.IN_INSERT] >> - EVAL_TAC - ) >> - CONJ_TAC >- ( - (* bpost_1 subset *) - REWRITE_TAC [bspec_post_1_def] >> - SIMP_TAC (std_ss++pred_setLib.PRED_SET_ss) [GSYM prog_vars_thm, prog_vars_list_def] >> - SIMP_TAC (std_ss++pred_setLib.PRED_SET_ss++holBACore_ss) [listTheory.MEM, pred_setTheory.IN_INSERT] - ) >> - CONJ_TAC >- ( - (* bpost_2 subset *) - REWRITE_TAC [bspec_post_2_def] >> - SIMP_TAC (std_ss++pred_setLib.PRED_SET_ss) [GSYM prog_vars_thm, prog_vars_list_def] >> - SIMP_TAC (std_ss++pred_setLib.PRED_SET_ss++holBACore_ss) [listTheory.MEM, pred_setTheory.IN_INSERT] - ) >> - CONJ_TAC >- ( - (* bpost_1 is bool *) - REWRITE_TAC [bspec_post_1_def] >> - SIMP_TAC (std_ss++holBACore_ss) [bir_is_bool_exp_REWRS, type_of_bir_exp_def] - ) >> - CONJ_TAC >- ( - (* bpost_2 is bool *) - REWRITE_TAC [bspec_post_2_def] >> - SIMP_TAC (std_ss++holBACore_ss) [bir_is_bool_exp_REWRS, type_of_bir_exp_def] - ) >> - CONJ_TAC >- ( - (* ALL_DISTINCT envtyl *) - SIMP_TAC (std_ss++listSimps.LIST_ss) [birenvtyl_EVAL_thm] >> - EVAL_TAC - ) >> - CONJ_TAC >- ( - (* envtyl = vars_of_prog *) - REWRITE_TAC [GSYM prog_vars_thm] >> - SIMP_TAC std_ss [birenvtyl_def, listTheory.MAP_MAP_o, PairToBVar_BVarToPair_I_thm, listTheory.MAP_ID] - ) >> - METIS_TAC [bir_abstract_jgmt_rel_thm, prog_vars_thm]); - -val bspec_cont_thm = - prove (``bir_cont ^bprog_tm bir_exp_true - (BL_Address (Imm64 ^init_addr_tm)) {BL_Address (Imm64 ^end_addr_1_tm); BL_Address (Imm64 ^end_addr_2_tm)} {} - ^bspec_pre_tm - (\l. if l = BL_Address (Imm64 ^end_addr_1_tm) then ^bspec_post_1_tm - else if l = BL_Address (Imm64 ^end_addr_2_tm) then ^bspec_post_2_tm - else bir_exp_false)``, - - `{BL_Address (Imm64 ^end_addr_1_tm); BL_Address (Imm64 ^end_addr_2_tm)} <> {}` by fs [] >> - - MP_TAC ((Q.SPECL [ - `BL_Address (Imm64 ^init_addr_tm)`, - `{BL_Address (Imm64 ^end_addr_1_tm); BL_Address (Imm64 ^end_addr_2_tm)}`, - `^bspec_pre_tm`, - `\l. if l = BL_Address (Imm64 ^end_addr_1_tm) then ^bspec_post_1_tm - else if l = BL_Address (Imm64 ^end_addr_2_tm) then ^bspec_post_2_tm - else bir_exp_false` - ] o SPEC bprog_tm o INST_TYPE [Type.alpha |-> Type`:'observation_type`]) - abstract_jgmt_rel_bir_cont) >> - - rw [] >> - METIS_TAC [abstract_jgmt_rel_thm]); +val bspec_cont_3_thm = + bir_symb_transfer_two init_addr_tm end_addr_1_tm end_addr_2_tm + bspec_pre_tm bspec_post_1_tm bspec_post_2_tm + bir_isqrt_prog_def isqrt_birenvtyl_def + bspec_isqrt_pre_3_def bspec_isqrt_post_3_loop_def bspec_isqrt_post_3_ret_def isqrt_prog_vars_list_def + isqrt_symb_analysis_3_thm isqrt_bsysprecond_3_thm isqrt_prog_vars_thm; Theorem bspec_cont_isqrt_3: bir_cont bir_isqrt_prog bir_exp_true @@ -438,7 +92,7 @@ Theorem bspec_cont_isqrt_3: else if l = BL_Address (Imm64 ^end_addr_2_tm) then ^bspec_post_2_tm else bir_exp_false) Proof - rw [bir_isqrt_prog_def,bspec_cont_thm] + rw [bir_isqrt_prog_def,bspec_cont_3_thm] QED val _ = export_theory (); diff --git a/src/tools/symbexec/bir_symbLib.sig b/src/tools/symbexec/bir_symbLib.sig index 12af68f8e..69e612da0 100644 --- a/src/tools/symbexec/bir_symbLib.sig +++ b/src/tools/symbexec/bir_symbLib.sig @@ -7,8 +7,20 @@ sig val bir_symb_analysis_thm : thm -> thm -> thm list -> thm -> thm -> thm * thm; - val bir_symb_transfer : term -> term -> term -> term -> - thm -> thm -> thm -> thm -> thm -> - thm -> thm -> thm -> thm; + val bir_symb_transfer : + term -> term -> + term -> term -> + thm -> thm -> + thm -> thm -> thm -> + thm -> thm -> thm -> + thm; + + val bir_symb_transfer_two : + term -> term -> term -> + term -> term -> term -> + thm -> thm -> + thm -> thm -> thm -> thm -> + thm -> thm -> thm -> + thm; end diff --git a/src/tools/symbexec/bir_symbLib.sml b/src/tools/symbexec/bir_symbLib.sml index 0e31ac28a..bf1349fac 100644 --- a/src/tools/symbexec/bir_symbLib.sml +++ b/src/tools/symbexec/bir_symbLib.sml @@ -145,8 +145,11 @@ local open bir_immSyntax; in -fun bir_symb_transfer init_addr_tm end_addr_tm bspec_pre_tm bspec_post_tm - bir_prog_def birenvtyl_def bspec_pre_def bspec_post_def prog_vars_list_def +fun bir_symb_transfer + init_addr_tm end_addr_tm + bspec_pre_tm bspec_post_tm + bir_prog_def birenvtyl_def + bspec_pre_def bspec_post_def prog_vars_list_def symb_analysis_thm bsysprecond_thm prog_vars_thm = let val birs_state_ss = rewrites (type_rws ``:birs_state_t``); @@ -397,4 +400,342 @@ fun bir_symb_transfer init_addr_tm end_addr_tm bspec_pre_tm bspec_post_tm end (* local *) +local + open HolKernel boolLib Parse bossLib; + open markerTheory; + open distribute_generic_stuffLib; + open bir_programSyntax bir_program_labelsTheory; + open bir_immTheory bir_valuesTheory bir_expTheory; + open bir_tsTheory bir_bool_expTheory bir_programTheory; + open bir_lifting_machinesTheory; + open bir_typing_expTheory; + open bir_htTheory; + open bir_symbTheory birs_auxTheory; + open HolBACoreSimps; + open bir_program_transfTheory; + open total_program_logicTheory; + open total_ext_program_logicTheory; + open symb_prop_transferTheory; + open jgmt_rel_bir_contTheory; + open bir_symbTheory; + open birsSyntax; + open bir_symb_sound_coreTheory; + open symb_recordTheory; + open symb_interpretTheory; + open pred_setTheory; + open program_logicSimps; + open bir_env_oldTheory; + open bir_program_varsTheory; + open distribute_generic_stuffTheory; + open bir_immSyntax; +in + +fun bir_symb_transfer_two + init_addr_tm end_addr_1_tm end_addr_2_tm + bspec_pre_tm bspec_post_1_tm bspec_post_2_tm + bir_prog_def birenvtyl_def + bspec_pre_def bspec_post_1_def bspec_post_2_def prog_vars_list_def + symb_analysis_thm bsysprecond_thm prog_vars_thm = + let + val birs_state_ss = rewrites (type_rws ``:birs_state_t``); + val bprog_tm = (fst o dest_eq o concl) bir_prog_def; + val prog_vars_list_tm = (fst o dest_eq o concl) prog_vars_list_def; + val birenvtyl_tm = (fst o dest_eq o concl) birenvtyl_def; + val bir_state_init_lbl_tm = (snd o dest_eq o concl o EVAL) + ``bir_block_pc (BL_Address (Imm64 ^init_addr_tm))``; + val birs_state_end_lbl_1_tm = (snd o dest_eq o concl o EVAL) + ``bir_block_pc (BL_Address (Imm64 ^end_addr_1_tm))``; + val birs_state_end_lbl_2_tm = (snd o dest_eq o concl o EVAL) + ``bir_block_pc (BL_Address (Imm64 ^end_addr_2_tm))``; + val birs_state_init_pre_tm = + ``birs_state_init_pre_GEN ^bir_state_init_lbl_tm ^birenvtyl_tm + (mk_bsysprecond ^bspec_pre_tm ^birenvtyl_tm)``; + + val (sys_i, L_s, Pi_f) = (symb_sound_struct_get_sysLPi_fun o concl) symb_analysis_thm; + + val analysis_L_NOTIN_thm_1 = prove (``^birs_state_end_lbl_1_tm NOTIN ^L_s``, EVAL_TAC); + val analysis_L_NOTIN_thm_2 = prove (``^birs_state_end_lbl_2_tm NOTIN ^L_s``, EVAL_TAC); + + val birs_state_init_pre_EQ_thm = + prove (``^((snd o dest_comb) sys_i) = ^birs_state_init_pre_tm``, + REWRITE_TAC [birs_state_init_pre_GEN_def, mk_bsysprecond_def, bsysprecond_thm] >> + CONV_TAC (computeLib.RESTR_EVAL_CONV [``birs_eval_exp``] THENC birs_stepLib.birs_eval_exp_CONV)); + + val analysis_thm = + REWRITE_RULE [birs_state_init_pre_EQ_thm, GSYM bir_prog_def] symb_analysis_thm; + + val birenvtyl_EVAL_thm = + (REWRITE_CONV [ + birenvtyl_def, + bir_lifting_machinesTheory.riscv_bmr_vars_EVAL, + bir_lifting_machinesTheory.riscv_bmr_temp_vars_EVAL] THENC EVAL) + birenvtyl_tm; + + val birs_state_thm = + REWRITE_CONV [birenvtyl_EVAL_thm] birs_state_init_pre_tm; + + val birs_symb_symbols_f_sound_prog_thm = + (SPEC (inst [Type`:'observation_type` |-> Type.alpha] bprog_tm) + bir_symb_soundTheory.birs_symb_symbols_f_sound_thm); + + val birs_prop_transfer_thm = + (MATCH_MP symb_prop_transferTheory.symb_prop_transfer_thm + birs_symb_symbols_f_sound_prog_thm); + + val type_of_bir_exp_thms = + let + open bir_immTheory + open bir_valuesTheory + open bir_envTheory + open bir_exp_memTheory + open bir_bool_expTheory + open bir_extra_expsTheory + open bir_nzcv_expTheory + open bir_interval_expTheory + in [ + type_of_bir_exp_def, + bir_var_type_def, + bir_type_is_Imm_def, + type_of_bir_imm_def, + BExp_Aligned_type_of, + BExp_unchanged_mem_interval_distinct_type_of, + bir_number_of_mem_splits_REWRS, + BType_Bool_def, + bir_exp_true_def, + bir_exp_false_def, + BExp_MSB_type_of, + BExp_nzcv_ADD_DEFS, + BExp_nzcv_SUB_DEFS, + n2bs_def, + BExp_word_bit_def, + BExp_Align_type_of, + BExp_ror_type_of, + BExp_LSB_type_of, + BExp_word_bit_exp_type_of, + BExp_ADD_WITH_CARRY_type_of, + BExp_word_reverse_type_of, + BExp_ror_exp_type_of + ] end; + + val bprog_P_entails_thm = + prove (``P_entails_an_interpret + (bir_symb_rec_sbir ^bprog_tm) + (P_bircont ^birenvtyl_tm ^bspec_pre_tm) + (birs_symb_to_symbst ^birs_state_init_pre_tm)``, + + ASSUME_TAC (GSYM prog_vars_thm) >> + `^prog_vars_list_tm = MAP PairToBVar ^birenvtyl_tm` by ( + SIMP_TAC std_ss [birenvtyl_def, listTheory.MAP_MAP_o, + PairToBVar_BVarToPair_I_thm, listTheory.MAP_ID]) >> + POP_ASSUM (fn thm => FULL_SIMP_TAC std_ss [thm]) >> + IMP_RES_TAC (SIMP_RULE std_ss [] P_bircont_entails_thm) >> + SIMP_TAC std_ss [] >> + POP_ASSUM (ASSUME_TAC o SPEC bspec_pre_tm) >> + `bir_vars_of_exp ^bspec_pre_tm SUBSET set (MAP PairToBVar ^birenvtyl_tm)` by EVAL_TAC >> + POP_ASSUM (fn thm => FULL_SIMP_TAC std_ss [thm]) >> + `ALL_DISTINCT (MAP FST ^birenvtyl_tm)` by EVAL_TAC >> + POP_ASSUM (fn thm => FULL_SIMP_TAC std_ss [thm]) >> + `IS_SOME (type_of_bir_exp ^bspec_pre_tm)` by ( + SIMP_TAC std_ss [bspec_pre_def] >> + CONV_TAC (RAND_CONV (SIMP_CONV (srw_ss()) type_of_bir_exp_thms)) >> + SIMP_TAC (std_ss++holBACore_ss) [optionTheory.option_CLAUSES]) >> + POP_ASSUM (fn thm => FULL_SIMP_TAC std_ss [thm])); + + val sys1 = (snd o dest_eq o concl o REWRITE_CONV [bsysprecond_thm]) birs_state_init_pre_tm; + + val (Pi_func, Pi_set) = dest_comb Pi_f; + + val sys2s = pred_setSyntax.strip_set Pi_set; + + val sys2ps = [ + (List.nth (sys2s,0), bspec_post_1_tm, birs_state_end_lbl_1_tm), + (List.nth (sys2s,1), bspec_post_2_tm, birs_state_end_lbl_2_tm) + ]; + + val strongpostcond_goals = List.map (fn (sys2,post_tm,_) => `` + sys1 = ^sys1 ==> + sys2 = ^sys2 ==> + birs_symb_matchstate sys1 H' bs ==> + bir_eval_exp ^bspec_pre_tm bs.bst_environ = SOME bir_val_true ==> + birs_symb_matchstate sys2 H' bs' ==> + bir_eval_exp ^post_tm bs'.bst_environ = SOME bir_val_true``) + sys2ps; + + val strongpostcond_thms = List.map (fn goal => + prove(``^goal``, birs_strongpostcond_impl_TAC)) + strongpostcond_goals; + + val Pi_thms = List.map (fn (sys2,post_tm,birs_state_end_lbl_tm) => + prove(`` + sys1 = ^sys1 ==> + sys2 = ^sys2 ==> + birs_symb_matchstate sys1 H bs ==> + P_bircont ^birenvtyl_tm ^bspec_pre_tm (birs_symb_to_concst bs) ==> + symb_interpr_ext H' H ==> + birs_symb_matchstate sys2 H' bs' ==> + Q_bircont ^birs_state_end_lbl_tm (set ^prog_vars_list_tm) ^post_tm + (birs_symb_to_concst bs) (birs_symb_to_concst bs')``, + + REPEAT STRIP_TAC >> + + FULL_SIMP_TAC (std_ss) [Q_bircont_thm] >> + CONJ_TAC >- ( + REV_FULL_SIMP_TAC (std_ss++birs_state_ss) [birs_symb_matchstate_def] + ) >> + + CONJ_TAC >- ( + REV_FULL_SIMP_TAC (std_ss++birs_state_ss) [birs_symb_matchstate_def] + ) >> + + CONJ_TAC >- ( + PAT_X_ASSUM ``A = B`` (fn thm => FULL_SIMP_TAC std_ss [thm]) >> + PAT_X_ASSUM ``A = B`` (K ALL_TAC) >> + FULL_SIMP_TAC (std_ss++birs_state_ss) [birs_symb_matchstate_def, prog_vars_thm] >> + + IMP_RES_TAC birs_env_vars_are_initialised_IMP_thm >> + POP_ASSUM (K ALL_TAC) >> + PAT_X_ASSUM ``!x. A`` (ASSUME_TAC o SPEC ((snd o dest_eq o concl) prog_vars_thm)) >> + POP_ASSUM (MATCH_MP_TAC) >> + + REPEAT (POP_ASSUM (K ALL_TAC)) >> + + FULL_SIMP_TAC (std_ss++birs_state_ss) [birs_symb_symbols_thm, birs_auxTheory.birs_exps_of_senv_thm] >> + FULL_SIMP_TAC (std_ss++holBACore_ss++listSimps.LIST_ss) [birs_gen_env_def, birs_gen_env_fun_def, birs_gen_env_fun_def, bir_envTheory.bir_env_lookup_def] >> + + FULL_SIMP_TAC (std_ss++holBACore_ss++listSimps.LIST_ss) [birs_auxTheory.birs_exps_of_senv_COMP_thm] >> + CONV_TAC (RATOR_CONV (RAND_CONV (computeLib.RESTR_EVAL_CONV [``bir_vars_of_exp``] THENC SIMP_CONV (std_ss++holBACore_ss) [] THENC EVAL))) >> + CONV_TAC (RAND_CONV (computeLib.RESTR_EVAL_CONV [``bir_vars_of_program``] THENC SIMP_CONV (std_ss++HolBASimps.VARS_OF_PROG_ss++pred_setLib.PRED_SET_ss) [] THENC EVAL)) >> + REWRITE_TAC [birs_env_vars_are_initialised_INSERT_thm, birs_env_vars_are_initialised_EMPTY_thm, birs_env_var_is_initialised_def] >> + + EVAL_TAC >> + SIMP_TAC (std_ss++holBACore_ss++pred_setLib.PRED_SET_ss) [] >> + EVAL_TAC) >> + + `birs_symb_matchstate sys1 H' bs` by + METIS_TAC [bir_symb_soundTheory.birs_symb_matchstate_interpr_ext_IMP_matchstate_thm] >> + FULL_SIMP_TAC std_ss [P_bircont_thm] >> + METIS_TAC strongpostcond_thms)) + sys2ps; + + val bprog_Q_birconts_tm = + ``\st st'. + Q_bircont ^(#3 (List.nth (sys2ps,0))) (set ^prog_vars_list_tm) + ^(#2 (List.nth (sys2ps,0))) st st' \/ + Q_bircont ^(#3 (List.nth (sys2ps,1))) (set ^prog_vars_list_tm) + ^(#2 (List.nth (sys2ps,1))) st st'``; + + val bprog_Pi_overapprox_Q_thm = + prove (``Pi_overapprox_Q + (bir_symb_rec_sbir ^bprog_tm) + (P_bircont ^birenvtyl_tm ^bspec_pre_tm) + (birs_symb_to_symbst ^birs_state_init_pre_tm) ^Pi_f + ^bprog_Q_birconts_tm``, + + REWRITE_TAC [bir_prop_transferTheory.bir_Pi_overapprox_Q_thm, bsysprecond_thm] >> + REPEAT GEN_TAC >> + REWRITE_TAC [pred_setTheory.IMAGE_INSERT, pred_setTheory.IMAGE_EMPTY, pred_setTheory.IN_INSERT, pred_setTheory.NOT_IN_EMPTY] >> + REPEAT STRIP_TAC >> ( + FULL_SIMP_TAC std_ss [] >> + METIS_TAC Pi_thms)); + + val bprog_prop_holds_thm = + SIMP_RULE (std_ss++birs_state_ss) + [birs_state_init_pre_GEN_def, birs_symb_symbst_pc_thm] ( + MATCH_MP + (MATCH_MP + (MATCH_MP + birs_prop_transfer_thm + bprog_P_entails_thm) + bprog_Pi_overapprox_Q_thm) + analysis_thm); + + val bir_abstract_jgmt_rel_thm = + (MATCH_MP + (MATCH_MP + (MATCH_MP prop_holds_TO_abstract_jgmt_rel_two_thm analysis_L_NOTIN_thm_1) analysis_L_NOTIN_thm_2) + (REWRITE_RULE [] bprog_prop_holds_thm)); + + val abstract_jgmt_rel_thm = + prove (``abstract_jgmt_rel (bir_ts ^bprog_tm) + (BL_Address (Imm64 ^init_addr_tm)) + {BL_Address (Imm64 ^end_addr_1_tm); BL_Address (Imm64 ^end_addr_2_tm);} + (\st. bir_exec_to_labels_triple_precond st ^bspec_pre_tm ^bprog_tm) + (\st st'. bir_exec_to_labels_triple_postcond st' + (\l. if l = BL_Address (Imm64 ^end_addr_1_tm) then ^bspec_post_1_tm + else if l = BL_Address (Imm64 ^end_addr_2_tm) then ^bspec_post_2_tm + else bir_exp_false) ^bprog_tm)``, + + MATCH_MP_TAC (REWRITE_RULE + [boolTheory.AND_IMP_INTRO] abstract_jgmt_rel_bir_exec_to_two_labels_triple_thm) >> + SIMP_TAC std_ss [] >> + EXISTS_TAC birenvtyl_tm >> + CONJ_TAC >- rw [] >> + CONJ_TAC >- ( + (* bpre subset *) + REWRITE_TAC [bspec_pre_def] >> + SIMP_TAC (std_ss++pred_setLib.PRED_SET_ss) [GSYM prog_vars_thm, prog_vars_list_def] >> + SIMP_TAC (std_ss++pred_setLib.PRED_SET_ss++holBACore_ss) [listTheory.MEM, pred_setTheory.IN_INSERT] >> + EVAL_TAC + ) >> + CONJ_TAC >- ( + (* bpost_1 subset *) + REWRITE_TAC [bspec_post_1_def] >> + SIMP_TAC (std_ss++pred_setLib.PRED_SET_ss) [GSYM prog_vars_thm, prog_vars_list_def] >> + SIMP_TAC (std_ss++pred_setLib.PRED_SET_ss++holBACore_ss) [listTheory.MEM, pred_setTheory.IN_INSERT] + ) >> + CONJ_TAC >- ( + (* bpost_2 subset *) + REWRITE_TAC [bspec_post_2_def] >> + SIMP_TAC (std_ss++pred_setLib.PRED_SET_ss) [GSYM prog_vars_thm, prog_vars_list_def] >> + SIMP_TAC (std_ss++pred_setLib.PRED_SET_ss++holBACore_ss) [listTheory.MEM, pred_setTheory.IN_INSERT] + ) >> + CONJ_TAC >- ( + (* bpost_1 is bool *) + REWRITE_TAC [bspec_post_1_def] >> + SIMP_TAC (std_ss++holBACore_ss) [bir_is_bool_exp_REWRS, type_of_bir_exp_def] + ) >> + CONJ_TAC >- ( + (* bpost_2 is bool *) + REWRITE_TAC [bspec_post_2_def] >> + SIMP_TAC (std_ss++holBACore_ss) [bir_is_bool_exp_REWRS, type_of_bir_exp_def] + ) >> + CONJ_TAC >- ( + (* ALL_DISTINCT envtyl *) + SIMP_TAC (std_ss++listSimps.LIST_ss) [birenvtyl_EVAL_thm] >> + EVAL_TAC + ) >> + CONJ_TAC >- ( + (* envtyl = vars_of_prog *) + REWRITE_TAC [GSYM prog_vars_thm] >> + SIMP_TAC std_ss [birenvtyl_def, listTheory.MAP_MAP_o, PairToBVar_BVarToPair_I_thm, listTheory.MAP_ID] + ) >> + METIS_TAC [bir_abstract_jgmt_rel_thm, prog_vars_thm]); + + val bspec_cont_thm = + prove (``bir_cont ^bprog_tm bir_exp_true + (BL_Address (Imm64 ^init_addr_tm)) {BL_Address (Imm64 ^end_addr_1_tm); BL_Address (Imm64 ^end_addr_2_tm)} {} + ^bspec_pre_tm + (\l. if l = BL_Address (Imm64 ^end_addr_1_tm) then ^bspec_post_1_tm + else if l = BL_Address (Imm64 ^end_addr_2_tm) then ^bspec_post_2_tm + else bir_exp_false)``, + + `{BL_Address (Imm64 ^end_addr_1_tm); BL_Address (Imm64 ^end_addr_2_tm)} <> {}` by fs [] >> + MP_TAC ((Q.SPECL [ + `BL_Address (Imm64 ^init_addr_tm)`, + `{BL_Address (Imm64 ^end_addr_1_tm); BL_Address (Imm64 ^end_addr_2_tm)}`, + `^bspec_pre_tm`, + `\l. if l = BL_Address (Imm64 ^end_addr_1_tm) then ^bspec_post_1_tm + else if l = BL_Address (Imm64 ^end_addr_2_tm) then ^bspec_post_2_tm + else bir_exp_false` + ] o SPEC bprog_tm o INST_TYPE [Type.alpha |-> Type`:'observation_type`]) + abstract_jgmt_rel_bir_cont) >> + rw [] >> + METIS_TAC [abstract_jgmt_rel_thm]); + + in + bspec_cont_thm + end (* let *) + +end (* local *) + end (* structure *) From 07947a30b27a3b965276486e189452831721f827 Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Thu, 26 Sep 2024 22:17:41 +0200 Subject: [PATCH 21/95] more convenient bir_symb_transfer functions that only take thms --- .../riscv/isqrt/isqrt_symb_transfScript.sml | 50 +++++++++---------- src/tools/symbexec/bir_symbLib.sig | 15 ++++++ src/tools/symbexec/bir_symbLib.sml | 44 +++++++++++++++- 3 files changed, 83 insertions(+), 26 deletions(-) diff --git a/examples/riscv/isqrt/isqrt_symb_transfScript.sml b/examples/riscv/isqrt/isqrt_symb_transfScript.sml index d896e878b..902e5eb56 100644 --- a/examples/riscv/isqrt/isqrt_symb_transfScript.sml +++ b/examples/riscv/isqrt/isqrt_symb_transfScript.sml @@ -18,18 +18,18 @@ val _ = new_theory "isqrt_symb_transf"; (* before loop contract *) +val bspec_cont_1_thm = + bir_symb_transfer_thm + bir_isqrt_prog_def isqrt_init_addr_1_def isqrt_end_addr_1_def + bspec_isqrt_pre_1_def bspec_isqrt_post_1_def + isqrt_birenvtyl_def isqrt_prog_vars_list_def + isqrt_symb_analysis_1_thm isqrt_bsysprecond_1_thm isqrt_prog_vars_thm; + val init_addr_1_tm = (snd o dest_eq o concl) isqrt_init_addr_1_def; val end_addr_1_tm = (snd o dest_eq o concl) isqrt_end_addr_1_def; - val bspec_pre_1_tm = (lhs o snd o strip_forall o concl) bspec_isqrt_pre_1_def; val bspec_post_1_tm = (lhs o snd o strip_forall o concl) bspec_isqrt_post_1_def; -val bspec_cont_1_thm = - bir_symb_transfer init_addr_1_tm end_addr_1_tm bspec_pre_1_tm bspec_post_1_tm - bir_isqrt_prog_def isqrt_birenvtyl_def - bspec_isqrt_pre_1_def bspec_isqrt_post_1_def isqrt_prog_vars_list_def - isqrt_symb_analysis_1_thm isqrt_bsysprecond_1_thm isqrt_prog_vars_thm; - Theorem bspec_cont_isqrt_1: bir_cont bir_isqrt_prog bir_exp_true (BL_Address (Imm64 ^init_addr_1_tm)) {BL_Address (Imm64 ^end_addr_1_tm)} {} @@ -38,23 +38,23 @@ Theorem bspec_cont_isqrt_1: then ^bspec_post_1_tm else bir_exp_false) Proof - rw [bir_isqrt_prog_def,bspec_cont_1_thm] + rw [bspec_cont_1_thm] QED (* loop body contract *) +val bspec_cont_2_thm = + bir_symb_transfer_thm + bir_isqrt_prog_def isqrt_init_addr_2_def isqrt_end_addr_2_def + bspec_isqrt_pre_2_def bspec_isqrt_post_2_def + isqrt_birenvtyl_def isqrt_prog_vars_list_def + isqrt_symb_analysis_2_thm isqrt_bsysprecond_2_thm isqrt_prog_vars_thm; + val init_addr_2_tm = (snd o dest_eq o concl) isqrt_init_addr_2_def; val end_addr_2_tm = (snd o dest_eq o concl) isqrt_end_addr_2_def; - val bspec_pre_2_tm = (lhs o snd o strip_forall o concl) bspec_isqrt_pre_2_def; val bspec_post_2_tm = (lhs o snd o strip_forall o concl) bspec_isqrt_post_2_def; -val bspec_cont_2_thm = - bir_symb_transfer init_addr_2_tm end_addr_2_tm bspec_pre_2_tm bspec_post_2_tm - bir_isqrt_prog_def isqrt_birenvtyl_def - bspec_isqrt_pre_2_def bspec_isqrt_post_2_def isqrt_prog_vars_list_def - isqrt_symb_analysis_2_thm isqrt_bsysprecond_2_thm isqrt_prog_vars_thm; - Theorem bspec_cont_isqrt_2: bir_cont bir_isqrt_prog bir_exp_true (BL_Address (Imm64 ^init_addr_2_tm)) {BL_Address (Imm64 ^end_addr_2_tm)} {} @@ -63,26 +63,26 @@ Theorem bspec_cont_isqrt_2: then ^bspec_post_2_tm else bir_exp_false) Proof - rw [bir_isqrt_prog_def,bspec_cont_2_thm] + rw [bspec_cont_2_thm] QED (* branch contract *) +val bspec_cont_3_thm = + bir_symb_transfer_two_thm + bir_isqrt_prog_def + isqrt_init_addr_3_def isqrt_end_addr_3_loop_def isqrt_end_addr_3_ret_def + bspec_isqrt_pre_3_def bspec_isqrt_post_3_loop_def bspec_isqrt_post_3_ret_def + isqrt_birenvtyl_def isqrt_prog_vars_list_def + isqrt_symb_analysis_3_thm isqrt_bsysprecond_3_thm isqrt_prog_vars_thm; + val init_addr_tm = (snd o dest_eq o concl) isqrt_init_addr_3_def; val end_addr_1_tm = (snd o dest_eq o concl) isqrt_end_addr_3_loop_def; val end_addr_2_tm = (snd o dest_eq o concl) isqrt_end_addr_3_ret_def; - val bspec_pre_tm = (lhs o snd o strip_forall o concl) bspec_isqrt_pre_3_def; val bspec_post_1_tm = (lhs o snd o strip_forall o concl) bspec_isqrt_post_3_loop_def; val bspec_post_2_tm = (lhs o snd o strip_forall o concl) bspec_isqrt_post_3_ret_def; -val bspec_cont_3_thm = - bir_symb_transfer_two init_addr_tm end_addr_1_tm end_addr_2_tm - bspec_pre_tm bspec_post_1_tm bspec_post_2_tm - bir_isqrt_prog_def isqrt_birenvtyl_def - bspec_isqrt_pre_3_def bspec_isqrt_post_3_loop_def bspec_isqrt_post_3_ret_def isqrt_prog_vars_list_def - isqrt_symb_analysis_3_thm isqrt_bsysprecond_3_thm isqrt_prog_vars_thm; - Theorem bspec_cont_isqrt_3: bir_cont bir_isqrt_prog bir_exp_true (BL_Address (Imm64 ^init_addr_tm)) @@ -92,7 +92,7 @@ Theorem bspec_cont_isqrt_3: else if l = BL_Address (Imm64 ^end_addr_2_tm) then ^bspec_post_2_tm else bir_exp_false) Proof - rw [bir_isqrt_prog_def,bspec_cont_3_thm] + rw [bspec_cont_3_thm] QED val _ = export_theory (); diff --git a/src/tools/symbexec/bir_symbLib.sig b/src/tools/symbexec/bir_symbLib.sig index 69e612da0..807739c71 100644 --- a/src/tools/symbexec/bir_symbLib.sig +++ b/src/tools/symbexec/bir_symbLib.sig @@ -15,6 +15,13 @@ sig thm -> thm -> thm -> thm; + val bir_symb_transfer_thm : + thm -> thm -> thm -> + thm -> thm -> + thm -> thm -> + thm -> thm -> thm -> + thm; + val bir_symb_transfer_two : term -> term -> term -> term -> term -> term -> @@ -23,4 +30,12 @@ sig thm -> thm -> thm -> thm; + val bir_symb_transfer_two_thm : + thm -> + thm -> thm -> thm -> + thm -> thm -> thm -> + thm -> thm -> + thm -> thm -> thm -> + thm; + end diff --git a/src/tools/symbexec/bir_symbLib.sml b/src/tools/symbexec/bir_symbLib.sml index bf1349fac..228d38246 100644 --- a/src/tools/symbexec/bir_symbLib.sml +++ b/src/tools/symbexec/bir_symbLib.sml @@ -79,7 +79,8 @@ Profile.output_profile_results (iostream) (Profile.results ()) end (* let *) fun bir_symb_analysis_thm bir_prog_def - init_addr_def end_addr_defs bspec_pre_def birenvtyl_def = + init_addr_def end_addr_defs + bspec_pre_def birenvtyl_def = let val _ = print "\n======\n > bir_symb_analysis_thm started\n"; val timer = holba_miscLib.timer_start 0; @@ -398,6 +399,25 @@ fun bir_symb_transfer bspec_cont_thm end (* let *) +fun bir_symb_transfer_thm + bir_prog_def init_addr_def end_addr_def + bspec_pre_def bspec_post_def + birenvtyl_def prog_vars_list_def + symb_analysis_thm bsysprecond_thm prog_vars_thm = + let + val init_addr_tm = (snd o dest_eq o concl) init_addr_def; + val end_addr_tm = (snd o dest_eq o concl) end_addr_def; + val bspec_pre_tm = (lhs o snd o strip_forall o concl) bspec_pre_def; + val bspec_post_tm = (lhs o snd o strip_forall o concl) bspec_post_def; + in + bir_symb_transfer + init_addr_tm end_addr_tm + bspec_pre_tm bspec_post_tm + bir_prog_def birenvtyl_def + bspec_pre_def bspec_post_def prog_vars_list_def + symb_analysis_thm bsysprecond_thm prog_vars_thm + end (* let *) + end (* local *) local @@ -736,6 +756,28 @@ fun bir_symb_transfer_two bspec_cont_thm end (* let *) +fun bir_symb_transfer_two_thm + bir_prog_def + init_addr_def end_addr_1_def end_addr_2_def + bspec_pre_def bspec_post_1_def bspec_post_2_def + birenvtyl_def prog_vars_list_def + symb_analysis_thm bsysprecond_thm prog_vars_thm = + let + val init_addr_tm = (snd o dest_eq o concl) init_addr_def; + val end_addr_1_tm = (snd o dest_eq o concl) end_addr_1_def; + val end_addr_2_tm = (snd o dest_eq o concl) end_addr_2_def; + val bspec_pre_tm = (lhs o snd o strip_forall o concl) bspec_pre_def; + val bspec_post_1_tm = (lhs o snd o strip_forall o concl) bspec_post_1_def; + val bspec_post_2_tm = (lhs o snd o strip_forall o concl) bspec_post_2_def; + in + bir_symb_transfer_two + init_addr_tm end_addr_1_tm end_addr_2_tm + bspec_pre_tm bspec_post_1_tm bspec_post_2_tm + bir_prog_def birenvtyl_def + bspec_pre_def bspec_post_1_def bspec_post_2_def prog_vars_list_def + symb_analysis_thm bsysprecond_thm prog_vars_thm + end (* let *) + end (* local *) end (* structure *) From 28943f44eb88dcc0163e0fcaca39a7049b5feace Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Wed, 25 Sep 2024 13:36:45 +0200 Subject: [PATCH 22/95] Prepare simplification test --- examples/riscv/perftest/simpstress.sml | 48 ++++++++++++++++++-------- 1 file changed, 33 insertions(+), 15 deletions(-) diff --git a/examples/riscv/perftest/simpstress.sml b/examples/riscv/perftest/simpstress.sml index 5a04b2788..3214e2ee9 100644 --- a/examples/riscv/perftest/simpstress.sml +++ b/examples/riscv/perftest/simpstress.sml @@ -154,11 +154,7 @@ local <|bpc_label := BL_Address (Imm64 2804w); bpc_index := 0|>; bsst_environ := birs_gen_env - [("x15", - BExp_BinExp BIExp_Minus - (BExp_Den (BVar "sy_x11" (BType_Imm Bit64))) - (BExp_Const (Imm64 2w))); - ("MEM8", + [("MEM8", BExp_Store (BExp_Store (BExp_Store @@ -6750,6 +6746,10 @@ local (BExp_Den (BVar "sy_x14" (BType_Imm Bit64)))) BEnd_LittleEndian Bit32) Bit64)); + ("x15", + BExp_BinExp BIExp_Minus + (BExp_Den (BVar "sy_x11" (BType_Imm Bit64))) + (BExp_Const (Imm64 2w))); ("x8", BExp_BinExp BIExp_Minus (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) @@ -7048,7 +7048,8 @@ local ``; val pc_old = ``<|bpc_label := BL_Address (Imm64 2804w); bpc_index := 0|>``; -val pc_new = ``<|bpc_label := BL_Address (Imm64 0xAECw); bpc_index := 1|>``; +val pc_new = ``<|bpc_label := BL_Address (Imm64 0xAECw); bpc_index := 1|>``; (* load *) +val pc_new = ``<|bpc_label := BL_Address (Imm64 0xAECw); bpc_index := 0|>``; (* assert alignment of x8 *) (* val t = state; @@ -7072,21 +7073,19 @@ end; (* ================================================================================= *) open birs_stepLib; +open birs_execLib; val bprog_tm = (fst o dest_eq o concl) bir_aespart_prog_def; val birs_rule_STEP_thm = birs_rule_STEP_prog_fun (bir_prog_has_no_halt_fun bprog_tm); val birs_rule_SUBST_thm = birs_rule_SUBST_prog_fun bprog_tm; + val birs_simp_fun = birs_rule_SUBST_trysimp_fun birs_rule_SUBST_thm; - val timer_symbanalysis_last = ref (holba_miscLib.timer_start 0); - val birs_post_step_fun = (fn t => ( - holba_miscLib.timer_stop (fn delta_s => print ("time since last step " ^ delta_s ^ "\n")) (!timer_symbanalysis_last); - timer_symbanalysis_last := holba_miscLib.timer_start 0; (*print_term ((last o pairSyntax.strip_pair o snd o dest_comb o concl) t);*) t)) o - birs_rule_SUBST_trysimp_fun birs_rule_SUBST_thm o + birs_simp_fun o birs_rule_tryprune_fun birs_rulesTheory.branch_prune1_spec_thm o birs_rule_tryprune_fun birs_rulesTheory.branch_prune2_spec_thm o birs_rule_tryjustassert_fun true; @@ -7096,10 +7095,27 @@ val bprog_tm = (fst o dest_eq o concl) bir_aespart_prog_def; birs_rule_STEP_fun birs_rule_STEP_thm); (* ================================================================================= *) -(* - val timer_symbanalysis_last = ref (holba_miscLib.timer_start 0); -val _ = birs_rule_STEP_fun_spec state2; -*) +open birsSyntax; + +val _ = print "assert and simplify large store sequence\n"; +val timer = holba_miscLib.timer_start 0; +val state2_simpd_thm = birs_rule_STEP_fun_spec state2; +val _ = holba_miscLib.timer_stop (fn delta_s => print ("time to simplify large store sequence: " ^ delta_s ^ "\n")) timer; +val _ = (print_term o fst o strip_comb o concl) state2_simpd_thm; +val state2_simpd = + let + val (_, _, Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) state2_simpd_thm; + in + (hd o symb_sound_struct_Pi_to_birstatelist_fun) Pi_tm + end; +val (_, state2_env, _, _) = dest_birs_state state2; +val (_, state2_simpd_env, _, _) = dest_birs_state state2_simpd; +val _ = if identical state2_simpd_env state2_env then print "unchanged\n" else print "changed\n"; + +val _ = print "taking step on simplified state\n"; +val timer = holba_miscLib.timer_start 0; +val _ = birs_rule_STEP_fun_spec state2_simpd; +val _ = holba_miscLib.timer_stop (fn delta_s => print ("time to step with simplifications and pruning: " ^ delta_s ^ "\n")) timer; (* @@ -7110,6 +7126,7 @@ Profile.output_profile_results (iostream) (Profile.results ()) *) +(* val smt_check_exp = ``BExp_Den (BVar "abc" (BType_Imm Bit1))``; val howmanylist = List.tabulate (1000, fn _ => ()); @@ -7118,6 +7135,7 @@ val _ = List.foldr (fn (_,_) => bir_smtLib.bir_smt_check_sat false smt_check_exp val _ = print "\n"; val _ = Profile.print_profile_results (Profile.results ()); +*) (* val teststring = holba_fileLib.read_from_file "/home/andreas/data/hol/HolBA_symbexec/examples/riscv/perftest/tempdir/smtquery_2024-08-08_11-38-51_253062_nil"; From 6d61a8e64e26ff76f281dfbb45a674d7f59f910c Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Fri, 27 Sep 2024 15:42:27 +0200 Subject: [PATCH 23/95] Refactor simplification library Add various performance fixes --- examples/riscv/perftest/simpstress.sml | 56 ++- src/tools/symbexec/bir_symbLib.sml | 5 +- src/tools/symbexec/birsSyntax.sml | 11 +- src/tools/symbexec/birs_driveLib.sml | 9 +- src/tools/symbexec/birs_execLib.sml | 11 +- src/tools/symbexec/birs_simpLib.sml | 582 ++++++++++++++++--------- src/tools/symbexec/birs_stepLib.sml | 13 +- 7 files changed, 461 insertions(+), 226 deletions(-) diff --git a/examples/riscv/perftest/simpstress.sml b/examples/riscv/perftest/simpstress.sml index 3214e2ee9..2ce541075 100644 --- a/examples/riscv/perftest/simpstress.sml +++ b/examples/riscv/perftest/simpstress.sml @@ -7070,6 +7070,25 @@ val state2 = replace_subterm state pc_old pc_new; end; +open birsSyntax; + +(* ================================================================================= *) +open birs_auxLib; +fun pc_lookup_fallback_fun pc_lookup_t = + let + val _ = print "falling back to evaluation to get current statement"; + val pc_lookup_thm = EVAL pc_lookup_t; + in + pc_lookup_thm + end; +fun pc_lookup_fun (bprog_tm, pc_tm) = + let + val pc_lookup_t = mk_bir_get_current_statement (bprog_tm, pc_tm); + in + case (!cur_stmt_lookup_fun) pc_tm of + NONE => pc_lookup_fallback_fun pc_lookup_t + | SOME x => if (identical pc_lookup_t o fst o dest_eq o concl) x then x else pc_lookup_fallback_fun pc_lookup_t + end; (* ================================================================================= *) open birs_stepLib; @@ -7080,28 +7099,41 @@ val bprog_tm = (fst o dest_eq o concl) bir_aespart_prog_def; val birs_rule_STEP_thm = birs_rule_STEP_prog_fun (bir_prog_has_no_halt_fun bprog_tm); val birs_rule_SUBST_thm = birs_rule_SUBST_prog_fun bprog_tm; val birs_simp_fun = birs_rule_SUBST_trysimp_fun birs_rule_SUBST_thm; - - val birs_post_step_fun = + +local + open bir_programSyntax; + open optionSyntax; +in + fun is_SOME_BStmtB_BStmt_Assign t = is_some t andalso (is_BStmtB o dest_some) t andalso (is_BStmt_Assign o dest_BStmtB o dest_some) t; +end + + fun birs_post_step_fun (t, (last_pc, last_stmt)) = + let + val _ = print "starting postprocessing after step\n"; + val _ = print_term last_pc; + val _ = print_term last_stmt; + val _ = if is_SOME_BStmtB_BStmt_Assign last_stmt then print "is an assign\n" else print "is no assign\n"; + val t1 = ( (fn t => ( (*print_term ((last o pairSyntax.strip_pair o snd o dest_comb o concl) t);*) t)) o birs_simp_fun o birs_rule_tryprune_fun birs_rulesTheory.branch_prune1_spec_thm o birs_rule_tryprune_fun birs_rulesTheory.branch_prune2_spec_thm o - birs_rule_tryjustassert_fun true; + birs_rule_tryjustassert_fun true) t; + in + t1 + end; val birs_rule_STEP_fun_spec = (birs_post_step_fun o birs_rule_STEP_fun birs_rule_STEP_thm); (* ================================================================================= *) -open birsSyntax; - val _ = print "assert and simplify large store sequence\n"; val timer = holba_miscLib.timer_start 0; val state2_simpd_thm = birs_rule_STEP_fun_spec state2; val _ = holba_miscLib.timer_stop (fn delta_s => print ("time to simplify large store sequence: " ^ delta_s ^ "\n")) timer; -val _ = (print_term o fst o strip_comb o concl) state2_simpd_thm; val state2_simpd = let val (_, _, Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) state2_simpd_thm; @@ -7114,9 +7146,19 @@ val _ = if identical state2_simpd_env state2_env then print "unchanged\n" else p val _ = print "taking step on simplified state\n"; val timer = holba_miscLib.timer_start 0; -val _ = birs_rule_STEP_fun_spec state2_simpd; +val state3_thm = birs_rule_STEP_fun_spec state2_simpd; +val state3 = + let + val (_, _, Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) state3_thm; + in + (hd o symb_sound_struct_Pi_to_birstatelist_fun) Pi_tm + end; +val (_, state3_env, _, _) = dest_birs_state state3; val _ = holba_miscLib.timer_stop (fn delta_s => print ("time to step with simplifications and pruning: " ^ delta_s ^ "\n")) timer; +val _ = print "\n"; +val _ = Profile.print_profile_results (Profile.results ()); + (* Profile.reset_all () diff --git a/src/tools/symbexec/bir_symbLib.sml b/src/tools/symbexec/bir_symbLib.sml index 228d38246..665a6593b 100644 --- a/src/tools/symbexec/bir_symbLib.sml +++ b/src/tools/symbexec/bir_symbLib.sml @@ -29,7 +29,7 @@ fun bir_symb_analysis bprog_tm birs_state_init_lbl val timer_symbanalysis_last = ref (holba_miscLib.timer_start 0); val birs_rule_STEP_thm = birs_rule_STEP_prog_fun (bir_prog_has_no_halt_fun bprog_tm); val birs_rule_SUBST_thm = birs_rule_SUBST_prog_fun bprog_tm; - val birs_post_step_fun = + fun birs_post_step_fun (t, (last_pc, last_stmt)) = ( (fn t => ( holba_miscLib.timer_stop (fn delta_s => print ("running since " ^ delta_s ^ "\n")) timer_symbanalysis; holba_miscLib.timer_stop (fn delta_s => print ("time since last step " ^ delta_s ^ "\n")) (!timer_symbanalysis_last); @@ -39,7 +39,8 @@ fun bir_symb_analysis bprog_tm birs_state_init_lbl birs_rule_SUBST_trysimp_fun birs_rule_SUBST_thm o birs_rule_tryprune_fun birs_rulesTheory.branch_prune1_spec_thm o birs_rule_tryprune_fun birs_rulesTheory.branch_prune2_spec_thm o - birs_rule_tryjustassert_fun true; + birs_rule_tryjustassert_fun true + ) t; val birs_rule_STEP_fun_spec = (birs_post_step_fun o birs_rule_STEP_fun birs_rule_STEP_thm); diff --git a/src/tools/symbexec/birsSyntax.sml b/src/tools/symbexec/birsSyntax.sml index a5b94fac5..2c1cb3158 100644 --- a/src/tools/symbexec/birsSyntax.sml +++ b/src/tools/symbexec/birsSyntax.sml @@ -46,7 +46,7 @@ in end; local - fun syntax_fns n d m = HolKernel.syntax_fns {n = n, dest = d, make = m} "bir_symb" + fun syntax_fns n d m = HolKernel.syntax_fns {n = n, dest = d, make = m} "bir_symb"; val syntax_fns1 = syntax_fns 1 HolKernel.dest_monop HolKernel.mk_monop; val syntax_fns2 = syntax_fns 2 HolKernel.dest_binop HolKernel.mk_binop; val syntax_fns2_env = syntax_fns 3 HolKernel.dest_binop HolKernel.mk_binop; @@ -95,7 +95,14 @@ in end handle e => raise wrap_exn "mk_birs_state" e; (* val (_tm, mk_, dest_, is_) = syntax_fns2_set "";*) -end; +end + +local + fun syntax_fns n d m = HolKernel.syntax_fns {n = n, dest = d, make = m} "bir_symb_simp"; + val syntax_fns3 = syntax_fns 3 HolKernel.dest_triop HolKernel.mk_triop; +in + val (birs_simplification_tm, mk_birs_simplification, dest_birs_simplification, is_birs_simplification) = syntax_fns3 "birs_simplification"; +end fun is_IMAGE_birs_symb_to_symbst Pi = pred_setSyntax.is_image Pi andalso (identical birs_symb_to_symbst_tm o fst o pred_setSyntax.dest_image) Pi; fun dest_IMAGE_birs_symb_to_symbst Pi = diff --git a/src/tools/symbexec/birs_driveLib.sml b/src/tools/symbexec/birs_driveLib.sml index 8cdf6bbfa..3810fb914 100644 --- a/src/tools/symbexec/birs_driveLib.sml +++ b/src/tools/symbexec/birs_driveLib.sml @@ -58,7 +58,7 @@ val SUBST_thm = birs_rule_SUBST_thm; val STEP_SEQ_thm = birs_rule_STEP_SEQ_thm; val symbex_A_thm = single_step_A_thm; *) -fun birs_rule_STEP_SEQ_fun_ (SUBST_thm, STEP_SEQ_thm) symbex_A_thm = +fun birs_rule_STEP_SEQ_fun (SUBST_thm, STEP_SEQ_thm) symbex_A_thm = let val step1_thm = MATCH_MP STEP_SEQ_thm symbex_A_thm; val step2_thm = REWRITE_RULE [bir_symbTheory.birs_state_t_accessors, bir_symbTheory.birs_state_t_accfupds, combinTheory.K_THM] step1_thm; @@ -67,16 +67,17 @@ fun birs_rule_STEP_SEQ_fun_ (SUBST_thm, STEP_SEQ_thm) symbex_A_thm = val timer_exec_step_p3 = holba_miscLib.timer_start 0; *) - val step3_thm = CONV_RULE birs_exec_step_CONV_fun step2_thm; + val (step3_conv_thm, extra_info) = birs_exec_step_CONV_fun (concl step2_thm); + val step3_thm = EQ_MP step3_conv_thm step2_thm; (* val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n>>>>>> STEP_SEQ in " ^ delta_s ^ "\n")) timer_exec_step_p3; *) val step4_thm = (* (birs_rule_SUBST_trysimp_fun SUBST_thm o birs_rule_tryjustassert_fun true) *) step3_thm; in - step4_thm + (step4_thm, extra_info) end; -fun birs_rule_STEP_SEQ_fun x = Profile.profile "birs_rule_STEP_SEQ_fun" (birs_rule_STEP_SEQ_fun_ x); +val birs_rule_STEP_SEQ_fun = fn x => Profile.profile "birs_rule_STEP_SEQ_fun" (birs_rule_STEP_SEQ_fun x); (* diff --git a/src/tools/symbexec/birs_execLib.sml b/src/tools/symbexec/birs_execLib.sml index cd98da9bc..52032c0f4 100644 --- a/src/tools/symbexec/birs_execLib.sml +++ b/src/tools/symbexec/birs_execLib.sml @@ -58,8 +58,9 @@ local in fun birs_rule_STEP_fun_ birs_rule_STEP_thm bstate_tm = let - - val birs_exec_thm = CONV_RULE (birs_exec_step_CONV_fun) (SPEC bstate_tm birs_rule_STEP_thm); + val step1_thm = SPEC bstate_tm birs_rule_STEP_thm; + val (step2_thm, extra_info) = birs_exec_step_CONV_fun (concl step1_thm); + val birs_exec_thm = EQ_MP step2_thm step1_thm; val timer_exec_step_p3 = holba_miscLib.timer_start 0; (* TODO: optimize *) @@ -75,7 +76,7 @@ fun birs_rule_STEP_fun_ birs_rule_STEP_thm bstate_tm = (print_term (concl single_step_prog_thm); raise ERR "birs_rule_STEP_fun" "something is not right, the produced theorem is not evaluated enough"); in - single_step_prog_thm + (single_step_prog_thm, extra_info) end; end; fun birs_rule_STEP_fun x = Profile.profile "birs_rule_STEP_fun" (birs_rule_STEP_fun_ x); @@ -272,9 +273,9 @@ fun birs_rule_SUBST_trysimp_fun_ birs_rule_SUBST_thm single_step_prog_thm = val simp_t_o = Option.mapPartial (fn assignment_thm => let val simp_tm = (fst o dest_imp o (*snd o strip_binder (SOME boolSyntax.universal) o*) concl o Q.SPEC `symbexp'`) assignment_thm; - + (*val _ = print_term simp_tm;*) val timer_exec_step_p3 = holba_miscLib.timer_start 0; - val simp_t = birs_simpLib.birs_simp_repeat simp_tm; + val simp_t = birs_simpLib.birs_simp_gen simp_tm; (* TODO: need to remove the following line later and enable the simp function above *) (*val simp_t_o = NONE;*) val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n>>>>>> SUBST in " ^ delta_s ^ "\n")) timer_exec_step_p3; diff --git a/src/tools/symbexec/birs_simpLib.sml b/src/tools/symbexec/birs_simpLib.sml index 886b0796e..63dcb488d 100644 --- a/src/tools/symbexec/birs_simpLib.sml +++ b/src/tools/symbexec/birs_simpLib.sml @@ -19,48 +19,131 @@ open birs_auxLib; in (* local *) -(* + local + val symbexp_prim_tm = ``symbexp':bir_exp_t``; + in + fun birs_simp_gen_term pcond bexp = + birsSyntax.mk_birs_simplification (pcond, bexp, symbexp_prim_tm); + end + + fun birs_simp_gen_term_from_prev_simp_thm pre_simp_thm = + let + val (pcond_tm, _, bexp_tm) = (birsSyntax.dest_birs_simplification o concl) pre_simp_thm; + in + birs_simp_gen_term pcond_tm bexp_tm + end; -(*symb_rulesTheory.symb_simplification_def*) -fun birs_trysimp + fun birs_simp_ID_fun simp_tm = + let + val (pcond_tm, bexp_tm, _) = birsSyntax.dest_birs_simplification simp_tm; + val simp_thm = ISPECL [pcond_tm, bexp_tm] birs_simplification_ID_thm; + in + simp_thm + end + handle _ => raise ERR "birs_simp_ID_fun" ("this shouldn't happen :: " ^ (term_to_string simp_tm)); - fun try_inst t simp_thm = - let - val t_ = SPEC_ALL t; - val bir_simp_tm = (fst o dest_comb o (*snd o strip_binder (SOME boolSyntax.universal) o*) concl) t_; - val bir_simp_inst_tm = (fst o dest_comb o fst o dest_imp o (*snd o strip_binder (SOME boolSyntax.universal) o*) concl o Q.SPEC `symbexp'`) simp_thm; + fun birs_simp_check_ID_opt_fun simp_tm_fun simp_tm = + let + val simp_thm = simp_tm_fun simp_tm; + val (_,exp1,exp2) = (birsSyntax.dest_birs_simplification o concl) simp_thm; + val is_ID = identical exp1 exp2; + in + if is_ID then + NONE + else + SOME simp_thm + end; - val tm_subst = match_term bir_simp_tm bir_simp_inst_tm; - val final_thm = INST_TY_TERM tm_subst t_; - in - CONV_RULE (TRY_CONV (RAND_CONV EVAL) THENC REFL) final_thm - end; + fun birs_simp_apply_trans post_fun pre_simp_thm simp_thm_o = + if isSome simp_thm_o then + let + val t1 = pre_simp_thm; + val t2 = valOf simp_thm_o; + val (pcond_tm, bexp1_tm, bexp2_tm) = (birsSyntax.dest_birs_simplification o concl) t1; + val (_, _, bexp3_tm) = (birsSyntax.dest_birs_simplification o concl) t2; + val trans_spec_thm = SPECL [pcond_tm, bexp1_tm, bexp2_tm, bexp3_tm] birs_simplification_TRANS_thm; + val t3 = MP (MP trans_spec_thm t1) t2; + in + post_fun t3 + end + else + pre_simp_thm; - fun try_fold_match simp_thm (t, thm_o) = +(* ----------------------------------------------------------------------------------- *) + + (* try simplifying with the theorems of the list in order and return NONE or SOME simplification theorem *) +(* + fun simp_try_fold_fun_gen simp_try_fun (t, thm_o) = if isSome thm_o then thm_o else - SOME (MATCH_MP simp_thm (try_inst t simp_thm)) - handle _ => NONE; + (* SOME (MATCH_MP simp_thm (try_inst t simp_thm)) *) + simp_try_fun (t, NONE) + (*handle _ => NONE*); - fun repeat_fold step_thm = + fun simp_try_fold_gen simp_try_fun h_thms (simp_tm, simp_thm_o) = + List.foldl (fn (h_thm, simp_thm_o) => simp_try_fold_fun_gen (simp_try_fun h_thm) (simp_tm, simp_thm_o)) simp_thm_o h_thms; +*) + fun simp_try_fold_gen simp_try_fun [] (_, simp_thm_o) = simp_thm_o + | simp_try_fold_gen simp_try_fun (h_thm::h_thms) (simp_tm, simp_thm_o) = + if isSome simp_thm_o then + simp_thm_o + else + let + val simp_thm_o1 = simp_try_fun h_thm (simp_tm, NONE); + in + simp_try_fold_gen simp_try_fun h_thms (simp_tm, simp_thm_o1) + end; + + fun simp_try_list_gen [] (_, simp_thm_o) = simp_thm_o + | simp_try_list_gen (fh::fl) (simp_tm, simp_thm_o) = + if isSome simp_thm_o then + simp_thm_o + else + let + val simp_thm_o1 = fh (simp_tm, NONE); + in + simp_try_list_gen fl (simp_tm, simp_thm_o1) + end; + + fun simp_try_make_option_fun basic_fun (simp_tm, simp_thm_o) = + if isSome simp_thm_o then + simp_thm_o + else + basic_fun simp_tm; + + fun simp_try_list_cont_gen_1 [] pre_simp_thm = pre_simp_thm + | simp_try_list_cont_gen_1 (fh::fl) pre_simp_thm = + let + val simp_tm = birs_simp_gen_term_from_prev_simp_thm pre_simp_thm; + val simp_thm_o = fh (simp_tm, NONE); + val post_simp_thm = birs_simp_apply_trans I pre_simp_thm simp_thm_o; + in + simp_try_list_cont_gen_1 fl post_simp_thm + end; + fun simp_try_list_cont_gen_2 simp_funs simp_tm = + simp_try_list_cont_gen_1 simp_funs (birs_simp_ID_fun simp_tm); + fun simp_try_list_cont_gen simp_funs = simp_try_make_option_fun (birs_simp_check_ID_opt_fun (simp_try_list_cont_gen_2 simp_funs)); + + fun simp_try_repeat_gen_1 simp_fun pre_simp_thm = let - val assignment_thm = MATCH_MP birs_rule_SUBST_thm step_thm; - val thm_o = List.foldr (try_fold_match assignment_thm) NONE const_add_subst_thms; + val simp_tm = birs_simp_gen_term_from_prev_simp_thm pre_simp_thm; + val simp_thm_o = simp_fun (simp_tm, NONE); in - if isSome thm_o then - repeat_fold (valOf thm_o) - else - step_thm + birs_simp_apply_trans (simp_try_repeat_gen_1 simp_fun) pre_simp_thm simp_thm_o end; + fun simp_try_repeat_gen_2 simp_fun simp_tm = + simp_try_repeat_gen_1 simp_fun (birs_simp_ID_fun simp_tm); + fun simp_try_repeat_gen simp_fun = simp_try_make_option_fun (birs_simp_check_ID_opt_fun (simp_try_repeat_gen_2 simp_fun)); -*) - - fun birs_simp_gen_term pcond bexp = `` - birs_simplification ^pcond ^bexp symbexp' - ``; - + fun simp_try_apply_gen simp_fun simp_tm = + let + val simp_thm_o = simp_fun (simp_tm, NONE); + in + Option.getOpt (simp_thm_o, birs_simp_ID_fun simp_tm) + end; +(* ----------------------------------------------------------------------------------- *) (* val t = ASSUME `` @@ -92,107 +175,138 @@ val t = ASSUME `` (* val t = instd_thm; *) + fun wrap_cache_result f = + let + val assumption_dict = ref (Redblackmap.mkDict Term.compare); + fun assumption_add (k_tm, tc_thm) = assumption_dict := Redblackmap.insert (!assumption_dict, k_tm, tc_thm); + fun assumption_lookup k_tm = + SOME (Redblackmap.find (!assumption_dict, k_tm)) + handle NotFound => NONE; + fun f_wrapped tm = + let + val a_thm_o = assumption_lookup tm; + in + if isSome a_thm_o then valOf a_thm_o else + let + val a_thm = f tm; + in + assumption_add (tm, a_thm); + a_thm + end + end; + in + f_wrapped + end; - (* need to handle typecheck, IS_SOME typecheck *) - fun birs_simp_try_justify_assumptions t = - if (not o is_imp o concl) t then - t - else - let - val assmpt = (fst o dest_imp o concl) t; - val type_ofbirexp_CONV = GEN_match_conv (bir_typing_expSyntax.is_type_of_bir_exp) (type_of_bir_exp_DIRECT_CONV); + fun birs_simp_try_justify_assumption assmpt = + let + val type_ofbirexp_CONV = GEN_match_conv (bir_typing_expSyntax.is_type_of_bir_exp) (type_of_bir_exp_DIRECT_CONV); val assmpt_thm = (type_ofbirexp_CONV THENC EVAL) assmpt; val assmpt_new = (snd o dest_eq o concl) assmpt_thm; (* raise exception when the assumption turns out to be false *) val _ = if not (identical assmpt_new F) then () else - raise ERR "birs_simp_try_justify_assumptions" "assumption does not hold"; + raise ERR "birs_simp_try_justify_assumption" "assumption does not hold"; val _ = if identical assmpt_new T then () else - raise ERR "birs_simp_try_justify_assumptions" ("failed to fix the assumption: " ^ (term_to_string assmpt)); - in - birs_simp_try_justify_assumptions - (REWRITE_RULE [assmpt_thm] t) - end; - val birs_simp_try_justify_assumptions = Profile.profile "birs_simp_try_justify_assumptions" birs_simp_try_justify_assumptions; - + raise ERR "birs_simp_try_justify_assumption" ("failed to fix the assumption: " ^ (term_to_string assmpt)); + in + if identical assmpt_new T then + SOME (EQ_MP (GSYM assmpt_thm) TRUTH) + else + NONE + end + handle _ => NONE; + val birs_simp_try_justify_assumption = wrap_cache_result birs_simp_try_justify_assumption; -(* -val simp_t = birs_simplification_Plus_Plus_Const_thm; -val simp_inst_tm = birs_simp_gen_term pcond bexp; -*) - (* for the plain cases (not subexpression, not pcond implication) *) - fun birs_simp_try_inst simp_inst_tm simp_t = + (* need to handle typecheck, IS_SOME typecheck *) + fun birs_simp_try_justify_assumptions NONE = NONE + | birs_simp_try_justify_assumptions (SOME t) = + if (not o is_imp o concl) t then + SOME t + else let - val simp_t_ = SPEC_ALL simp_t; - val simp_tm = ((fn tm => (if is_imp tm then (snd o strip_imp) else (I)) tm) o concl) simp_t_; - - (* see if the simplification instance fits the simplification theorem conclusion (i.e. simplification term part) *) - val tm_subst_o = - SOME (match_term ((fst o dest_comb) simp_tm) ((fst o dest_comb) simp_inst_tm)) - handle _ => NONE; + val assmpt = (fst o dest_imp o concl) t; + val assmpt_thm_o = birs_simp_try_justify_assumption assmpt; in - (* - val SOME tm_subst = tm_subst_o; - *) - Option.map (fn tm_subst => INST_TY_TERM tm_subst simp_t_) tm_subst_o + case assmpt_thm_o of + NONE => NONE + | SOME assmpt_thm => + birs_simp_try_justify_assumptions + (SOME (MP t assmpt_thm)) end; fun birs_simp_try_fix_assumptions instd_thm = let (* now try to check the assumptions *) - val final_thm_o = - SOME (birs_simp_try_justify_assumptions instd_thm) - handle _ => NONE; + val final_thm_o = birs_simp_try_justify_assumptions (SOME instd_thm); + val _ = if isSome final_thm_o andalso (birsSyntax.is_birs_simplification o concl) (valOf final_thm_o) then () else + raise ERR "birs_simp_try_fix_assumptions" "this should not happen"; in - Option.map (fn final_thm => CONV_RULE (TRY_CONV (RAND_CONV EVAL) THENC REFL) final_thm) final_thm_o + (* Option.map (CONV_RULE (TRY_CONV (RAND_CONV EVAL) THENC REFL)) (* why was this here??*) *) final_thm_o end; val birs_simp_try_fix_assumptions = Profile.profile "birs_simp_try_fix_assumptions" birs_simp_try_fix_assumptions; + +(* ----------------------------------------------------------------------------------- *) +(* ----------------------------------------------------------------------------------- *) +(* ----------------------------------------------------------------------------------- *) +(* ----------------------------------------------------------------------------------- *) + + + val get_op = fst o dest_comb; + val get_rarg = snd o dest_comb; + val get_larg = get_rarg o get_op; + val get_fst_antec = fst o dest_imp; + val get_snd_antec = get_fst_antec o snd o dest_imp; + val get_conseq = fn tm => (if is_imp tm then (snd o strip_imp) else (I)) tm; + + (* match a term tm within in a theorem thm, use thm_tm_get to extract the part of the theorem to be matched with the part of the term tm that is extracted with tm_get *) + fun simp_try_match_gen (thm_tm_get, tm_get) thm tm = + let + val thm_tm = (thm_tm_get o concl) thm; + val tm_tm = tm_get tm; - val birs_simp_exp_plain_thms = - [birs_simplification_UnsignedCast_LowCast_Twice_thm, - - birs_simplification_Plus_Const64_thm, - - birs_simplification_Plus_Plus_Const64_thm, - birs_simplification_Minus_Plus_Const64_thm, - birs_simplification_Minus_Minus_Const64_thm, - birs_simplification_Plus_Minus_Const64_thm(*, + (* see if the simplification instance fits the simplification theorem conclusion (i.e. simplification term part) *) + val tm_subst_o = + SOME (match_term thm_tm tm_tm) + handle _ => NONE; + in + (* + val SOME tm_subst = tm_subst_o; + *) + Option.map (fn tm_subst => INST_TY_TERM tm_subst thm) tm_subst_o + end; - birs_simplification_Plus_Plus_Const32_thm, - birs_simplification_Minus_Plus_Const32_thm, - birs_simplification_Minus_Minus_Const32_thm, - birs_simplification_Plus_Minus_Const32_thm*)]; + (* special case of matching, where first the forall quantifiers are removed and then the rightmost consequent is extracted (if it is an implication) *) + fun simp_try_inst_gen (inst_tm_get, tm_get) simp_t tm = + simp_try_match_gen (inst_tm_get o get_conseq, tm_get) (SPEC_ALL simp_t) tm; - (* try simplifying with the theorems of the list in order and return NONE or SOME simplification theorem *) - fun simp_try_fold_fun_gen simp_try_fun (t, thm_o) = - if isSome thm_o then - thm_o - else - (* SOME (MATCH_MP simp_thm (try_inst t simp_thm)) *) - simp_try_fun t - (*handle _ => NONE*); +(* +val simp_t = birs_simplification_Plus_Plus_Const_thm; +val simp_inst_tm = birs_simp_gen_term pcond bexp; +*) + (* for the plain cases (not subexpression, not pcond implication) *) + (* select only the operations because in case of plain theorems, the last operand is the symbexp' we are trying to find *) + val birs_simp_try_inst = + simp_try_inst_gen (get_op, get_op); - fun simp_try_fold_gen simp_try_fun simp_inst_tm simp_thms acc = - List.foldr (simp_try_fold_fun_gen (simp_try_fun simp_inst_tm)) acc simp_thms; - val birs_simp_try_plain_simp_ = - fn x => fn y => Option.mapPartial birs_simp_try_fix_assumptions (birs_simp_try_inst x y); - fun birs_simp_try_plain_simp x = Profile.profile "birs_simp_try_plain_simp" (birs_simp_try_plain_simp_ x); + fun birs_simp_try_plain h_thm simp_tm = + Option.mapPartial birs_simp_try_fix_assumptions (birs_simp_try_inst h_thm simp_tm); + val birs_simp_try_plain = fn h_thm => simp_try_make_option_fun (birs_simp_try_plain h_thm); (* val simp_inst_tm = birs_simp_gen_term pcond bexp; - val abc = simp_try_fold_gen birs_simp_try_plain_simp simp_inst_tm birs_simp_exp_plain_thms NONE; + val abc = simp_try_fold_gen birs_simp_try_plain birs_simp_exp_plain_thms (simp_inst_tm, NONE); *) - fun check_imp_tm imp_tm = - let + let (* input term: birs_exp_imp *) (* ================================================= *) (* TODO: function/code to remove imp assumption, with smt solver *) - val pred1_tm = (snd o dest_comb o fst o dest_comb) imp_tm; - val pred2_tm = (snd o dest_comb) imp_tm; + val pred1_tm = get_larg imp_tm; + val pred2_tm = get_rarg imp_tm; val imp_bexp_tm = bslSyntax.bor (bslSyntax.bnot pred1_tm, pred2_tm); val imp_is_taut = bir_smt_check_taut false imp_bexp_tm; val imp_thm = @@ -201,91 +315,68 @@ val simp_inst_tm = birs_simp_gen_term pcond bexp; mk_oracle_thm "BIRS_SIMP_LIB_Z3" ([], imp_tm) else ( (*print_term imp_tm;*) - print "implication term is not a tautology"; + print "implication term is not a tautology\n"; raise ERR "check_imp_tm" "implication term is not a tautology" ) - in - imp_thm - end; + in + SOME imp_thm + end + handle _ => NONE; + val check_imp_tm = wrap_cache_result check_imp_tm; (* val simp_t = birs_simplification_IfThenElse_T_thm; val simp_t = birs_simplification_IfThenElse_F_thm; -val simp_inst_tm = birs_simp_gen_term pcond bexp; +val simp_tm = birs_simp_gen_term pcond bexp; *) - fun birs_simp_try_pcond_simp_ simp_inst_tm simp_t = + fun birs_simp_try_pcond simp_t simp_tm = let - val SOME birs_simp_IMP_inst_t = birs_simp_try_inst simp_inst_tm birs_simplification_IMP_thm; - val simp_inst_tm = (fst o dest_imp o snd o dest_imp o concl) birs_simp_IMP_inst_t; - - val simp_t_ = SPEC_ALL simp_t; - val simp_tm = ((fn tm => (if is_imp tm then (snd o strip_imp) else (I)) tm) o concl) simp_t_; - - (* see if the simplification instance fits the simplification theorem conclusion (i.e. simplification term part) *) - val tm_subst_o = - SOME (match_term ((snd o dest_comb o fst o dest_comb) simp_tm) ((snd o dest_comb o fst o dest_comb) simp_inst_tm)) - handle _ => NONE; - - val SOME instd_thm = Option.map (fn tm_subst => INST_TY_TERM tm_subst simp_t_) tm_subst_o; - - val SOME basic_simp_thm = birs_simp_try_fix_assumptions instd_thm; - - val birs_simp_IMP_inst_tm = (fst o dest_imp o snd o dest_imp o concl) birs_simp_IMP_inst_t; - - val tm_subst_o = - SOME (match_term birs_simp_IMP_inst_tm (concl basic_simp_thm)) - handle _ => NONE; - - val SOME instd_thm = Option.map (fn tm_subst => INST_TY_TERM tm_subst birs_simp_IMP_inst_t) tm_subst_o; - - - val imp_tm = (fst o dest_imp o concl) instd_thm; - (* ================================================= *) - val imp_thm = check_imp_tm imp_tm; - - val final_thm = MP (MP instd_thm imp_thm) basic_simp_thm; + val simp_IMP_thm_inst = + case birs_simp_try_inst birs_simplification_IMP_thm simp_tm of + SOME t => t + | NONE => raise ERR "birs_simp_try_pcond" "this should always work if the arguments are right"; + (* continue with the instantiated simplification term that has a free variable for the path condition *) + val simp_tm_new = (get_snd_antec o concl) simp_IMP_thm_inst; + + (* try to instantiate and fix the assumptions of the simplification theorem simp_t *) + val simp_t_inst = + case simp_try_inst_gen (get_larg, get_larg) simp_t simp_tm_new of + SOME t => t + | NONE => raise ERR "birs_simp_try_pcond" "the provided theorem is not applicable for the provided simplification term"; + val simp_thm = + case birs_simp_try_fix_assumptions simp_t_inst of + SOME t => t + | NONE => raise ERR "birs_simp_try_pcond" "not all assumptions of the provided theorem hold"; + + (* finish instantiation (i.e., path condition required by simp_t) *) + val instd_thm = + case simp_try_match_gen (get_snd_antec, I) simp_IMP_thm_inst (concl simp_thm) of + SOME t => t + | NONE => raise ERR "birs_simp_try_pcond" "this should always work if the arguments are right"; + + (* take out the implication predicate, prove it with the smt solver function, and remove it from the theorem *) + val imp_tm = (get_fst_antec o concl) instd_thm; + val imp_thm = + case check_imp_tm imp_tm of + SOME t => t + | NONE => raise ERR "birs_simp_try_pcond" "path condition does not entail the simplification condition"; + val final_thm = MP (MP instd_thm imp_thm) simp_thm; in SOME final_thm end handle _ => NONE; - fun birs_simp_try_pcond_simp x = Profile.profile "birs_simp_try_pcond_simp" (birs_simp_try_pcond_simp_ x); - - - val birs_simp_exp_pcond_thms = - [(*birs_simplification_And_Minus_CM0_thm,*) - birs_simplification_LSB0_And64_RV_thm, - birs_simplification_SignedLowCast3264_RV_thm, + val birs_simp_try_pcond = fn h_thm => simp_try_make_option_fun (birs_simp_try_pcond h_thm); - birs_simplification_IfThenElse_T_thm, - birs_simplification_IfThenElse_F_thm]@ - (CONJUNCTS birs_simplification_Mem_Match_64_8_thm)@ - (CONJUNCTS birs_simplification_Mem_Bypass_64_8_thm)(*@ - (CONJUNCTS birs_simplification_Mem_Match_32_8_thm)@ - (CONJUNCTS birs_simplification_Mem_Bypass_32_8_thm)*); (* val simp_inst_tm = birs_simp_gen_term pcond bexp; - val abc = simp_try_fold_gen birs_simp_try_pcond_simp simp_inst_tm birs_simp_exp_pcond_thms NONE; + val abc = simp_try_fold_gen birs_simp_try_pcond birs_simp_exp_pcond_thms (simp_inst_tm, NONE); *) - (* combination function of the two kinds above (direct simplification) *) - (* - try plain simplification *) - (* - try implied simplification *) -(* - val simp_inst_tm = birs_simp_gen_term pcond bexp; -*) - fun birs_simp_try_direct_simp simp_inst_tm = - let - val plain_o = simp_try_fold_gen birs_simp_try_plain_simp simp_inst_tm birs_simp_exp_plain_thms NONE; - val pcond_o = simp_try_fold_gen birs_simp_try_pcond_simp simp_inst_tm birs_simp_exp_pcond_thms plain_o; - in - pcond_o - end; - val birs_simp_try_direct_simp = Profile.profile "birs_simp_try_direct_simp" birs_simp_try_direct_simp; (* "recursion" into certain subexpressions *) @@ -293,31 +384,24 @@ val simp_inst_tm = birs_simp_gen_term pcond bexp; val simp_t = birs_simplification_Minus_thm; val simp_inst_tm = birs_simp_gen_term pcond bexp; *) - fun birs_simp_try_subexp_simp_ simp_inst_tm simp_t = + fun birs_simp_try_subexp sub_simp_fun simp_t simp_inst_tm = let - val SOME birs_simp_IMP_inst_t = birs_simp_try_inst simp_inst_tm simp_t; + val birs_simp_IMP_inst_t = + case birs_simp_try_inst simp_t simp_inst_tm of + SOME t => t + | NONE => raise ERR "birs_simp_try_subexp" "cannot instantiate subexp theorem for the target simplification"; val simp_inst_tm__ = (fst o dest_imp o concl) birs_simp_IMP_inst_t; - val SOME simp_thm = birs_simp_try_direct_simp simp_inst_tm__; + val simp_thm_o = sub_simp_fun (simp_inst_tm__, NONE); in - SOME (MATCH_MP birs_simp_IMP_inst_t simp_thm) + Option.map (fn simp_thm => MATCH_MP birs_simp_IMP_inst_t simp_thm) simp_thm_o end handle _ => NONE; - fun birs_simp_try_subexp_simp x = Profile.profile "birs_simp_try_subexp_simp" (birs_simp_try_subexp_simp_ x); - - val birs_simp_exp_subexp_thms = - [birs_simplification_UnsignedCast_thm, - birs_simplification_SignedCast_thm, - birs_simplification_LowCast_thm, - birs_simplification_Minus_left_thm, - birs_simplification_Plus_left_thm, - birs_simplification_Plus_right_thm, - birs_simplification_Load_addr_thm, - birs_simplification_Store_addr_thm]; + val birs_simp_try_subexp = fn sub_simp_fun => fn simp_t => simp_try_make_option_fun (birs_simp_try_subexp sub_simp_fun simp_t); (* val simp_inst_tm = birs_simp_gen_term pcond bexp; - val abc = simp_try_fold_gen birs_simp_try_subexp_simp simp_inst_tm birs_simp_exp_subexp_thms NONE; + val abc = simp_try_fold_gen birs_simp_try_subexp birs_simp_exp_subexp_thms (simp_inst_tm, NONE); *) @@ -327,43 +411,131 @@ val simp_inst_tm = birs_simp_gen_term pcond bexp; (* - repeat the above until can't find anything to simplify *) - fun birs_simp_ID_fun simp_inst_tm = - let - val simp_t_ = SPEC_ALL birs_simplification_ID_thm; - val simp_tm_ = (concl) simp_t_; - val tm_subst_o = - SOME (match_term ((fst o dest_comb) simp_tm_) ((fst o dest_comb) simp_inst_tm)) - handle _ => NONE; - val SOME instd_thm = Option.map (fn tm_subst => INST_TY_TERM tm_subst simp_t_) tm_subst_o; - in - instd_thm - end - handle _ => raise ERR "birs_simp_ID_thm" ("this shouldn't happen :: " ^ (term_to_string simp_inst_tm)); (* val simp_inst_tm = birs_simp_gen_term pcond bexp; - val start_simp_thm = birs_simp_ID_fun simp_inst_tm; + val pre_simp_thm = birs_simp_ID_fun simp_inst_tm; birs_simp_repeat simp_inst_tm; *) - fun birs_simp_repeat_ start_simp_thm = - let - val pcond_tm = (snd o dest_comb o fst o dest_comb o fst o dest_comb o concl) start_simp_thm; - val bexp_tm = (snd o dest_comb o concl) start_simp_thm; - val simp_inst_tm__ = birs_simp_gen_term pcond_tm bexp_tm; - val direct_o = birs_simp_try_direct_simp simp_inst_tm__; - val subexp_o = simp_try_fold_gen birs_simp_try_subexp_simp simp_inst_tm__ birs_simp_exp_subexp_thms direct_o; - in - if isSome subexp_o then - birs_simp_repeat_ (MATCH_MP (MATCH_MP birs_simplification_TRANS_thm start_simp_thm) (valOf subexp_o)) - else - start_simp_thm - end; - val birs_simp_repeat_ = Profile.profile "birs_simp_repeat_" birs_simp_repeat_; + (* combination function of the two kinds above (direct simplification) *) + (* - try plain simplification *) + (* - try implied simplification *) +(* + val simp_inst_tm = birs_simp_gen_term pcond bexp; +*) +(* ----------------------------------------------------------------------------------- *) + +(* + 4 types of simplification functions, and recursive rinse&repeat + - plain (only basic assumptions as typing or some numbers or other basic equalities) + - pcond (starts out with basic assumptions, justify pcond implication with smt solver) + - direct (first try all plain, then try pcond) + - subexp (go into subexpression and then try direct, no recusion into subexpressions of subexpressions) + + recursive rinse&repeat + - try direct, then try subexp, one simplification = one iteration, repeat until no more possible + special treatment of store sequences, and load operations +*) + + val birs_simp_exp_plain_thms = List.rev ( + [birs_simplification_UnsignedCast_LowCast_Twice_thm, + + birs_simplification_Plus_Const64_thm, + + birs_simplification_Plus_Plus_Const64_thm, + birs_simplification_Minus_Plus_Const64_thm, + birs_simplification_Minus_Minus_Const64_thm, + birs_simplification_Plus_Minus_Const64_thm(*, + + birs_simplification_Plus_Plus_Const32_thm, + birs_simplification_Minus_Plus_Const32_thm, + birs_simplification_Minus_Minus_Const32_thm, + birs_simplification_Plus_Minus_Const32_thm*)] + ); + + val birs_simp_exp_pcond_thms = List.rev ( + [(*birs_simplification_And_Minus_CM0_thm,*) + birs_simplification_LSB0_And64_RV_thm, + birs_simplification_SignedLowCast3264_RV_thm, + + birs_simplification_IfThenElse_T_thm, + birs_simplification_IfThenElse_F_thm]@ + (CONJUNCTS birs_simplification_Mem_Match_64_8_thm)@ + (CONJUNCTS birs_simplification_Mem_Bypass_64_8_thm)(*@ + (CONJUNCTS birs_simplification_Mem_Match_32_8_thm)@ + (CONJUNCTS birs_simplification_Mem_Bypass_32_8_thm)*) + ); - fun birs_simp_repeat simp_inst_tm = - birs_simp_repeat_ (birs_simp_ID_fun simp_inst_tm); + val birs_simp_exp_subexp_thms = List.rev ( + [birs_simplification_UnsignedCast_thm, + birs_simplification_SignedCast_thm, + birs_simplification_LowCast_thm, + birs_simplification_Minus_left_thm, + birs_simplification_Plus_left_thm, + birs_simplification_Plus_right_thm, + birs_simplification_Load_addr_thm, + birs_simplification_Store_addr_thm] + ); + +(* ----------------------------------------------------------------------------------- *) + + val birs_simp_try_direct = + simp_try_list_gen [ + simp_try_fold_gen birs_simp_try_plain birs_simp_exp_plain_thms, + simp_try_fold_gen birs_simp_try_pcond birs_simp_exp_pcond_thms + ]; + + fun birs_simp_repeat simp_tm = + let + val simp_fun = simp_try_list_gen + [birs_simp_try_direct, + simp_try_fold_gen (birs_simp_try_subexp birs_simp_try_direct) birs_simp_exp_subexp_thms]; + in + simp_try_apply_gen (simp_try_repeat_gen simp_fun) simp_tm + end; + val birs_simp_repeat = Profile.profile "birs_simp_repeat" birs_simp_repeat; + fun birs_simp_load simp_tm = + let + (* TODO: constant propagation on the address, bypass as many stores as possible, try to match the load with a store *) + val load_thms = + (CONJUNCTS birs_simplification_Mem_Bypass_64_8_thm)@ + (CONJUNCTS birs_simplification_Mem_Match_64_8_thm); + val simp_fun_mem_load = simp_try_repeat_gen (simp_try_fold_gen birs_simp_try_pcond load_thms); + val cast_thms = + [birs_simplification_UnsignedCast_thm, + birs_simplification_SignedCast_thm, + birs_simplification_LowCast_thm]; + val simp_fun = simp_try_list_gen + [simp_try_fold_gen (birs_simp_try_subexp simp_fun_mem_load) cast_thms, + simp_fun_mem_load]; + val simp_thm = simp_try_apply_gen simp_fun simp_tm; + (*val _ = (print_term o get_rarg o concl) simp_thm;*) + in + simp_thm + end; + val birs_simp_load = Profile.profile "birs_simp_load" birs_simp_load; + fun birs_simp_store simp_tm = birs_simp_ID_fun simp_tm; (* constant propagation on the address/value, try to remove another store (only one) *) + val birs_simp_store = Profile.profile "birs_simp_store" birs_simp_store; + (*fun birs_simp_load simp_tm = birs_simp_repeat simp_tm;*) + fun birs_simp_store simp_tm = birs_simp_repeat simp_tm; + fun birs_simp_gen simp_tm = + let + val start_exp_tm = get_larg simp_tm; + open bir_expSyntax; + (* loads are more complicated, in this case we have a cast, and within there is a load *) + val isLoad = (fn t => is_BExp_Load t orelse (is_BExp_Cast t andalso (is_BExp_Load o (fn (_,x,_) => x) o dest_BExp_Cast) t)) start_exp_tm; + val isStore = (is_BExp_Store) start_exp_tm; + val _ = + if isLoad then print "simplifying a load\n" else + if isStore then print "simplifying a store\n" else + print "it is neither a load nor a store\n"; + in + if isLoad then birs_simp_load simp_tm else + if isStore then birs_simp_store simp_tm else + birs_simp_repeat simp_tm (* TODO: needs refactoring, bound the depth *) + end; (* val pcond = ````; diff --git a/src/tools/symbexec/birs_stepLib.sml b/src/tools/symbexec/birs_stepLib.sml index 6c98f286e..d29163234 100644 --- a/src/tools/symbexec/birs_stepLib.sml +++ b/src/tools/symbexec/birs_stepLib.sml @@ -681,7 +681,7 @@ val birs_symbval_concretizations_oracle_CONV = in if identical tm ((fst o dest_eq o concl) res_thm) - handle _ => raise ERR "birs_symbval_concretizations_oracle_CONV" "failed to resolve single jump target, not an equality theorem" + handle _ => (print_thm res_thm; raise ERR "birs_symbval_concretizations_oracle_CONV" "failed to resolve single jump target, not an equality theorem") then res_thm else raise ERR "birs_symbval_concretizations_oracle_CONV" "failed to resolve single jump target" end); @@ -987,6 +987,10 @@ val birs_eval_exp_CONV = birs_eval_exp_CONV; (* bir symbolic execution steps *) (* ----------------------------------------------- *) fun birs_exec_step_CONV_fun tm = + let + val last_pc = ref T; + val last_stmt = ref T; + val birs_step_thm = GEN_match_conv (is_birs_exec_step) (fn bstate_tm => ( @@ -994,6 +998,10 @@ fun birs_exec_step_CONV_fun tm = (fn tm_i => let + val (bprog_tm, st_i) = dest_birs_exec_step tm_i; + val (pc, _, _, _) = dest_birs_state st_i; + val _ = last_pc := pc; + val _ = last_stmt := (snd o dest_eq o concl o pc_lookup_fun) (bprog_tm, pc); (* TODO: avoid pc_lookup_fun twice *) val timer_exec_step = holba_miscLib.timer_start 0; (* TODO: optimize *) val birs_exec_thm = birs_exec_step_CONV tm_i; @@ -1006,6 +1014,9 @@ fun birs_exec_step_CONV_fun tm = ) bstate_tm ) tm; + in + (birs_step_thm, (!last_pc, !last_stmt)) + end; end (* local *) From 9b3f9079203764d701673a12295bc91de7ccc11b Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Fri, 27 Sep 2024 01:51:58 +0200 Subject: [PATCH 24/95] Add little performance tweak --- src/tools/symbexec/birs_driveLib.sml | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/tools/symbexec/birs_driveLib.sml b/src/tools/symbexec/birs_driveLib.sml index 3810fb914..5e29e61f3 100644 --- a/src/tools/symbexec/birs_driveLib.sml +++ b/src/tools/symbexec/birs_driveLib.sml @@ -28,9 +28,17 @@ val tm = ``<|bsst_pc := a; bsst_pcond := c|>``; *) fun birs_get_pc tm = - ((snd o dest_eq o concl o EVAL) ``(^tm).bsst_pc``); + let + val (pc, _, _, _) = dest_birs_state tm; + in + pc + end; fun birs_is_running tm = - identical ((snd o dest_eq o concl o EVAL) ``(^tm).bsst_status``) ``BST_Running``; + let + val (_, _, status, _) = dest_birs_state tm; + in + identical status bir_programSyntax.BST_Running_tm + end; datatype symbexec_tree_t = Symb_Node of (thm * (symbexec_tree_t list)); From f0f4dc9afd1ec54640ff2f130447bc899b184fd7 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Fri, 27 Sep 2024 16:08:31 +0200 Subject: [PATCH 25/95] Apply simplification conditionally, only after executing assignment statements --- src/tools/symbexec/bir_symbLib.sml | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/src/tools/symbexec/bir_symbLib.sml b/src/tools/symbexec/bir_symbLib.sml index 665a6593b..37ff27bb1 100644 --- a/src/tools/symbexec/bir_symbLib.sml +++ b/src/tools/symbexec/bir_symbLib.sml @@ -11,6 +11,18 @@ local open birs_driveLib; open birs_auxTheory; open bir_immSyntax; + + local + open bir_programSyntax; + open optionSyntax; + fun is_SOME_BStmtB_BStmt_Assign t = is_some t andalso (is_BStmtB o dest_some) t andalso (is_BStmt_Assign o dest_BStmtB o dest_some) t; + in + fun apply_if_assign tm f = + if is_SOME_BStmtB_BStmt_Assign tm then + f + else + I; + end in fun bir_symb_analysis bprog_tm birs_state_init_lbl @@ -36,7 +48,7 @@ fun bir_symb_analysis bprog_tm birs_state_init_lbl timer_symbanalysis_last := holba_miscLib.timer_start 0; (*print_term ((last o pairSyntax.strip_pair o snd o dest_comb o concl) t);*) t)) o - birs_rule_SUBST_trysimp_fun birs_rule_SUBST_thm o + apply_if_assign last_stmt (birs_rule_SUBST_trysimp_fun birs_rule_SUBST_thm) o birs_rule_tryprune_fun birs_rulesTheory.branch_prune1_spec_thm o birs_rule_tryprune_fun birs_rulesTheory.branch_prune2_spec_thm o birs_rule_tryjustassert_fun true From 165cca41081e49e5ec86391142c6e8b45b4ff629 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Fri, 27 Sep 2024 19:24:51 +0200 Subject: [PATCH 26/95] Add crude store-store simplification (usable for prototyping or similar) --- src/tools/symbexec/birs_simpLib.sml | 129 +++++++++++++++++++++++++--- 1 file changed, 118 insertions(+), 11 deletions(-) diff --git a/src/tools/symbexec/birs_simpLib.sml b/src/tools/symbexec/birs_simpLib.sml index 63dcb488d..3ea6e1b13 100644 --- a/src/tools/symbexec/birs_simpLib.sml +++ b/src/tools/symbexec/birs_simpLib.sml @@ -478,8 +478,84 @@ val simp_inst_tm = birs_simp_gen_term pcond bexp; birs_simplification_Store_addr_thm] ); +(* ----------------------------------------------------------------------------------- *) +(* +val (mexp1, stores1) = dest_BExp_Store_list bexp_stores []; +val bexp_stores_ = mk_BExp_Store_list (mexp1, stores1); +identical bexp_stores bexp_stores_; +*) + local + open bir_expSyntax; + in + fun dest_BExp_Store_list bexp acc = + if not (is_BExp_Store bexp) then + (bexp, acc) + else + let + val (expm, expad, endi, expv) = dest_BExp_Store bexp; + in + dest_BExp_Store_list expm ((expad, endi, expv)::acc) + end; + fun mk_BExp_Store_list (expm, []) = expm + | mk_BExp_Store_list (expm, (expad, endi, expv)::l) = + mk_BExp_Store_list (mk_BExp_Store (expm, expad, endi, expv), l); + end + +(* +val bexp_stores = `` + (BExp_Store + ^bexp_stores + (BExp_BinExp BIExp_Plus + (BExp_BinExp BIExp_Minus + (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) + (BExp_Const (Imm64 33w))) (BExp_Const (Imm64 25w))) + BEnd_LittleEndian + (BExp_Den (BVar "sy_x1" (BType_Imm Bit64)))) +``; +val (mexp1, stores1) = dest_BExp_Store_list bexp_stores []; +val store_to_check = List.last stores1; +val stores2 = List.take(stores1, List.length stores1 - 1); + +filter (not o stores_match pcond store_to_check) stores2 + +val bexp = bexp_stores; +val simp_tm = birs_simp_gen_term pcond bexp; +birs_simp_load simp_tm; +*) +local + open optionSyntax; + open bir_typing_expSyntax; + open bslSyntax; +in + fun get_type_of_bexp tm = + let + val thm = type_of_bir_exp_DIRECT_CONV (mk_type_of_bir_exp tm); + in + (dest_some o snd o dest_eq o concl) thm + end + handle _ => raise ERR "get_type_of_bexp" "not well-typed expression or other issue"; + + (* + val (expad1:term, endi1:term, expv1:term) = store_to_check; + *) + fun stores_match pcond store1 store2 = + let + val (expad1, endi1, expv1) = store1; + val (expad2, endi2, expv2) = store2; + val endi_eq = identical endi1 endi2; + val vsz_eq = identical (get_type_of_bexp expv1) (get_type_of_bexp expv2); + + val imp_bexp_tm = bor (bnot pcond, beq (expad1, expad2)); + val ad_is_eq = bir_smt_check_taut false imp_bexp_tm; + in + endi_eq andalso + vsz_eq andalso + ad_is_eq + end; +end (* ----------------------------------------------------------------------------------- *) + val birs_simp_try_direct = simp_try_list_gen [ simp_try_fold_gen birs_simp_try_plain birs_simp_exp_plain_thms, @@ -494,11 +570,11 @@ val simp_inst_tm = birs_simp_gen_term pcond bexp; in simp_try_apply_gen (simp_try_repeat_gen simp_fun) simp_tm end; - val birs_simp_repeat = Profile.profile "birs_simp_repeat" birs_simp_repeat; fun birs_simp_load simp_tm = let - (* TODO: constant propagation on the address, bypass as many stores as possible, try to match the load with a store *) + (* bypass as many stores as possible, try to match the load with a store *) + (* TODO: constant propagation on the address *) val load_thms = (CONJUNCTS birs_simplification_Mem_Bypass_64_8_thm)@ (CONJUNCTS birs_simplification_Mem_Match_64_8_thm); @@ -516,17 +592,44 @@ val simp_inst_tm = birs_simp_gen_term pcond bexp; simp_thm end; val birs_simp_load = Profile.profile "birs_simp_load" birs_simp_load; - fun birs_simp_store simp_tm = birs_simp_ID_fun simp_tm; (* constant propagation on the address/value, try to remove another store (only one) *) + + fun birs_simp_store simp_tm = + let + (* TODO: constant propagation on the address/value *) + (* try to remove another store (only one) *) + (* TODO: this implementation is only crude and not correct *) + open birsSyntax; + val (pcond_tm, symbexp_tm, _) = dest_birs_simplification simp_tm; + val (mexp, stores1) = dest_BExp_Store_list symbexp_tm []; + val store_to_check = List.last stores1; + val stores = List.take(stores1, List.length stores1 - 1); + val filtered_stores = filter (not o stores_match pcond_tm store_to_check) stores; + val symbexp_1_tm = mk_BExp_Store_list (mexp, filtered_stores@[store_to_check]); + val num_removed = List.length stores - List.length filtered_stores; + val _ = if num_removed = 0 then () else print ("removed stores: " ^ (Int.toString num_removed) ^ "\n"); + in + prove(mk_birs_simplification (pcond_tm, symbexp_tm, symbexp_1_tm), cheat) + end; val birs_simp_store = Profile.profile "birs_simp_store" birs_simp_store; - (*fun birs_simp_load simp_tm = birs_simp_repeat simp_tm;*) - fun birs_simp_store simp_tm = birs_simp_repeat simp_tm; + + fun birs_simp_regular simp_tm = birs_simp_repeat simp_tm; + val birs_simp_regular = Profile.profile "birs_simp_regular" birs_simp_regular; + + local + open bir_expSyntax; + in + (* loads are more complicated, in this case we have a cast, and within there is a load *) + fun is_load_tm_fun tm = is_BExp_Load tm orelse (is_BExp_Cast tm andalso (is_BExp_Load o (fn (_,x,_) => x) o dest_BExp_Cast) tm); + val is_store_tm_fun = is_BExp_Store; + end + + (*fun birs_simp_load simp_tm = birs_simp_regular simp_tm;*) + (*fun birs_simp_store simp_tm = birs_simp_regular simp_tm;*) fun birs_simp_gen simp_tm = let val start_exp_tm = get_larg simp_tm; - open bir_expSyntax; - (* loads are more complicated, in this case we have a cast, and within there is a load *) - val isLoad = (fn t => is_BExp_Load t orelse (is_BExp_Cast t andalso (is_BExp_Load o (fn (_,x,_) => x) o dest_BExp_Cast) t)) start_exp_tm; - val isStore = (is_BExp_Store) start_exp_tm; + val isLoad = is_load_tm_fun start_exp_tm; + val isStore = is_store_tm_fun start_exp_tm; val _ = if isLoad then print "simplifying a load\n" else if isStore then print "simplifying a store\n" else @@ -534,7 +637,7 @@ val simp_inst_tm = birs_simp_gen_term pcond bexp; in if isLoad then birs_simp_load simp_tm else if isStore then birs_simp_store simp_tm else - birs_simp_repeat simp_tm (* TODO: needs refactoring, bound the depth *) + birs_simp_regular simp_tm end; (* @@ -608,7 +711,7 @@ val bexp = ``(BExp_Load (BExp_Const (Imm64 32w))) (BExp_Const (Imm64 28w))) BEnd_LittleEndian Bit32)``; -val bexp = ``(BExp_Load +val bexp_stores = `` (BExp_Store (BExp_Store (BExp_Store @@ -678,6 +781,10 @@ val bexp = ``(BExp_Load BEnd_LittleEndian (BExp_Cast BIExp_LowCast (BExp_Const (Imm64 7w)) Bit32)) +``; +val bexp = bexp_stores; +val bexp = ``(BExp_Load + ^bexp_stores (BExp_BinExp BIExp_Minus (BExp_BinExp BIExp_Minus (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) From 661b759b80a38335d51491540cd344085f4aa826 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Fri, 27 Sep 2024 19:42:15 +0200 Subject: [PATCH 27/95] Disable crude cheat store-store simplification --- src/tools/symbexec/birs_simpLib.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tools/symbexec/birs_simpLib.sml b/src/tools/symbexec/birs_simpLib.sml index 3ea6e1b13..f49f67ef4 100644 --- a/src/tools/symbexec/birs_simpLib.sml +++ b/src/tools/symbexec/birs_simpLib.sml @@ -624,7 +624,7 @@ end end (*fun birs_simp_load simp_tm = birs_simp_regular simp_tm;*) - (*fun birs_simp_store simp_tm = birs_simp_regular simp_tm;*) + fun birs_simp_store simp_tm = birs_simp_regular simp_tm; fun birs_simp_gen simp_tm = let val start_exp_tm = get_larg simp_tm; From c852d32bbe492d6d6abf75c01e29d2445386728b Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Mon, 11 Mar 2024 11:31:43 +0100 Subject: [PATCH 28/95] Z3 version 4.13.0 test --- .github/workflows/build.yaml | 2 +- scripts/setup/env_config_gen.sh | 4 ++-- scripts/setup/install_z3.sh | 2 +- scripts/setup/install_z3_src.sh | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/.github/workflows/build.yaml b/.github/workflows/build.yaml index ceb1bdb54..b5c5b0deb 100644 --- a/.github/workflows/build.yaml +++ b/.github/workflows/build.yaml @@ -20,7 +20,7 @@ jobs: strategy: matrix: polyml: [{version: 'v5.7.1'}, {version: 'v5.9.1', heapless: '1'}] - z3: ['4.8.4'] + z3: ['4.13.0'] hol4: ['trindemossen-1'] env: diff --git a/scripts/setup/env_config_gen.sh b/scripts/setup/env_config_gen.sh index 1209f077b..80ae592c6 100755 --- a/scripts/setup/env_config_gen.sh +++ b/scripts/setup/env_config_gen.sh @@ -131,13 +131,13 @@ echo ####### HOLBA_Z3_DIR if [[ ( -z "${HOLBA_Z3_DIR}" ) || ( ! -z "${OPT_DIR_PARAM}" ) ]]; then - Z3_DIR="${HOLBA_OPT_DIR}/z3-4.8.4" + Z3_DIR="${HOLBA_OPT_DIR}/z3-4.13.0" if [[ -d "${Z3_DIR}/bin/python" ]]; then print_export_msg "HOLBA_Z3_DIR" export HOLBA_Z3_DIR="${Z3_DIR}" else # try the folder name for the version compiled from source - Z3_DIR="${HOLBA_OPT_DIR}/z3_4.8.4" + Z3_DIR="${HOLBA_OPT_DIR}/z3_4.13.0" if [[ -d "${Z3_DIR}/bin/python" ]]; then print_export_msg "HOLBA_Z3_DIR" export HOLBA_Z3_DIR=${Z3_DIR} diff --git a/scripts/setup/install_z3.sh b/scripts/setup/install_z3.sh index 4cc876ab1..ed50e4eb1 100755 --- a/scripts/setup/install_z3.sh +++ b/scripts/setup/install_z3.sh @@ -16,7 +16,7 @@ source "${SETUP_DIR}/env_config_gen.sh" "${OPT_DIR_PARAM}" ################################################################## # use a default z3 version if it is not specified in the environment -Z3_VERSION="4.8.4" +Z3_VERSION="4.13.0" if [[ ! -z "${HOLBA_Z3_VERSION}" ]]; then Z3_VERSION=${HOLBA_Z3_VERSION} fi diff --git a/scripts/setup/install_z3_src.sh b/scripts/setup/install_z3_src.sh index 320fce35d..dbaaa3348 100755 --- a/scripts/setup/install_z3_src.sh +++ b/scripts/setup/install_z3_src.sh @@ -16,7 +16,7 @@ source "${SETUP_DIR}/env_config_gen.sh" "${OPT_DIR_PARAM}" ################################################################## # use a default z3 version if it is not specified in the environment -Z3_VERSION="4.8.4" +Z3_VERSION="4.13.0" if [[ ! -z "${HOLBA_Z3_VERSION}" ]]; then Z3_VERSION=${HOLBA_Z3_VERSION} fi From 9fc3a4f185c7b4bb10134e014c1b0d8149f86fcf Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Mon, 11 Mar 2024 12:00:21 +0100 Subject: [PATCH 29/95] Z3 download link --- scripts/setup/install_z3.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scripts/setup/install_z3.sh b/scripts/setup/install_z3.sh index ed50e4eb1..b42e35103 100755 --- a/scripts/setup/install_z3.sh +++ b/scripts/setup/install_z3.sh @@ -21,7 +21,7 @@ if [[ ! -z "${HOLBA_Z3_VERSION}" ]]; then Z3_VERSION=${HOLBA_Z3_VERSION} fi -Z3_ASSET_SUFFIX=".d6df51951f4c-x64-debian-8.11.zip" +Z3_ASSET_SUFFIX="-x64-glibc-2.35.zip" if [[ ! -z "${HOLBA_Z3_ASSET_SUFFIX}" ]]; then Z3_ASSET_SUFFIX=${HOLBA_Z3_ASSET_SUFFIX} fi From 2ac727f5137022666c62734bd048a7e1420da68b Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Mon, 11 Mar 2024 14:10:36 +0100 Subject: [PATCH 30/95] Z3 file suffix in yaml --- .github/workflows/build.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/build.yaml b/.github/workflows/build.yaml index b5c5b0deb..a2f095936 100644 --- a/.github/workflows/build.yaml +++ b/.github/workflows/build.yaml @@ -27,7 +27,7 @@ jobs: HOLBA_POLYML_VERSION: ${{ matrix.polyml.version }} HOLBA_POLYML_HEAPLESS: ${{ matrix.polyml.heapless }} HOLBA_Z3_VERSION: ${{ matrix.z3 }} - HOLBA_Z3_ASSET_SUFFIX: '.d6df51951f4c-x64-debian-8.11.zip' + HOLBA_Z3_ASSET_SUFFIX: '-x64-glibc-2.35.zip' HOLBA_HOL4_VERSION: ${{ matrix.hol4 }} steps: From dbd9671ebde95a408c68b5ee658682bfff236f42 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Mon, 11 Mar 2024 14:40:53 +0100 Subject: [PATCH 31/95] Ubuntu version --- .github/workflows/build.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/build.yaml b/.github/workflows/build.yaml index a2f095936..98b0d0456 100644 --- a/.github/workflows/build.yaml +++ b/.github/workflows/build.yaml @@ -15,7 +15,7 @@ env: jobs: build: name: Build - runs-on: ubuntu-20.04 + runs-on: ubuntu-22.04 strategy: matrix: From 6e490354401a8857b959e1421261913ed62fc608 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Mon, 11 Mar 2024 14:52:23 +0100 Subject: [PATCH 32/95] Revert Ubuntu version, new Z3 suffix --- .github/workflows/build.yaml | 4 ++-- scripts/setup/install_z3.sh | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/build.yaml b/.github/workflows/build.yaml index 98b0d0456..7bf99642f 100644 --- a/.github/workflows/build.yaml +++ b/.github/workflows/build.yaml @@ -15,7 +15,7 @@ env: jobs: build: name: Build - runs-on: ubuntu-22.04 + runs-on: ubuntu-20.04 strategy: matrix: @@ -27,7 +27,7 @@ jobs: HOLBA_POLYML_VERSION: ${{ matrix.polyml.version }} HOLBA_POLYML_HEAPLESS: ${{ matrix.polyml.heapless }} HOLBA_Z3_VERSION: ${{ matrix.z3 }} - HOLBA_Z3_ASSET_SUFFIX: '-x64-glibc-2.35.zip' + HOLBA_Z3_ASSET_SUFFIX: '-x64-glibc-2.31.zip' HOLBA_HOL4_VERSION: ${{ matrix.hol4 }} steps: diff --git a/scripts/setup/install_z3.sh b/scripts/setup/install_z3.sh index b42e35103..27cdcaad4 100755 --- a/scripts/setup/install_z3.sh +++ b/scripts/setup/install_z3.sh @@ -21,7 +21,7 @@ if [[ ! -z "${HOLBA_Z3_VERSION}" ]]; then Z3_VERSION=${HOLBA_Z3_VERSION} fi -Z3_ASSET_SUFFIX="-x64-glibc-2.35.zip" +Z3_ASSET_SUFFIX="-x64-glibc-2.31.zip" if [[ ! -z "${HOLBA_Z3_ASSET_SUFFIX}" ]]; then Z3_ASSET_SUFFIX=${HOLBA_Z3_ASSET_SUFFIX} fi From ec256717f17101415fecacb7f40e08bee01e86e9 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Mon, 11 Mar 2024 15:52:46 +0100 Subject: [PATCH 33/95] Z3 4.12.2 --- .github/workflows/build.yaml | 2 +- scripts/setup/install_z3.sh | 2 +- scripts/setup/install_z3_src.sh | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/build.yaml b/.github/workflows/build.yaml index 7bf99642f..d0eddea56 100644 --- a/.github/workflows/build.yaml +++ b/.github/workflows/build.yaml @@ -20,7 +20,7 @@ jobs: strategy: matrix: polyml: [{version: 'v5.7.1'}, {version: 'v5.9.1', heapless: '1'}] - z3: ['4.13.0'] + z3: ['4.12.2'] hol4: ['trindemossen-1'] env: diff --git a/scripts/setup/install_z3.sh b/scripts/setup/install_z3.sh index 27cdcaad4..f5ca93789 100755 --- a/scripts/setup/install_z3.sh +++ b/scripts/setup/install_z3.sh @@ -16,7 +16,7 @@ source "${SETUP_DIR}/env_config_gen.sh" "${OPT_DIR_PARAM}" ################################################################## # use a default z3 version if it is not specified in the environment -Z3_VERSION="4.13.0" +Z3_VERSION="4.12.2" if [[ ! -z "${HOLBA_Z3_VERSION}" ]]; then Z3_VERSION=${HOLBA_Z3_VERSION} fi diff --git a/scripts/setup/install_z3_src.sh b/scripts/setup/install_z3_src.sh index dbaaa3348..f3287d005 100755 --- a/scripts/setup/install_z3_src.sh +++ b/scripts/setup/install_z3_src.sh @@ -16,7 +16,7 @@ source "${SETUP_DIR}/env_config_gen.sh" "${OPT_DIR_PARAM}" ################################################################## # use a default z3 version if it is not specified in the environment -Z3_VERSION="4.13.0" +Z3_VERSION="4.12.2" if [[ ! -z "${HOLBA_Z3_VERSION}" ]]; then Z3_VERSION=${HOLBA_Z3_VERSION} fi From 647488c0cb7977fd61627d3e58f8a539bec5d395 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Tue, 12 Mar 2024 00:33:03 +0100 Subject: [PATCH 34/95] Typo --- scripts/setup/env_config_gen.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/scripts/setup/env_config_gen.sh b/scripts/setup/env_config_gen.sh index 80ae592c6..ffdc87df6 100755 --- a/scripts/setup/env_config_gen.sh +++ b/scripts/setup/env_config_gen.sh @@ -131,13 +131,13 @@ echo ####### HOLBA_Z3_DIR if [[ ( -z "${HOLBA_Z3_DIR}" ) || ( ! -z "${OPT_DIR_PARAM}" ) ]]; then - Z3_DIR="${HOLBA_OPT_DIR}/z3-4.13.0" + Z3_DIR="${HOLBA_OPT_DIR}/z3-4.12.2" if [[ -d "${Z3_DIR}/bin/python" ]]; then print_export_msg "HOLBA_Z3_DIR" export HOLBA_Z3_DIR="${Z3_DIR}" else # try the folder name for the version compiled from source - Z3_DIR="${HOLBA_OPT_DIR}/z3_4.13.0" + Z3_DIR="${HOLBA_OPT_DIR}/z3_4.12.2" if [[ -d "${Z3_DIR}/bin/python" ]]; then print_export_msg "HOLBA_Z3_DIR" export HOLBA_Z3_DIR=${Z3_DIR} From 62c579b1f055e496ae622e9d1f90025898d3c4c7 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Thu, 22 Aug 2024 15:19:55 +0200 Subject: [PATCH 35/95] Enable prepackaged polyml --- .github/workflows/build.yaml | 7 ++++--- scripts/setup/install_hol4.sh | 13 +++++++++---- scripts/setup/install_poly.sh | 24 ++++++++++++++++++++++++ 3 files changed, 37 insertions(+), 7 deletions(-) diff --git a/.github/workflows/build.yaml b/.github/workflows/build.yaml index d0eddea56..16cda9493 100644 --- a/.github/workflows/build.yaml +++ b/.github/workflows/build.yaml @@ -15,11 +15,12 @@ env: jobs: build: name: Build - runs-on: ubuntu-20.04 + runs-on: ${{ matrix.os }} strategy: matrix: - polyml: [{version: 'v5.7.1'}, {version: 'v5.9.1', heapless: '1'}] + os: ['ubuntu-22.04'] + polyml: [{version: 'PREPACKAGED'}, {version: 'v5.9.1', heapless: '1'}] z3: ['4.12.2'] hol4: ['trindemossen-1'] @@ -40,7 +41,7 @@ jobs: with: path: | ${{ env.HOLBA_OPT_DIR }} - key: os-${{ runner.os }}_polyml-${{ matrix.polyml }}_z3-${{ matrix.z3 }}_hol4-${{ matrix.hol4 }} + key: os-${{ matrix.os }}_polyml-${{ matrix.polyml }}_z3-${{ matrix.z3 }}_hol4-${{ matrix.hol4 }} - name: Static analysis timeout-minutes: 5 diff --git a/scripts/setup/install_hol4.sh b/scripts/setup/install_hol4.sh index 00666f2fd..8afc748d6 100755 --- a/scripts/setup/install_hol4.sh +++ b/scripts/setup/install_hol4.sh @@ -21,10 +21,12 @@ if [[ ! -z "${HOLBA_POLYML_VERSION}" ]]; then POLY_VERSION=${HOLBA_POLYML_VERSION} fi -# make polyml binaries and libraries available -POLY_DIR=${HOLBA_OPT_DIR}/polyml_${POLY_VERSION} -export PATH=${POLY_DIR}/bin:$PATH -export LD_LIBRARY_PATH=${POLY_DIR}/lib:$LD_LIBRARY_PATH +if [[ ! "${POLY_VERSION}" == "PREPACKAGED" ]]; then + # make polyml binaries and libraries available + POLY_DIR=${HOLBA_OPT_DIR}/polyml_${POLY_VERSION} + export PATH=${POLY_DIR}/bin:$PATH + export LD_LIBRARY_PATH=${POLY_DIR}/lib:$LD_LIBRARY_PATH +fi # use a default hol4 version if it is not specified in the environment HOL4_VERSION="trindemossen-1" @@ -87,6 +89,9 @@ if [[ ! -d "${HOL4_DIR}" ]]; then fi # compile HOL4 + if [[ "${POLY_VERSION}" == "PREPACKAGED" ]]; then + echo "val polymllibdir = \"/usr/lib/x86_64-linux-gnu\";" > tools-poly/poly-includes.ML + fi poly < tools/smart-configure.sml bin/build --nograph fi diff --git a/scripts/setup/install_poly.sh b/scripts/setup/install_poly.sh index c6e937fa1..be61fc43a 100755 --- a/scripts/setup/install_poly.sh +++ b/scripts/setup/install_poly.sh @@ -36,6 +36,30 @@ POLY_DIR_SRC=${HOLBA_OPT_DIR}/polyml_${POLY_VERSION}_src ################################################################## +if [[ "${POLY_VERSION}" == "PREPACKAGED" ]]; then + # check if poly is available + POLY_CMD=$(which poly || echo "") + if [[ -z "${POLY_CMD}" ]]; then + echo "could not find poly, installing polyml now" + sudo apt install polyml libpolyml-dev + # check again after installing + POLY_CMD=$(which poly || echo "") + if [[ -z "${POLY_CMD}" ]]; then + echo "couldn't install poly" + exit 1 + fi + fi + echo ${POLY_CMD} + # try to run poly + POLY_VERSION_STR=$(poly -v) + echo "polyml is installed, version: ${POLY_VERSION_STR}" + # check if the version output is as expected + if [[ ! "${POLY_VERSION_STR}" =~ ^"Poly/ML " ]]; then + echo "something is wrong with the version string" + exit 2 + fi + exit 0 +fi # if the output directory exists, we already have a polyml in the cache if [[ -d "${POLY_DIR}" ]]; then From b12a4d254b521f70f1c01308572a6fd409cb0ae2 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Thu, 22 Aug 2024 16:01:52 +0200 Subject: [PATCH 36/95] Fix --- .github/workflows/build.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/build.yaml b/.github/workflows/build.yaml index 16cda9493..1cd764ebb 100644 --- a/.github/workflows/build.yaml +++ b/.github/workflows/build.yaml @@ -41,7 +41,7 @@ jobs: with: path: | ${{ env.HOLBA_OPT_DIR }} - key: os-${{ matrix.os }}_polyml-${{ matrix.polyml }}_z3-${{ matrix.z3 }}_hol4-${{ matrix.hol4 }} + key: os-${{ matrix.os }}_polyml-${{ matrix.polyml.version }}_z3-${{ matrix.z3 }}_hol4-${{ matrix.hol4 }} - name: Static analysis timeout-minutes: 5 From 1eba69c586a4c13182eb09eccff26ea8f61795e0 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Thu, 22 Aug 2024 11:08:23 +0200 Subject: [PATCH 37/95] Update to z3 version 4.13.0 --- .github/workflows/build.yaml | 4 ++-- scripts/setup/env_config_gen.sh | 4 ++-- scripts/setup/install_z3.sh | 4 ++-- scripts/setup/install_z3_src.sh | 2 +- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/.github/workflows/build.yaml b/.github/workflows/build.yaml index 1cd764ebb..3077c7533 100644 --- a/.github/workflows/build.yaml +++ b/.github/workflows/build.yaml @@ -21,14 +21,14 @@ jobs: matrix: os: ['ubuntu-22.04'] polyml: [{version: 'PREPACKAGED'}, {version: 'v5.9.1', heapless: '1'}] - z3: ['4.12.2'] + z3: ['4.13.0'] hol4: ['trindemossen-1'] env: HOLBA_POLYML_VERSION: ${{ matrix.polyml.version }} HOLBA_POLYML_HEAPLESS: ${{ matrix.polyml.heapless }} HOLBA_Z3_VERSION: ${{ matrix.z3 }} - HOLBA_Z3_ASSET_SUFFIX: '-x64-glibc-2.31.zip' + HOLBA_Z3_ASSET_SUFFIX: '-x64-glibc-2.35.zip' HOLBA_HOL4_VERSION: ${{ matrix.hol4 }} steps: diff --git a/scripts/setup/env_config_gen.sh b/scripts/setup/env_config_gen.sh index ffdc87df6..80ae592c6 100755 --- a/scripts/setup/env_config_gen.sh +++ b/scripts/setup/env_config_gen.sh @@ -131,13 +131,13 @@ echo ####### HOLBA_Z3_DIR if [[ ( -z "${HOLBA_Z3_DIR}" ) || ( ! -z "${OPT_DIR_PARAM}" ) ]]; then - Z3_DIR="${HOLBA_OPT_DIR}/z3-4.12.2" + Z3_DIR="${HOLBA_OPT_DIR}/z3-4.13.0" if [[ -d "${Z3_DIR}/bin/python" ]]; then print_export_msg "HOLBA_Z3_DIR" export HOLBA_Z3_DIR="${Z3_DIR}" else # try the folder name for the version compiled from source - Z3_DIR="${HOLBA_OPT_DIR}/z3_4.12.2" + Z3_DIR="${HOLBA_OPT_DIR}/z3_4.13.0" if [[ -d "${Z3_DIR}/bin/python" ]]; then print_export_msg "HOLBA_Z3_DIR" export HOLBA_Z3_DIR=${Z3_DIR} diff --git a/scripts/setup/install_z3.sh b/scripts/setup/install_z3.sh index f5ca93789..b42e35103 100755 --- a/scripts/setup/install_z3.sh +++ b/scripts/setup/install_z3.sh @@ -16,12 +16,12 @@ source "${SETUP_DIR}/env_config_gen.sh" "${OPT_DIR_PARAM}" ################################################################## # use a default z3 version if it is not specified in the environment -Z3_VERSION="4.12.2" +Z3_VERSION="4.13.0" if [[ ! -z "${HOLBA_Z3_VERSION}" ]]; then Z3_VERSION=${HOLBA_Z3_VERSION} fi -Z3_ASSET_SUFFIX="-x64-glibc-2.31.zip" +Z3_ASSET_SUFFIX="-x64-glibc-2.35.zip" if [[ ! -z "${HOLBA_Z3_ASSET_SUFFIX}" ]]; then Z3_ASSET_SUFFIX=${HOLBA_Z3_ASSET_SUFFIX} fi diff --git a/scripts/setup/install_z3_src.sh b/scripts/setup/install_z3_src.sh index f3287d005..dbaaa3348 100755 --- a/scripts/setup/install_z3_src.sh +++ b/scripts/setup/install_z3_src.sh @@ -16,7 +16,7 @@ source "${SETUP_DIR}/env_config_gen.sh" "${OPT_DIR_PARAM}" ################################################################## # use a default z3 version if it is not specified in the environment -Z3_VERSION="4.12.2" +Z3_VERSION="4.13.0" if [[ ! -z "${HOLBA_Z3_VERSION}" ]]; then Z3_VERSION=${HOLBA_Z3_VERSION} fi From eb73de25aaa3163dd4c496c0fa4d0b1c637a5296 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Fri, 27 Sep 2024 21:32:42 +0200 Subject: [PATCH 38/95] Fixes --- examples/riscv/aes/test-aes.sml | 2 +- src/tools/symbexec/birsSyntax.sml | 1 + src/tools/symbexec/examples/test-birs_compose.sml | 6 +++++- 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/examples/riscv/aes/test-aes.sml b/examples/riscv/aes/test-aes.sml index 9de6005d6..4bb6784e4 100644 --- a/examples/riscv/aes/test-aes.sml +++ b/examples/riscv/aes/test-aes.sml @@ -12,7 +12,7 @@ open aes_symb_execTheory; (* for now we just have a leightweight check; this is to include aes into the test *) val _ = print "checking aes_symb_analysis_thm:\n"; -val _ = if term_size (concl aes_symb_analysis_thm) = 23400 then () else +val _ = if term_size (concl aes_symb_analysis_thm) = 23407 then () else raise Fail "term size of aes symbolic execution theorem is not as expected"; val triple_tm = ((snd o dest_comb o concl) aes_symb_analysis_thm); diff --git a/src/tools/symbexec/birsSyntax.sml b/src/tools/symbexec/birsSyntax.sml index 2c1cb3158..306f68f8e 100644 --- a/src/tools/symbexec/birsSyntax.sml +++ b/src/tools/symbexec/birsSyntax.sml @@ -98,6 +98,7 @@ in end local + open bir_symb_simpTheory; fun syntax_fns n d m = HolKernel.syntax_fns {n = n, dest = d, make = m} "bir_symb_simp"; val syntax_fns3 = syntax_fns 3 HolKernel.dest_triop HolKernel.mk_triop; in diff --git a/src/tools/symbexec/examples/test-birs_compose.sml b/src/tools/symbexec/examples/test-birs_compose.sml index d0cd65f35..12fe17559 100644 --- a/src/tools/symbexec/examples/test-birs_compose.sml +++ b/src/tools/symbexec/examples/test-birs_compose.sml @@ -93,7 +93,11 @@ val bprog_tm = bprog; fun execute_two_steps bprog_tm birs_state_init_tm = let val birs_rule_STEP_thm = birs_rule_STEP_prog_fun (bir_prog_has_no_halt_fun bprog_tm); - val birs_rule_STEP_fun_spec = birs_rule_tryjustassert_fun false o birs_rule_STEP_fun birs_rule_STEP_thm; + + fun birs_post_step_fun (t, _) = ( + birs_rule_tryjustassert_fun false + ) t; + val birs_rule_STEP_fun_spec = birs_post_step_fun o birs_rule_STEP_fun birs_rule_STEP_thm; (* ........................... *) (* first step *) From 07830e7d22839bdcef1ffea61224e248ebee2522 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Fri, 27 Sep 2024 22:42:37 +0200 Subject: [PATCH 39/95] Make simplifications parameterizable Split simplification library into generic and specific --- examples/riscv/perftest/simpstress.sml | 2 +- src/tools/symbexec/bir_symbLib.sml | 2 +- src/tools/symbexec/birs_execLib.sml | 6 +- src/tools/symbexec/birs_simpLib.sml | 267 +---------------- src/tools/symbexec/birs_simp_instancesLib.sml | 270 ++++++++++++++++++ 5 files changed, 280 insertions(+), 267 deletions(-) create mode 100644 src/tools/symbexec/birs_simp_instancesLib.sml diff --git a/examples/riscv/perftest/simpstress.sml b/examples/riscv/perftest/simpstress.sml index 2ce541075..578cd0ded 100644 --- a/examples/riscv/perftest/simpstress.sml +++ b/examples/riscv/perftest/simpstress.sml @@ -7098,7 +7098,7 @@ val bprog_tm = (fst o dest_eq o concl) bir_aespart_prog_def; val birs_rule_STEP_thm = birs_rule_STEP_prog_fun (bir_prog_has_no_halt_fun bprog_tm); val birs_rule_SUBST_thm = birs_rule_SUBST_prog_fun bprog_tm; - val birs_simp_fun = birs_rule_SUBST_trysimp_fun birs_rule_SUBST_thm; + val birs_simp_fun = birs_rule_SUBST_trysimp_fun birs_rule_SUBST_thm birs_simp_instancesLib.birs_simp_default_riscv; local open bir_programSyntax; diff --git a/src/tools/symbexec/bir_symbLib.sml b/src/tools/symbexec/bir_symbLib.sml index 37ff27bb1..e1de2f456 100644 --- a/src/tools/symbexec/bir_symbLib.sml +++ b/src/tools/symbexec/bir_symbLib.sml @@ -48,7 +48,7 @@ fun bir_symb_analysis bprog_tm birs_state_init_lbl timer_symbanalysis_last := holba_miscLib.timer_start 0; (*print_term ((last o pairSyntax.strip_pair o snd o dest_comb o concl) t);*) t)) o - apply_if_assign last_stmt (birs_rule_SUBST_trysimp_fun birs_rule_SUBST_thm) o + apply_if_assign last_stmt (birs_rule_SUBST_trysimp_fun birs_rule_SUBST_thm birs_simp_instancesLib.birs_simp_default_riscv) o birs_rule_tryprune_fun birs_rulesTheory.branch_prune1_spec_thm o birs_rule_tryprune_fun birs_rulesTheory.branch_prune2_spec_thm o birs_rule_tryjustassert_fun true diff --git a/src/tools/symbexec/birs_execLib.sml b/src/tools/symbexec/birs_execLib.sml index 52032c0f4..9e5e7435a 100644 --- a/src/tools/symbexec/birs_execLib.sml +++ b/src/tools/symbexec/birs_execLib.sml @@ -264,7 +264,7 @@ fun birs_rule_SUBST_prog_fun bprog_tm = (* val single_step_prog_thm = result; *) -fun birs_rule_SUBST_trysimp_fun_ birs_rule_SUBST_thm single_step_prog_thm = +fun birs_rule_SUBST_trysimp_fun birs_rule_SUBST_thm birs_simp_fun single_step_prog_thm = let val assignment_thm_o = SOME (MATCH_MP birs_rule_SUBST_thm single_step_prog_thm) @@ -275,7 +275,7 @@ fun birs_rule_SUBST_trysimp_fun_ birs_rule_SUBST_thm single_step_prog_thm = val simp_tm = (fst o dest_imp o (*snd o strip_binder (SOME boolSyntax.universal) o*) concl o Q.SPEC `symbexp'`) assignment_thm; (*val _ = print_term simp_tm;*) val timer_exec_step_p3 = holba_miscLib.timer_start 0; - val simp_t = birs_simpLib.birs_simp_gen simp_tm; + val simp_t = birs_simp_fun simp_tm; (* TODO: need to remove the following line later and enable the simp function above *) (*val simp_t_o = NONE;*) val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n>>>>>> SUBST in " ^ delta_s ^ "\n")) timer_exec_step_p3; @@ -287,7 +287,7 @@ fun birs_rule_SUBST_trysimp_fun_ birs_rule_SUBST_thm single_step_prog_thm = SOME (simp_t, assignment_thm) => MATCH_MP assignment_thm simp_t | NONE => single_step_prog_thm end; -fun birs_rule_SUBST_trysimp_fun x = Profile.profile "birs_rule_SUBST_trysimp_fun" (birs_rule_SUBST_trysimp_fun_ x); +val birs_rule_SUBST_trysimp_fun = fn x => Profile.profile "birs_rule_SUBST_trysimp_fun" (birs_rule_SUBST_trysimp_fun x); end (* local *) diff --git a/src/tools/symbexec/birs_simpLib.sml b/src/tools/symbexec/birs_simpLib.sml index f49f67ef4..fac691680 100644 --- a/src/tools/symbexec/birs_simpLib.sml +++ b/src/tools/symbexec/birs_simpLib.sml @@ -72,18 +72,6 @@ in (* local *) (* ----------------------------------------------------------------------------------- *) (* try simplifying with the theorems of the list in order and return NONE or SOME simplification theorem *) -(* - fun simp_try_fold_fun_gen simp_try_fun (t, thm_o) = - if isSome thm_o then - thm_o - else - (* SOME (MATCH_MP simp_thm (try_inst t simp_thm)) *) - simp_try_fun (t, NONE) - (*handle _ => NONE*); - - fun simp_try_fold_gen simp_try_fun h_thms (simp_tm, simp_thm_o) = - List.foldl (fn (h_thm, simp_thm_o) => simp_try_fold_fun_gen (simp_try_fun h_thm) (simp_tm, simp_thm_o)) simp_thm_o h_thms; -*) fun simp_try_fold_gen simp_try_fun [] (_, simp_thm_o) = simp_thm_o | simp_try_fold_gen simp_try_fun (h_thm::h_thms) (simp_tm, simp_thm_o) = if isSome simp_thm_o then @@ -146,7 +134,7 @@ in (* local *) (* ----------------------------------------------------------------------------------- *) (* -val t = ASSUME `` +val instd_thm = ASSUME `` IS_SOME (type_of_bir_exp (BExp_IfThenElse @@ -167,13 +155,8 @@ val t = ASSUME `` (BExp_Const (Imm64 19w))) (BExp_Const (Imm64 1w))))) ==> (abcd) ``; -*) - - - -(* -val t = instd_thm; +birs_simp_try_fix_assumptions instd_thm; *) fun wrap_cache_result f = let @@ -244,7 +227,7 @@ val t = instd_thm; val _ = if isSome final_thm_o andalso (birsSyntax.is_birs_simplification o concl) (valOf final_thm_o) then () else raise ERR "birs_simp_try_fix_assumptions" "this should not happen"; in - (* Option.map (CONV_RULE (TRY_CONV (RAND_CONV EVAL) THENC REFL)) (* why was this here??*) *) final_thm_o + final_thm_o end; val birs_simp_try_fix_assumptions = Profile.profile "birs_simp_try_fix_assumptions" birs_simp_try_fix_assumptions; @@ -285,6 +268,8 @@ val t = instd_thm; (* val simp_t = birs_simplification_Plus_Plus_Const_thm; val simp_inst_tm = birs_simp_gen_term pcond bexp; + +birs_simp_try_inst simp_t simp_inst_tm; *) (* for the plain cases (not subexpression, not pcond implication) *) (* select only the operations because in case of plain theorems, the last operand is the symbexp' we are trying to find *) @@ -304,14 +289,12 @@ val simp_inst_tm = birs_simp_gen_term pcond bexp; let (* input term: birs_exp_imp *) (* ================================================= *) - (* TODO: function/code to remove imp assumption, with smt solver *) val pred1_tm = get_larg imp_tm; val pred2_tm = get_rarg imp_tm; val imp_bexp_tm = bslSyntax.bor (bslSyntax.bnot pred1_tm, pred2_tm); val imp_is_taut = bir_smt_check_taut false imp_bexp_tm; val imp_thm = if imp_is_taut then - (* SOME (prove(imp_tm, cheat)) *) mk_oracle_thm "BIRS_SIMP_LIB_Z3" ([], imp_tm) else ( (*print_term imp_tm;*) @@ -368,17 +351,11 @@ val simp_tm = birs_simp_gen_term pcond bexp; end handle _ => NONE; val birs_simp_try_pcond = fn h_thm => simp_try_make_option_fun (birs_simp_try_pcond h_thm); - - - (* val simp_inst_tm = birs_simp_gen_term pcond bexp; val abc = simp_try_fold_gen birs_simp_try_pcond birs_simp_exp_pcond_thms (simp_inst_tm, NONE); *) - - - (* "recursion" into certain subexpressions *) (* val simp_t = birs_simplification_Minus_thm; @@ -398,247 +375,13 @@ val simp_inst_tm = birs_simp_gen_term pcond bexp; end handle _ => NONE; val birs_simp_try_subexp = fn sub_simp_fun => fn simp_t => simp_try_make_option_fun (birs_simp_try_subexp sub_simp_fun simp_t); - (* val simp_inst_tm = birs_simp_gen_term pcond bexp; val abc = simp_try_fold_gen birs_simp_try_subexp birs_simp_exp_subexp_thms (simp_inst_tm, NONE); *) - (* TODO: need to keep simplifying using the three functions above repeatedly until not possible to simplify anymore *) - (* - try direct simplification *) - (* - try direct simplification in subexpressions *) - (* - repeat the above until can't find anything to simplify *) - - -(* - val simp_inst_tm = birs_simp_gen_term pcond bexp; - val pre_simp_thm = birs_simp_ID_fun simp_inst_tm; - birs_simp_repeat simp_inst_tm; -*) - - (* combination function of the two kinds above (direct simplification) *) - (* - try plain simplification *) - (* - try implied simplification *) -(* - val simp_inst_tm = birs_simp_gen_term pcond bexp; -*) -(* ----------------------------------------------------------------------------------- *) - -(* - 4 types of simplification functions, and recursive rinse&repeat - - plain (only basic assumptions as typing or some numbers or other basic equalities) - - pcond (starts out with basic assumptions, justify pcond implication with smt solver) - - direct (first try all plain, then try pcond) - - subexp (go into subexpression and then try direct, no recusion into subexpressions of subexpressions) - - recursive rinse&repeat - - try direct, then try subexp, one simplification = one iteration, repeat until no more possible - special treatment of store sequences, and load operations -*) - - val birs_simp_exp_plain_thms = List.rev ( - [birs_simplification_UnsignedCast_LowCast_Twice_thm, - - birs_simplification_Plus_Const64_thm, - - birs_simplification_Plus_Plus_Const64_thm, - birs_simplification_Minus_Plus_Const64_thm, - birs_simplification_Minus_Minus_Const64_thm, - birs_simplification_Plus_Minus_Const64_thm(*, - - birs_simplification_Plus_Plus_Const32_thm, - birs_simplification_Minus_Plus_Const32_thm, - birs_simplification_Minus_Minus_Const32_thm, - birs_simplification_Plus_Minus_Const32_thm*)] - ); - - val birs_simp_exp_pcond_thms = List.rev ( - [(*birs_simplification_And_Minus_CM0_thm,*) - birs_simplification_LSB0_And64_RV_thm, - birs_simplification_SignedLowCast3264_RV_thm, - - birs_simplification_IfThenElse_T_thm, - birs_simplification_IfThenElse_F_thm]@ - (CONJUNCTS birs_simplification_Mem_Match_64_8_thm)@ - (CONJUNCTS birs_simplification_Mem_Bypass_64_8_thm)(*@ - (CONJUNCTS birs_simplification_Mem_Match_32_8_thm)@ - (CONJUNCTS birs_simplification_Mem_Bypass_32_8_thm)*) - ); - - val birs_simp_exp_subexp_thms = List.rev ( - [birs_simplification_UnsignedCast_thm, - birs_simplification_SignedCast_thm, - birs_simplification_LowCast_thm, - birs_simplification_Minus_left_thm, - birs_simplification_Plus_left_thm, - birs_simplification_Plus_right_thm, - birs_simplification_Load_addr_thm, - birs_simplification_Store_addr_thm] - ); - -(* ----------------------------------------------------------------------------------- *) -(* -val (mexp1, stores1) = dest_BExp_Store_list bexp_stores []; -val bexp_stores_ = mk_BExp_Store_list (mexp1, stores1); -identical bexp_stores bexp_stores_; -*) - local - open bir_expSyntax; - in - fun dest_BExp_Store_list bexp acc = - if not (is_BExp_Store bexp) then - (bexp, acc) - else - let - val (expm, expad, endi, expv) = dest_BExp_Store bexp; - in - dest_BExp_Store_list expm ((expad, endi, expv)::acc) - end; - fun mk_BExp_Store_list (expm, []) = expm - | mk_BExp_Store_list (expm, (expad, endi, expv)::l) = - mk_BExp_Store_list (mk_BExp_Store (expm, expad, endi, expv), l); - end - -(* -val bexp_stores = `` - (BExp_Store - ^bexp_stores - (BExp_BinExp BIExp_Plus - (BExp_BinExp BIExp_Minus - (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) - (BExp_Const (Imm64 33w))) (BExp_Const (Imm64 25w))) - BEnd_LittleEndian - (BExp_Den (BVar "sy_x1" (BType_Imm Bit64)))) -``; -val (mexp1, stores1) = dest_BExp_Store_list bexp_stores []; -val store_to_check = List.last stores1; -val stores2 = List.take(stores1, List.length stores1 - 1); - -filter (not o stores_match pcond store_to_check) stores2 - -val bexp = bexp_stores; -val simp_tm = birs_simp_gen_term pcond bexp; -birs_simp_load simp_tm; -*) -local - open optionSyntax; - open bir_typing_expSyntax; - open bslSyntax; -in - fun get_type_of_bexp tm = - let - val thm = type_of_bir_exp_DIRECT_CONV (mk_type_of_bir_exp tm); - in - (dest_some o snd o dest_eq o concl) thm - end - handle _ => raise ERR "get_type_of_bexp" "not well-typed expression or other issue"; - - (* - val (expad1:term, endi1:term, expv1:term) = store_to_check; - *) - fun stores_match pcond store1 store2 = - let - val (expad1, endi1, expv1) = store1; - val (expad2, endi2, expv2) = store2; - val endi_eq = identical endi1 endi2; - val vsz_eq = identical (get_type_of_bexp expv1) (get_type_of_bexp expv2); - - val imp_bexp_tm = bor (bnot pcond, beq (expad1, expad2)); - val ad_is_eq = bir_smt_check_taut false imp_bexp_tm; - in - endi_eq andalso - vsz_eq andalso - ad_is_eq - end; -end -(* ----------------------------------------------------------------------------------- *) - - - val birs_simp_try_direct = - simp_try_list_gen [ - simp_try_fold_gen birs_simp_try_plain birs_simp_exp_plain_thms, - simp_try_fold_gen birs_simp_try_pcond birs_simp_exp_pcond_thms - ]; - - fun birs_simp_repeat simp_tm = - let - val simp_fun = simp_try_list_gen - [birs_simp_try_direct, - simp_try_fold_gen (birs_simp_try_subexp birs_simp_try_direct) birs_simp_exp_subexp_thms]; - in - simp_try_apply_gen (simp_try_repeat_gen simp_fun) simp_tm - end; - - fun birs_simp_load simp_tm = - let - (* bypass as many stores as possible, try to match the load with a store *) - (* TODO: constant propagation on the address *) - val load_thms = - (CONJUNCTS birs_simplification_Mem_Bypass_64_8_thm)@ - (CONJUNCTS birs_simplification_Mem_Match_64_8_thm); - val simp_fun_mem_load = simp_try_repeat_gen (simp_try_fold_gen birs_simp_try_pcond load_thms); - val cast_thms = - [birs_simplification_UnsignedCast_thm, - birs_simplification_SignedCast_thm, - birs_simplification_LowCast_thm]; - val simp_fun = simp_try_list_gen - [simp_try_fold_gen (birs_simp_try_subexp simp_fun_mem_load) cast_thms, - simp_fun_mem_load]; - val simp_thm = simp_try_apply_gen simp_fun simp_tm; - (*val _ = (print_term o get_rarg o concl) simp_thm;*) - in - simp_thm - end; - val birs_simp_load = Profile.profile "birs_simp_load" birs_simp_load; - - fun birs_simp_store simp_tm = - let - (* TODO: constant propagation on the address/value *) - (* try to remove another store (only one) *) - (* TODO: this implementation is only crude and not correct *) - open birsSyntax; - val (pcond_tm, symbexp_tm, _) = dest_birs_simplification simp_tm; - val (mexp, stores1) = dest_BExp_Store_list symbexp_tm []; - val store_to_check = List.last stores1; - val stores = List.take(stores1, List.length stores1 - 1); - val filtered_stores = filter (not o stores_match pcond_tm store_to_check) stores; - val symbexp_1_tm = mk_BExp_Store_list (mexp, filtered_stores@[store_to_check]); - val num_removed = List.length stores - List.length filtered_stores; - val _ = if num_removed = 0 then () else print ("removed stores: " ^ (Int.toString num_removed) ^ "\n"); - in - prove(mk_birs_simplification (pcond_tm, symbexp_tm, symbexp_1_tm), cheat) - end; - val birs_simp_store = Profile.profile "birs_simp_store" birs_simp_store; - - fun birs_simp_regular simp_tm = birs_simp_repeat simp_tm; - val birs_simp_regular = Profile.profile "birs_simp_regular" birs_simp_regular; - - local - open bir_expSyntax; - in - (* loads are more complicated, in this case we have a cast, and within there is a load *) - fun is_load_tm_fun tm = is_BExp_Load tm orelse (is_BExp_Cast tm andalso (is_BExp_Load o (fn (_,x,_) => x) o dest_BExp_Cast) tm); - val is_store_tm_fun = is_BExp_Store; - end - - (*fun birs_simp_load simp_tm = birs_simp_regular simp_tm;*) - fun birs_simp_store simp_tm = birs_simp_regular simp_tm; - fun birs_simp_gen simp_tm = - let - val start_exp_tm = get_larg simp_tm; - val isLoad = is_load_tm_fun start_exp_tm; - val isStore = is_store_tm_fun start_exp_tm; - val _ = - if isLoad then print "simplifying a load\n" else - if isStore then print "simplifying a store\n" else - print "it is neither a load nor a store\n"; - in - if isLoad then birs_simp_load simp_tm else - if isStore then birs_simp_store simp_tm else - birs_simp_regular simp_tm - end; (* val pcond = ````; diff --git a/src/tools/symbexec/birs_simp_instancesLib.sml b/src/tools/symbexec/birs_simp_instancesLib.sml new file mode 100644 index 000000000..39f189b54 --- /dev/null +++ b/src/tools/symbexec/birs_simp_instancesLib.sml @@ -0,0 +1,270 @@ +structure birs_simp_instancesLib = +struct + +local + + open HolKernel Parse boolLib bossLib; + open bir_exp_typecheckLib; + open bir_smtLib; + open birs_simpLib; + + open bir_symb_simpTheory; + + (* error handling *) + val libname = "bir_simp_instancesLib" + val ERR = Feedback.mk_HOL_ERR libname + val wrap_exn = Feedback.wrap_exn libname + +in (* local *) + +(* ----------------------------------------------------------------------------------- *) +(* ----------------------------------------------------------------------------------- *) +(* ----------------------------------------------------------------------------------- *) +(* +val (mexp1, stores1) = dest_BExp_Store_list bexp_stores []; +val bexp_stores_ = mk_BExp_Store_list (mexp1, stores1); +identical bexp_stores bexp_stores_; +*) + local + open bir_expSyntax; + in + fun dest_BExp_Store_list bexp acc = + if not (is_BExp_Store bexp) then + (bexp, acc) + else + let + val (expm, expad, endi, expv) = dest_BExp_Store bexp; + in + dest_BExp_Store_list expm ((expad, endi, expv)::acc) + end; + fun mk_BExp_Store_list (expm, []) = expm + | mk_BExp_Store_list (expm, (expad, endi, expv)::l) = + mk_BExp_Store_list (mk_BExp_Store (expm, expad, endi, expv), l); + end + +(* +val bexp_stores = `` + (BExp_Store + ^bexp_stores + (BExp_BinExp BIExp_Plus + (BExp_BinExp BIExp_Minus + (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) + (BExp_Const (Imm64 33w))) (BExp_Const (Imm64 25w))) + BEnd_LittleEndian + (BExp_Den (BVar "sy_x1" (BType_Imm Bit64)))) +``; +val (mexp1, stores1) = dest_BExp_Store_list bexp_stores []; +val store_to_check = List.last stores1; +val stores2 = List.take(stores1, List.length stores1 - 1); + +filter (not o stores_match pcond store_to_check) stores2 + +val bexp = bexp_stores; +val simp_tm = birs_simp_gen_term pcond bexp; +birs_simp_load simp_tm; +*) +local + open optionSyntax; + open bir_typing_expSyntax; + open bslSyntax; +in + fun get_type_of_bexp tm = + let + val thm = type_of_bir_exp_DIRECT_CONV (mk_type_of_bir_exp tm); + in + (dest_some o snd o dest_eq o concl) thm + end + handle _ => raise ERR "get_type_of_bexp" "not well-typed expression or other issue"; + + (* + val (expad1:term, endi1:term, expv1:term) = store_to_check; + *) + fun stores_match pcond store1 store2 = + let + val (expad1, endi1, expv1) = store1; + val (expad2, endi2, expv2) = store2; + val endi_eq = identical endi1 endi2; + val vsz_eq = identical (get_type_of_bexp expv1) (get_type_of_bexp expv2); + + val imp_bexp_tm = bor (bnot pcond, beq (expad1, expad2)); + val ad_is_eq = bir_smt_check_taut false imp_bexp_tm; + in + endi_eq andalso + vsz_eq andalso + ad_is_eq + end; +end + +fun birs_simp_store_cheater simp_tm = + let + (* TODO: constant propagation on the address/value *) + (* try to remove another store (only one) *) + (* TODO: this implementation is only crude and not correct *) + open birsSyntax; + val (pcond_tm, symbexp_tm, _) = dest_birs_simplification simp_tm; + val (mexp, stores1) = dest_BExp_Store_list symbexp_tm []; + val store_to_check = List.last stores1; + val stores = List.take(stores1, List.length stores1 - 1); + val filtered_stores = filter (not o stores_match pcond_tm store_to_check) stores; + val symbexp_1_tm = mk_BExp_Store_list (mexp, filtered_stores@[store_to_check]); + val num_removed = List.length stores - List.length filtered_stores; + val _ = if num_removed = 0 then () else print ("removed stores: " ^ (Int.toString num_removed) ^ "\n"); + in + prove(mk_birs_simplification (pcond_tm, symbexp_tm, symbexp_1_tm), cheat) + end; +(* ----------------------------------------------------------------------------------- *) +(* ----------------------------------------------------------------------------------- *) + +(* + 4 types of simplification functions, and recursive rinse&repeat + - plain (only basic assumptions as typing or some numbers or other basic equalities) + - pcond (starts out with basic assumptions, justify pcond implication with smt solver) + - direct (first try all plain, then try pcond) + - subexp (go into subexpression and then try direct, no recusion into subexpressions of subexpressions) + + recursive rinse&repeat + - try direct, then try subexp, one simplification = one iteration, repeat until no more possible + special treatment of store sequences, and load operations +*) + + val birs_simp_exp_plain_thms = List.rev ( + [birs_simplification_UnsignedCast_LowCast_Twice_thm, + + birs_simplification_Plus_Const64_thm, + + birs_simplification_Plus_Plus_Const64_thm, + birs_simplification_Minus_Plus_Const64_thm, + birs_simplification_Minus_Minus_Const64_thm, + birs_simplification_Plus_Minus_Const64_thm(*, + + birs_simplification_Plus_Plus_Const32_thm, + birs_simplification_Minus_Plus_Const32_thm, + birs_simplification_Minus_Minus_Const32_thm, + birs_simplification_Plus_Minus_Const32_thm*)] + ); + + val birs_simp_exp_pcond_thms = List.rev ( + [(*birs_simplification_And_Minus_CM0_thm,*) + birs_simplification_LSB0_And64_RV_thm, + birs_simplification_SignedLowCast3264_RV_thm, + + birs_simplification_IfThenElse_T_thm, + birs_simplification_IfThenElse_F_thm]@ + (CONJUNCTS birs_simplification_Mem_Match_64_8_thm)@ + (CONJUNCTS birs_simplification_Mem_Bypass_64_8_thm)(*@ + (CONJUNCTS birs_simplification_Mem_Match_32_8_thm)@ + (CONJUNCTS birs_simplification_Mem_Bypass_32_8_thm)*) + ); + + val birs_simp_exp_subexp_thms = List.rev ( + [birs_simplification_UnsignedCast_thm, + birs_simplification_SignedCast_thm, + birs_simplification_LowCast_thm, + birs_simplification_Minus_left_thm, + birs_simplification_Plus_left_thm, + birs_simplification_Plus_right_thm, + birs_simplification_Load_addr_thm, + birs_simplification_Store_addr_thm] + ); + + val simp_thms_tuple = (birs_simp_exp_plain_thms, birs_simp_exp_pcond_thms, birs_simp_exp_subexp_thms); + + val cast_thms = + [birs_simplification_UnsignedCast_thm, + birs_simplification_SignedCast_thm, + birs_simplification_LowCast_thm]; + val load_thms_tuple = + (CONJUNCTS birs_simplification_Mem_Bypass_64_8_thm, + CONJUNCTS birs_simplification_Mem_Match_64_8_thm, + cast_thms); + +(* ----------------------------------------------------------------------------------- *) + + (* combination function of the two kinds above (direct simplification) *) + (* - try plain simplification *) + (* - try implied simplification *) +(* + val simp_inst_tm = birs_simp_gen_term pcond bexp; +*) + fun birs_simp_try_direct (plain_thms, pcond_thms) = + simp_try_list_gen [ + simp_try_fold_gen birs_simp_try_plain plain_thms, + simp_try_fold_gen birs_simp_try_pcond pcond_thms + ]; + + (* TODO: need to keep simplifying using the three functions above repeatedly until not possible to simplify anymore *) + (* - try direct simplification *) + (* - try direct simplification in subexpressions *) + (* - repeat the above until can't find anything to simplify *) +(* + val simp_tm = birs_simp_gen_term pcond bexp; + birs_simp_repeat (birs_simp_exp_plain_thms, birs_simp_exp_pcond_thms, birs_simp_exp_subexp_thms) simp_tm; +*) + fun birs_simp_repeat (plain_thms, pcond_thms, subexp_thms) simp_tm = + let + val direct_simp_fun = birs_simp_try_direct (plain_thms, pcond_thms); + val simp_fun = simp_try_list_gen + [direct_simp_fun, + simp_try_fold_gen (birs_simp_try_subexp direct_simp_fun) subexp_thms]; + in + simp_try_apply_gen (simp_try_repeat_gen simp_fun) simp_tm + end; + + fun birs_simp_regular simp_thms_tuple simp_tm = birs_simp_repeat simp_thms_tuple simp_tm; + val birs_simp_regular = fn x => Profile.profile "birs_simp_regular" (birs_simp_regular x); + + fun birs_simp_load (bypass_thms, match_thms, subexp_thms) simp_tm = + let + (* bypass as many stores as possible, try to match the load with a store *) + (* TODO: constant propagation on the address *) + val simp_fun_mem_load = simp_try_repeat_gen (simp_try_fold_gen birs_simp_try_pcond (bypass_thms@match_thms)); + val simp_fun = simp_try_list_gen + [simp_try_fold_gen (birs_simp_try_subexp simp_fun_mem_load) subexp_thms, + simp_fun_mem_load]; + val simp_thm = simp_try_apply_gen simp_fun simp_tm; + (*val _ = (print_term o get_rarg o concl) simp_thm;*) + in + simp_thm + end; + val birs_simp_load = fn x => Profile.profile "birs_simp_load" (birs_simp_load x); + + fun birs_simp_store simp_tm = birs_simp_store_cheater simp_tm; + val birs_simp_store = Profile.profile "birs_simp_store" birs_simp_store; + + local + open bir_expSyntax; + in + (* loads are more complicated, in this case we have a cast, and within there is a load *) + fun is_load_tm_fun tm = is_BExp_Load tm orelse (is_BExp_Cast tm andalso (is_BExp_Load o (fn (_,x,_) => x) o dest_BExp_Cast) tm); + val is_store_tm_fun = is_BExp_Store; + end + + fun birs_simp_gen simp_tm = + let + val start_exp_tm = get_larg simp_tm; + val use_store_cheater = false; + + val simp_apply_fun = + if is_load_tm_fun start_exp_tm then ( + print "simplifying a load\n"; + birs_simp_load load_thms_tuple + ) else if is_store_tm_fun start_exp_tm then ( + print "simplifying a store\n"; + if use_store_cheater then + birs_simp_store + else + birs_simp_regular simp_thms_tuple + ) else ( + print "it is neither a load nor a store\n"; + birs_simp_regular simp_thms_tuple + ); + in + simp_apply_fun simp_tm + end; + + val birs_simp_default_riscv = + birs_simp_gen; + +end (* local *) + +end (* struct *) From 5b5c083f8c0f9fa61b82af8d462a30a2f2b592be Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Fri, 27 Sep 2024 23:07:30 +0200 Subject: [PATCH 40/95] Prepare architecture specific simplifications --- src/tools/symbexec/birs_simp_instancesLib.sml | 162 ++++++++++++------ 1 file changed, 106 insertions(+), 56 deletions(-) diff --git a/src/tools/symbexec/birs_simp_instancesLib.sml b/src/tools/symbexec/birs_simp_instancesLib.sml index 39f189b54..8b90ebf83 100644 --- a/src/tools/symbexec/birs_simp_instancesLib.sml +++ b/src/tools/symbexec/birs_simp_instancesLib.sml @@ -17,9 +17,6 @@ local in (* local *) -(* ----------------------------------------------------------------------------------- *) -(* ----------------------------------------------------------------------------------- *) -(* ----------------------------------------------------------------------------------- *) (* val (mexp1, stores1) = dest_BExp_Store_list bexp_stores []; val bexp_stores_ = mk_BExp_Store_list (mexp1, stores1); @@ -127,57 +124,6 @@ fun birs_simp_store_cheater simp_tm = special treatment of store sequences, and load operations *) - val birs_simp_exp_plain_thms = List.rev ( - [birs_simplification_UnsignedCast_LowCast_Twice_thm, - - birs_simplification_Plus_Const64_thm, - - birs_simplification_Plus_Plus_Const64_thm, - birs_simplification_Minus_Plus_Const64_thm, - birs_simplification_Minus_Minus_Const64_thm, - birs_simplification_Plus_Minus_Const64_thm(*, - - birs_simplification_Plus_Plus_Const32_thm, - birs_simplification_Minus_Plus_Const32_thm, - birs_simplification_Minus_Minus_Const32_thm, - birs_simplification_Plus_Minus_Const32_thm*)] - ); - - val birs_simp_exp_pcond_thms = List.rev ( - [(*birs_simplification_And_Minus_CM0_thm,*) - birs_simplification_LSB0_And64_RV_thm, - birs_simplification_SignedLowCast3264_RV_thm, - - birs_simplification_IfThenElse_T_thm, - birs_simplification_IfThenElse_F_thm]@ - (CONJUNCTS birs_simplification_Mem_Match_64_8_thm)@ - (CONJUNCTS birs_simplification_Mem_Bypass_64_8_thm)(*@ - (CONJUNCTS birs_simplification_Mem_Match_32_8_thm)@ - (CONJUNCTS birs_simplification_Mem_Bypass_32_8_thm)*) - ); - - val birs_simp_exp_subexp_thms = List.rev ( - [birs_simplification_UnsignedCast_thm, - birs_simplification_SignedCast_thm, - birs_simplification_LowCast_thm, - birs_simplification_Minus_left_thm, - birs_simplification_Plus_left_thm, - birs_simplification_Plus_right_thm, - birs_simplification_Load_addr_thm, - birs_simplification_Store_addr_thm] - ); - - val simp_thms_tuple = (birs_simp_exp_plain_thms, birs_simp_exp_pcond_thms, birs_simp_exp_subexp_thms); - - val cast_thms = - [birs_simplification_UnsignedCast_thm, - birs_simplification_SignedCast_thm, - birs_simplification_LowCast_thm]; - val load_thms_tuple = - (CONJUNCTS birs_simplification_Mem_Bypass_64_8_thm, - CONJUNCTS birs_simplification_Mem_Match_64_8_thm, - cast_thms); - (* ----------------------------------------------------------------------------------- *) (* combination function of the two kinds above (direct simplification) *) @@ -239,7 +185,7 @@ fun birs_simp_store_cheater simp_tm = val is_store_tm_fun = is_BExp_Store; end - fun birs_simp_gen simp_tm = + fun birs_simp_gen simp_thms_tuple load_thms_tuple simp_tm = let val start_exp_tm = get_larg simp_tm; val use_store_cheater = false; @@ -262,8 +208,112 @@ fun birs_simp_store_cheater simp_tm = simp_apply_fun simp_tm end; +(* ----------------------------------------------------------------------------------- *) + + fun plain_thms include_64 include_32 = + (if include_64 then + [birs_simplification_Plus_Minus_Const64_thm, + birs_simplification_Minus_Minus_Const64_thm, + birs_simplification_Minus_Plus_Const64_thm, + birs_simplification_Plus_Plus_Const64_thm] + else + [])@ + (if include_32 then + [birs_simplification_Plus_Minus_Const32_thm, + birs_simplification_Minus_Minus_Const32_thm, + birs_simplification_Minus_Plus_Const32_thm, + birs_simplification_Plus_Plus_Const32_thm] + else + [])@ + [birs_simplification_Plus_Const64_thm, + birs_simplification_UnsignedCast_LowCast_Twice_thm]; + + fun pcond_thms mem_64 mem_32 riscv cm0 = + (if mem_64 then + (CONJUNCTS birs_simplification_Mem_Bypass_64_8_thm)@ + (CONJUNCTS birs_simplification_Mem_Match_64_8_thm) + else + [])@ + (if mem_32 then + (CONJUNCTS birs_simplification_Mem_Bypass_32_8_thm)@ + (CONJUNCTS birs_simplification_Mem_Match_32_8_thm) + else + [])@ + [birs_simplification_IfThenElse_T_thm, + birs_simplification_IfThenElse_F_thm]@ + (if riscv then + [birs_simplification_SignedLowCast3264_RV_thm, + birs_simplification_LSB0_And64_RV_thm] + else + [])@ + (if cm0 then + [birs_simplification_And_Minus_CM0_thm] + else + []); + + val subexp_cast_thms = + [birs_simplification_LowCast_thm, + birs_simplification_SignedCast_thm, + birs_simplification_UnsignedCast_thm]; + + val subexp_thms = + [birs_simplification_Store_addr_thm, + birs_simplification_Load_addr_thm, + birs_simplification_Plus_right_thm, + birs_simplification_Plus_left_thm, + birs_simplification_Minus_left_thm]@ + subexp_cast_thms; + +(* ----------------------------------------------------------------------------------- *) + + fun simp_thms_tuple include_64 include_32 mem_64 mem_32 riscv cm0 = (plain_thms include_64 include_32, pcond_thms mem_64 mem_32 riscv cm0, subexp_thms); + + fun load_thms_tuple mem_64 mem_32 = + ((if mem_64 then + CONJUNCTS birs_simplification_Mem_Bypass_64_8_thm + else + [])@ + (if mem_32 then + CONJUNCTS birs_simplification_Mem_Bypass_32_8_thm + else + []), + (if mem_64 then + CONJUNCTS birs_simplification_Mem_Match_64_8_thm + else + [])@ + (if mem_32 then + CONJUNCTS birs_simplification_Mem_Match_32_8_thm + else + []), + subexp_cast_thms); + val birs_simp_default_riscv = - birs_simp_gen; + let + val include_64 = true; + val include_32 = false; + val mem_64 = true; + val mem_32 = false; + val riscv = true; + val cm0 = false; + in + birs_simp_gen + (simp_thms_tuple include_64 include_32 mem_64 mem_32 riscv cm0) + (load_thms_tuple mem_64 mem_32) + end; + + val birs_simp_default_armcm0 = + let + val include_64 = true; + val include_32 = true; + val mem_64 = false; + val mem_32 = true; + val riscv = false; + val cm0 = true; + in + birs_simp_gen + (simp_thms_tuple include_64 include_32 mem_64 mem_32 riscv cm0) + (load_thms_tuple mem_64 mem_32) + end; end (* local *) From 7dde07dbb45b5e9139a07e8b38442cea7cc92521 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Fri, 27 Sep 2024 23:20:27 +0200 Subject: [PATCH 41/95] Fix profile function wrapping --- src/tools/symbexec/birs_execLib.sml | 12 ++++++------ src/tools/symbexec/birs_stepLib.sml | 4 ++-- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/tools/symbexec/birs_execLib.sml b/src/tools/symbexec/birs_execLib.sml index 9e5e7435a..77e7e2e4f 100644 --- a/src/tools/symbexec/birs_execLib.sml +++ b/src/tools/symbexec/birs_execLib.sml @@ -56,7 +56,7 @@ fun birs_rule_STEP_prog_fun no_halt_thm = local open birs_auxTheory; in -fun birs_rule_STEP_fun_ birs_rule_STEP_thm bstate_tm = +fun birs_rule_STEP_fun birs_rule_STEP_thm bstate_tm = let val step1_thm = SPEC bstate_tm birs_rule_STEP_thm; val (step2_thm, extra_info) = birs_exec_step_CONV_fun (concl step1_thm); @@ -79,7 +79,7 @@ fun birs_rule_STEP_fun_ birs_rule_STEP_thm bstate_tm = (single_step_prog_thm, extra_info) end; end; -fun birs_rule_STEP_fun x = Profile.profile "birs_rule_STEP_fun" (birs_rule_STEP_fun_ x); +val birs_rule_STEP_fun = fn x => Profile.profile "birs_rule_STEP_fun" (birs_rule_STEP_fun x); @@ -135,7 +135,7 @@ local val birs_pcondinf_tm = ``birs_pcondinf``; in -fun birs_rule_tryjustassert_fun_ force_assert_justify single_step_prog_thm = +fun birs_rule_tryjustassert_fun force_assert_justify single_step_prog_thm = let (* val single_step_prog_thm = birs_rule_STEP_fun birs_rule_STEP_thm bprog_tm bstate_tm; @@ -174,9 +174,9 @@ fun birs_rule_tryjustassert_fun_ force_assert_justify single_step_prog_thm = end | _ => single_step_prog_thm end; -fun birs_rule_tryjustassert_fun x = Profile.profile "birs_rule_tryjustassert_fun" (birs_rule_tryjustassert_fun_ x); +val birs_rule_tryjustassert_fun = fn x => Profile.profile "birs_rule_tryjustassert_fun" (birs_rule_tryjustassert_fun x); -fun birs_rule_tryprune_fun_ prune_thm single_step_prog_thm = +fun birs_rule_tryprune_fun prune_thm single_step_prog_thm = let (* val _ = print "try prune now \n"; *) val continue_thm_o_1 = @@ -215,7 +215,7 @@ fun birs_rule_tryprune_fun_ prune_thm single_step_prog_thm = | _ => single_step_prog_thm end; end; -fun birs_rule_tryprune_fun x = Profile.profile "birs_rule_tryprune_fun" (birs_rule_tryprune_fun_ x); +val birs_rule_tryprune_fun = fn x => Profile.profile "birs_rule_tryprune_fun" (birs_rule_tryprune_fun x); (* stepping a sound structure, try to simplify after assignment *) diff --git a/src/tools/symbexec/birs_stepLib.sml b/src/tools/symbexec/birs_stepLib.sml index d29163234..ab88a5880 100644 --- a/src/tools/symbexec/birs_stepLib.sml +++ b/src/tools/symbexec/birs_stepLib.sml @@ -562,13 +562,13 @@ val birs_state_ss = rewrites (type_rws ``:birs_state_t``); (* ---------------------------------------------------------------------------- *) -fun birs_senv_typecheck_CONV_ eq_thms = ( +fun birs_senv_typecheck_CONV eq_thms = ( RESTR_EVAL_CONV [bir_typing_expSyntax.type_of_bir_exp_tm] THENC REWRITE_CONV eq_thms THENC GEN_match_conv (bir_typing_expSyntax.is_type_of_bir_exp) (type_of_bir_exp_DIRECT_CONV) THENC EVAL ); -fun birs_senv_typecheck_CONV x = Profile.profile "senv_typecheck_CONV" (birs_senv_typecheck_CONV_ x); +val birs_senv_typecheck_CONV = fn x => Profile.profile "senv_typecheck_CONV" (birs_senv_typecheck_CONV x); (* From 6961d0633d974daec04d6dbdf381eb41c8105b0a Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sun, 29 Sep 2024 11:33:54 +0200 Subject: [PATCH 42/95] Refactor reusable caching function --- src/tools/symbexec/aux_moveawayLib.sml | 42 +++++++++++++++++++++ src/tools/symbexec/bir_exp_typecheckLib.sml | 6 +-- src/tools/symbexec/birs_simpLib.sml | 27 +------------ 3 files changed, 45 insertions(+), 30 deletions(-) create mode 100644 src/tools/symbexec/aux_moveawayLib.sml diff --git a/src/tools/symbexec/aux_moveawayLib.sml b/src/tools/symbexec/aux_moveawayLib.sml new file mode 100644 index 000000000..bb0b4b081 --- /dev/null +++ b/src/tools/symbexec/aux_moveawayLib.sml @@ -0,0 +1,42 @@ +structure aux_moveawayLib = +struct + +local + +open HolKernel Parse boolLib bossLib; + +in (* local *) + + fun result_cache kcomp = + let + val d = ref (Redblackmap.mkDict kcomp); + fun add (k, v) = d := Redblackmap.insert (!d, k, v); + fun lookup k = + SOME (Redblackmap.find (!d, k)) + handle NotFound => NONE; + in + (add, lookup) + end; + + fun wrap_cache_result kcomp f = + let + val (add, lookup) = result_cache kcomp; + fun f_wrapped k = + let + val v_o = lookup k; + in + if isSome v_o then valOf v_o else + let + val v = f k; + in + add (k, v); + v + end + end; + in + f_wrapped + end; + +end (* local *) + +end (* struct *) diff --git a/src/tools/symbexec/bir_exp_typecheckLib.sml b/src/tools/symbexec/bir_exp_typecheckLib.sml index ae9ab3de3..9dbd1f0f6 100644 --- a/src/tools/symbexec/bir_exp_typecheckLib.sml +++ b/src/tools/symbexec/bir_exp_typecheckLib.sml @@ -72,11 +72,7 @@ in (* local *) end handle _ => raise ERR "type_of_bir_exp_CONV" "conversion failed"; - val typecheck_dict = ref ((Redblackmap.mkDict Term.compare) : (term, thm) Redblackmap.dict); - fun typecheck_add (k_tm, tc_thm) = typecheck_dict := Redblackmap.insert (!typecheck_dict, k_tm, tc_thm); - fun typecheck_lookup k_tm = - SOME (Redblackmap.find (!typecheck_dict, k_tm)) - handle NotFound => NONE; + val (typecheck_add, typecheck_lookup) = aux_moveawayLib.result_cache Term.compare; fun check_typeof thm = let diff --git a/src/tools/symbexec/birs_simpLib.sml b/src/tools/symbexec/birs_simpLib.sml index fac691680..58cdd3247 100644 --- a/src/tools/symbexec/birs_simpLib.sml +++ b/src/tools/symbexec/birs_simpLib.sml @@ -158,29 +158,6 @@ val instd_thm = ASSUME `` birs_simp_try_fix_assumptions instd_thm; *) - fun wrap_cache_result f = - let - val assumption_dict = ref (Redblackmap.mkDict Term.compare); - fun assumption_add (k_tm, tc_thm) = assumption_dict := Redblackmap.insert (!assumption_dict, k_tm, tc_thm); - fun assumption_lookup k_tm = - SOME (Redblackmap.find (!assumption_dict, k_tm)) - handle NotFound => NONE; - fun f_wrapped tm = - let - val a_thm_o = assumption_lookup tm; - in - if isSome a_thm_o then valOf a_thm_o else - let - val a_thm = f tm; - in - assumption_add (tm, a_thm); - a_thm - end - end; - in - f_wrapped - end; - fun birs_simp_try_justify_assumption assmpt = let val type_ofbirexp_CONV = GEN_match_conv (bir_typing_expSyntax.is_type_of_bir_exp) (type_of_bir_exp_DIRECT_CONV); @@ -201,7 +178,7 @@ birs_simp_try_fix_assumptions instd_thm; NONE end handle _ => NONE; - val birs_simp_try_justify_assumption = wrap_cache_result birs_simp_try_justify_assumption; + val birs_simp_try_justify_assumption = aux_moveawayLib.wrap_cache_result Term.compare birs_simp_try_justify_assumption; (* need to handle typecheck, IS_SOME typecheck *) fun birs_simp_try_justify_assumptions NONE = NONE @@ -305,7 +282,7 @@ birs_simp_try_inst simp_t simp_inst_tm; SOME imp_thm end handle _ => NONE; - val check_imp_tm = wrap_cache_result check_imp_tm; + val check_imp_tm = aux_moveawayLib.wrap_cache_result Term.compare check_imp_tm; From c6477d91ea484587a219d48fe4b631864972da98 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sun, 29 Sep 2024 11:57:50 +0200 Subject: [PATCH 43/95] Allow usage of speedy cheating store-store simplifications --- examples/riscv/aes-unopt/aes_symb_execScript.sml | 3 +++ src/tools/symbexec/bir_symbLib.sig | 2 ++ src/tools/symbexec/bir_symbLib.sml | 5 ++++- src/tools/symbexec/birs_simp_instancesLib.sml | 12 ++++++++---- 4 files changed, 17 insertions(+), 5 deletions(-) diff --git a/examples/riscv/aes-unopt/aes_symb_execScript.sml b/examples/riscv/aes-unopt/aes_symb_execScript.sml index e552f87b8..77bddf9f5 100644 --- a/examples/riscv/aes-unopt/aes_symb_execScript.sml +++ b/examples/riscv/aes-unopt/aes_symb_execScript.sml @@ -19,6 +19,9 @@ val _ = birs_auxLib.prepare_program_lookups bir_lift_thm; (* Symbolic analysis execution *) (* --------------------------- *) +(* turn on the store-store cheater *) +val _ = birs_simp_select := birs_simp_instancesLib.birs_simp_default_riscv_gen true; + val (bsysprecond_thm, symb_analysis_thm) = bir_symb_analysis_thm bir_aes_prog_def diff --git a/src/tools/symbexec/bir_symbLib.sig b/src/tools/symbexec/bir_symbLib.sig index 807739c71..68bb27788 100644 --- a/src/tools/symbexec/bir_symbLib.sig +++ b/src/tools/symbexec/bir_symbLib.sig @@ -3,6 +3,8 @@ sig include Abbrev; + val birs_simp_select : (term -> thm) ref; + val bir_symb_analysis : term -> term -> term list -> term -> term -> thm; val bir_symb_analysis_thm : thm -> thm -> thm list -> thm -> thm -> thm * thm; diff --git a/src/tools/symbexec/bir_symbLib.sml b/src/tools/symbexec/bir_symbLib.sml index e1de2f456..508bfa35c 100644 --- a/src/tools/symbexec/bir_symbLib.sml +++ b/src/tools/symbexec/bir_symbLib.sml @@ -25,6 +25,9 @@ local end in +(* TODO: later make the whole post step function a parameter to the symb_analysis function *) +val birs_simp_select = ref birs_simp_instancesLib.birs_simp_default_riscv; + fun bir_symb_analysis bprog_tm birs_state_init_lbl birs_end_lbls birs_env birs_pcond = let @@ -48,7 +51,7 @@ fun bir_symb_analysis bprog_tm birs_state_init_lbl timer_symbanalysis_last := holba_miscLib.timer_start 0; (*print_term ((last o pairSyntax.strip_pair o snd o dest_comb o concl) t);*) t)) o - apply_if_assign last_stmt (birs_rule_SUBST_trysimp_fun birs_rule_SUBST_thm birs_simp_instancesLib.birs_simp_default_riscv) o + apply_if_assign last_stmt (birs_rule_SUBST_trysimp_fun birs_rule_SUBST_thm (!birs_simp_select)) o birs_rule_tryprune_fun birs_rulesTheory.branch_prune1_spec_thm o birs_rule_tryprune_fun birs_rulesTheory.branch_prune2_spec_thm o birs_rule_tryjustassert_fun true diff --git a/src/tools/symbexec/birs_simp_instancesLib.sml b/src/tools/symbexec/birs_simp_instancesLib.sml index 8b90ebf83..df0175eff 100644 --- a/src/tools/symbexec/birs_simp_instancesLib.sml +++ b/src/tools/symbexec/birs_simp_instancesLib.sml @@ -185,10 +185,9 @@ fun birs_simp_store_cheater simp_tm = val is_store_tm_fun = is_BExp_Store; end - fun birs_simp_gen simp_thms_tuple load_thms_tuple simp_tm = + fun birs_simp_gen simp_thms_tuple load_thms_tuple use_store_cheater simp_tm = let val start_exp_tm = get_larg simp_tm; - val use_store_cheater = false; val simp_apply_fun = if is_load_tm_fun start_exp_tm then ( @@ -287,7 +286,7 @@ fun birs_simp_store_cheater simp_tm = []), subexp_cast_thms); - val birs_simp_default_riscv = + fun birs_simp_default_riscv_gen use_store_cheater = let val include_64 = true; val include_32 = false; @@ -299,9 +298,10 @@ fun birs_simp_store_cheater simp_tm = birs_simp_gen (simp_thms_tuple include_64 include_32 mem_64 mem_32 riscv cm0) (load_thms_tuple mem_64 mem_32) + use_store_cheater end; - val birs_simp_default_armcm0 = + fun birs_simp_default_armcm0_gen use_store_cheater = let val include_64 = true; val include_32 = true; @@ -313,7 +313,11 @@ fun birs_simp_store_cheater simp_tm = birs_simp_gen (simp_thms_tuple include_64 include_32 mem_64 mem_32 riscv cm0) (load_thms_tuple mem_64 mem_32) + use_store_cheater end; + + val birs_simp_default_riscv = birs_simp_default_riscv_gen false; + val birs_simp_default_armcm0 = birs_simp_default_armcm0_gen false; end (* local *) From aff23070faae97fd3f0029c432b1a7d9f10c66bd Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sun, 29 Sep 2024 12:09:06 +0200 Subject: [PATCH 44/95] Refactor --- src/tools/symbexec/birsSyntax.sml | 2 ++ src/tools/symbexec/birs_simpLib.sml | 3 +-- src/tools/symbexec/birs_simp_instancesLib.sml | 5 +++-- 3 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/tools/symbexec/birsSyntax.sml b/src/tools/symbexec/birsSyntax.sml index 306f68f8e..733eddb91 100644 --- a/src/tools/symbexec/birsSyntax.sml +++ b/src/tools/symbexec/birsSyntax.sml @@ -100,9 +100,11 @@ end local open bir_symb_simpTheory; fun syntax_fns n d m = HolKernel.syntax_fns {n = n, dest = d, make = m} "bir_symb_simp"; + val syntax_fns2 = syntax_fns 2 HolKernel.dest_binop HolKernel.mk_binop; val syntax_fns3 = syntax_fns 3 HolKernel.dest_triop HolKernel.mk_triop; in val (birs_simplification_tm, mk_birs_simplification, dest_birs_simplification, is_birs_simplification) = syntax_fns3 "birs_simplification"; + val (birs_exp_imp_tm, mk_birs_exp_imp, dest_birs_exp_imp, is_birs_exp_imp) = syntax_fns2 "birs_exp_imp"; end fun is_IMAGE_birs_symb_to_symbst Pi = pred_setSyntax.is_image Pi andalso (identical birs_symb_to_symbst_tm o fst o pred_setSyntax.dest_image) Pi; diff --git a/src/tools/symbexec/birs_simpLib.sml b/src/tools/symbexec/birs_simpLib.sml index 58cdd3247..c692fada6 100644 --- a/src/tools/symbexec/birs_simpLib.sml +++ b/src/tools/symbexec/birs_simpLib.sml @@ -263,9 +263,8 @@ birs_simp_try_inst simp_t simp_inst_tm; *) fun check_imp_tm imp_tm = + if not (birsSyntax.is_birs_exp_imp imp_tm) then raise ERR "check_imp_tm" "term needs to be birs_exp_imp" else let - (* input term: birs_exp_imp *) - (* ================================================= *) val pred1_tm = get_larg imp_tm; val pred2_tm = get_rarg imp_tm; val imp_bexp_tm = bslSyntax.bor (bslSyntax.bnot pred1_tm, pred2_tm); diff --git a/src/tools/symbexec/birs_simp_instancesLib.sml b/src/tools/symbexec/birs_simp_instancesLib.sml index df0175eff..2c9d66a51 100644 --- a/src/tools/symbexec/birs_simp_instancesLib.sml +++ b/src/tools/symbexec/birs_simp_instancesLib.sml @@ -76,6 +76,7 @@ in (* val (expad1:term, endi1:term, expv1:term) = store_to_check; *) + fun stores_match pcond store1 store2 = let val (expad1, endi1, expv1) = store1; @@ -83,8 +84,8 @@ in val endi_eq = identical endi1 endi2; val vsz_eq = identical (get_type_of_bexp expv1) (get_type_of_bexp expv2); - val imp_bexp_tm = bor (bnot pcond, beq (expad1, expad2)); - val ad_is_eq = bir_smt_check_taut false imp_bexp_tm; + val imp_tm = birsSyntax.mk_birs_exp_imp (pcond, beq (expad1, expad2)); + val ad_is_eq = isSome (check_imp_tm imp_tm); in endi_eq andalso vsz_eq andalso From 1080f798813d17d54c24071f345c25c1a1d0cfbd Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sun, 29 Sep 2024 13:13:24 +0200 Subject: [PATCH 45/95] Start a library to collect functions to obtain variables of bir and birs expressions/states --- src/tools/symbexec/aux_setLib.sml | 19 +++----------- src/tools/symbexec/bir_vars_ofLib.sml | 36 +++++++++++++++++++++++++++ src/tools/symbexec/birs_auxLib.sml | 5 ++-- src/tools/symbexec/birs_stepLib.sml | 4 ++- 4 files changed, 46 insertions(+), 18 deletions(-) create mode 100644 src/tools/symbexec/bir_vars_ofLib.sml diff --git a/src/tools/symbexec/aux_setLib.sml b/src/tools/symbexec/aux_setLib.sml index 823a36268..2197720cc 100644 --- a/src/tools/symbexec/aux_setLib.sml +++ b/src/tools/symbexec/aux_setLib.sml @@ -744,18 +744,6 @@ birs_exps_of_senv_COMP {"tmp_SP_process"} val debug_conv = (fn tm => (print_term tm; raise Fail "abcdE!!!")); val debug_conv2 = (fn tm => (if true then print ".\n" else print_term tm; REFL tm)); - fun GEN_match_conv is_tm_fun conv tm = - if is_tm_fun tm then - conv tm - else if is_comb tm then - ((RAND_CONV (GEN_match_conv is_tm_fun conv)) THENC - (RATOR_CONV (GEN_match_conv is_tm_fun conv))) tm - else if is_abs tm then - TRY_CONV (ABS_CONV (GEN_match_conv is_tm_fun conv)) tm - else - raise UNCHANGED - ; - (* REPEATC (SIMP_CONV (std_ss) []) THENC @@ -874,9 +862,10 @@ fun birs_symb_symbols_CONV tm = ( SIMP_CONV (std_ss++birs_state_ss) [birs_symb_symbols_thm] THENC debug_conv2 THENC - GEN_match_conv is_birs_exps_of_senv birs_exps_of_senv_CONV THENC + birs_auxLib.GEN_match_conv is_birs_exps_of_senv birs_exps_of_senv_CONV THENC debug_conv2 THENC - REWRITE_CONV [pred_setTheory.IMAGE_INSERT, pred_setTheory.IMAGE_EMPTY, bir_typing_expTheory.bir_vars_of_exp_def] THENC + REWRITE_CONV [pred_setTheory.IMAGE_INSERT, pred_setTheory.IMAGE_EMPTY] THENC + bir_vars_ofLib.bir_vars_of_exp_CONV THENC debug_conv2 THENC RATOR_CONV (RAND_CONV (REWRITE_CONV [pred_setTheory.BIGUNION_INSERT, pred_setTheory.BIGUNION_EMPTY])) THENC @@ -889,7 +878,7 @@ fun is_birs_symb_symbols tm = is_comb tm andalso (is_const o fst o dest_comb) tm andalso ((fn tm2 => tm2 = "birs_symb_symbols") o fst o dest_const o fst o dest_comb) tm; fun birs_symb_symbols_MATCH_CONV tm = - GEN_match_conv is_birs_symb_symbols birs_symb_symbols_CONV tm; + birs_auxLib.GEN_match_conv is_birs_symb_symbols birs_symb_symbols_CONV tm; (* ................................................ *) diff --git a/src/tools/symbexec/bir_vars_ofLib.sml b/src/tools/symbexec/bir_vars_ofLib.sml new file mode 100644 index 000000000..401d74741 --- /dev/null +++ b/src/tools/symbexec/bir_vars_ofLib.sml @@ -0,0 +1,36 @@ +structure bir_vars_ofLib = +struct + +local + +open HolKernel Parse boolLib bossLib; + +open bir_typing_expTheory; +open bir_typing_expSyntax; + +open HolBACoreSimps; + + (* error handling *) + val libname = "bir_vars_ofLib" + val ERR = Feedback.mk_HOL_ERR libname + val wrap_exn = Feedback.wrap_exn libname + +in (* local *) + + (* TODO: can probably speed this up by extending the caching into the evaluation of variables subexpressions, + but only relevant for handling of bigger expressions *) + fun bir_vars_of_exp_DIRECT_CONV tm = + let + val _ = if is_bir_vars_of_exp tm then () else + raise ERR "bir_vars_of_exp_DIRECT_CONV" "cannot handle term"; + in + (SIMP_CONV (std_ss++holBACore_ss) [] THENC EVAL) tm + end; + val bir_vars_of_exp_DIRECT_CONV = aux_moveawayLib.wrap_cache_result Term.compare bir_vars_of_exp_DIRECT_CONV; + + val bir_vars_of_exp_CONV = + birs_auxLib.GEN_match_conv (is_bir_vars_of_exp) bir_vars_of_exp_DIRECT_CONV; + +end (* local *) + +end (* struct *) diff --git a/src/tools/symbexec/birs_auxLib.sml b/src/tools/symbexec/birs_auxLib.sml index 7530c1f35..ef29a6a00 100644 --- a/src/tools/symbexec/birs_auxLib.sml +++ b/src/tools/symbexec/birs_auxLib.sml @@ -16,7 +16,7 @@ in (* ============================================================================ *) -(* TODO: this is stolen from exec tool *) + (* TODO: this is stolen from exec tool, better unify them later: bir_exec_auxLib *) fun GEN_match_conv is_tm_fun conv tm = if is_tm_fun tm then conv tm @@ -28,7 +28,8 @@ in else raise UNCHANGED ; -(* TODO: this is stolen from exec tool, and then modified for extraction of the expressions *) + + (* TODO: this is a modified version of the above function, better unify them later *) fun GEN_match_extract is_tm_fun acc [] = acc | GEN_match_extract is_tm_fun acc (tm::l) = if is_tm_fun tm then diff --git a/src/tools/symbexec/birs_stepLib.sml b/src/tools/symbexec/birs_stepLib.sml index ab88a5880..97d249e00 100644 --- a/src/tools/symbexec/birs_stepLib.sml +++ b/src/tools/symbexec/birs_stepLib.sml @@ -621,7 +621,9 @@ val birs_eval_exp_CONV_p2 = fun birs_eval_exp_CONV_p3 eq_thms = GEN_match_conv (is_birs_senv_typecheck) (birs_senv_typecheck_CONV eq_thms); -(* TODO: can possibly improve this *) +(* TODO: can possibly improve this, + for example by only taking the environment into the expressions where there are symbol lookups, + could even work with a cache of lookup theorems for the present symbols *) fun birs_eval_exp_CONV_p4 eq_thms = EVAL THENC REWRITE_CONV eq_thms THENC From 8ae2e635f7601b91b22eff67665e2a6cb4342581 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sun, 29 Sep 2024 13:46:57 +0200 Subject: [PATCH 46/95] Refactor --- src/tools/symbexec/bir_exp_typecheckLib.sml | 38 ++++++---- src/tools/symbexec/bir_symbLib.sml | 74 +------------------ src/tools/symbexec/bir_vars_ofLib.sml | 2 +- src/tools/symbexec/birs_simpLib.sml | 2 +- src/tools/symbexec/birs_simp_instancesLib.sml | 14 +--- src/tools/symbexec/birs_stepLib.sml | 8 +- 6 files changed, 34 insertions(+), 104 deletions(-) diff --git a/src/tools/symbexec/bir_exp_typecheckLib.sml b/src/tools/symbexec/bir_exp_typecheckLib.sml index 9dbd1f0f6..eee7049ee 100644 --- a/src/tools/symbexec/bir_exp_typecheckLib.sml +++ b/src/tools/symbexec/bir_exp_typecheckLib.sml @@ -3,16 +3,17 @@ struct local -open HolKernel Parse boolLib bossLib; -open computeLib; + open HolKernel Parse boolLib bossLib; + open computeLib; -open bir_exp_substitutionsTheory; -open bir_expTheory; + open bir_exp_substitutionsTheory; + open bir_expTheory; -open bir_symbTheory; -open birs_auxTheory; + open bir_symbTheory; + open birs_auxTheory; -open birs_auxLib; + open birs_auxLib; + open bir_typing_expSyntax; (* error handling *) val libname = "bir_exp_typecheckLib" @@ -21,15 +22,15 @@ open birs_auxLib; in (* local *) -(* TODO: we really have to put this in a central place... *) - fun type_of_bir_exp_CONV term = +(* TODO: we really have to put this in a central place..., stolen from: bir_exp_to_wordsLib.type_of_bir_exp_CONV (and maybe modified) *) + fun type_of_bir_exp_gen_CONV term = (* Manual test val term = `` BExp_BinExp BIExp_Plus (BExp_Const (Imm32 20w)) (BExp_Const (Imm32 22w)) ``; - val thm = type_of_bir_exp_CONV ``type_of_bir_exp ^term``; + val thm = type_of_bir_exp_gen_CONV ``type_of_bir_exp ^term``; *) let open bir_immTheory @@ -70,7 +71,7 @@ in (* local *) in conv term end - handle _ => raise ERR "type_of_bir_exp_CONV" "conversion failed"; + handle _ => raise ERR "type_of_bir_exp_gen_CONV" "conversion failed"; val (typecheck_add, typecheck_lookup) = aux_moveawayLib.result_cache Term.compare; @@ -90,7 +91,7 @@ fun check_typeof thm = fun gettype_CONV term = let - val thm = type_of_bir_exp_CONV term; + val thm = type_of_bir_exp_gen_CONV term; in thm end @@ -105,8 +106,6 @@ type_of_bir_exp_DIRECT_CONV bexp_term *) fun type_of_bir_exp_DIRECT_CONV term = let - open bir_typing_expSyntax; - val _ = if is_type_of_bir_exp term then () else raise ERR "type_of_bir_exp_DIRECT_CONV" "cannot handle term"; @@ -132,6 +131,17 @@ type_of_bir_exp_DIRECT_CONV bexp_term val type_of_bir_exp_DIRECT_CONV = Profile.profile "type_of_bir_exp_DIRECT_CONV" type_of_bir_exp_DIRECT_CONV; +val type_of_bir_exp_CONV = + GEN_match_conv (bir_typing_expSyntax.is_type_of_bir_exp) (type_of_bir_exp_DIRECT_CONV); + +fun get_type_of_bexp tm = + let + open optionSyntax; + val thm = type_of_bir_exp_DIRECT_CONV (mk_type_of_bir_exp tm); + in + (dest_some o snd o dest_eq o concl) thm + end + handle _ => raise ERR "get_type_of_bexp" "not well-typed expression or other issue"; end (* local *) diff --git a/src/tools/symbexec/bir_symbLib.sml b/src/tools/symbexec/bir_symbLib.sml index 508bfa35c..033f5d993 100644 --- a/src/tools/symbexec/bir_symbLib.sml +++ b/src/tools/symbexec/bir_symbLib.sml @@ -212,41 +212,6 @@ fun bir_symb_transfer (MATCH_MP symb_prop_transferTheory.symb_prop_transfer_thm birs_symb_symbols_f_sound_prog_thm); - val type_of_bir_exp_thms = - let - open bir_immTheory - open bir_valuesTheory - open bir_envTheory - open bir_exp_memTheory - open bir_bool_expTheory - open bir_extra_expsTheory - open bir_nzcv_expTheory - open bir_interval_expTheory - in [ - type_of_bir_exp_def, - bir_var_type_def, - bir_type_is_Imm_def, - type_of_bir_imm_def, - BExp_Aligned_type_of, - BExp_unchanged_mem_interval_distinct_type_of, - bir_number_of_mem_splits_REWRS, - BType_Bool_def, - bir_exp_true_def, - bir_exp_false_def, - BExp_MSB_type_of, - BExp_nzcv_ADD_DEFS, - BExp_nzcv_SUB_DEFS, - n2bs_def, - BExp_word_bit_def, - BExp_Align_type_of, - BExp_ror_type_of, - BExp_LSB_type_of, - BExp_word_bit_exp_type_of, - BExp_ADD_WITH_CARRY_type_of, - BExp_word_reverse_type_of, - BExp_ror_exp_type_of - ] end; - val bprog_P_entails_thm = prove (``P_entails_an_interpret (bir_symb_rec_sbir ^bprog_tm) @@ -267,7 +232,7 @@ fun bir_symb_transfer POP_ASSUM (fn thm => FULL_SIMP_TAC std_ss [thm]) >> `IS_SOME (type_of_bir_exp ^bspec_pre_tm)` by ( SIMP_TAC std_ss [bspec_pre_def] >> - CONV_TAC (RAND_CONV (SIMP_CONV (srw_ss()) type_of_bir_exp_thms)) >> + CONV_TAC (RAND_CONV (bir_exp_typecheckLib.type_of_bir_exp_gen_CONV)) >> SIMP_TAC (std_ss++holBACore_ss) [optionTheory.option_CLAUSES] ) >> POP_ASSUM (fn thm => FULL_SIMP_TAC std_ss [thm])); @@ -518,41 +483,6 @@ fun bir_symb_transfer_two (MATCH_MP symb_prop_transferTheory.symb_prop_transfer_thm birs_symb_symbols_f_sound_prog_thm); - val type_of_bir_exp_thms = - let - open bir_immTheory - open bir_valuesTheory - open bir_envTheory - open bir_exp_memTheory - open bir_bool_expTheory - open bir_extra_expsTheory - open bir_nzcv_expTheory - open bir_interval_expTheory - in [ - type_of_bir_exp_def, - bir_var_type_def, - bir_type_is_Imm_def, - type_of_bir_imm_def, - BExp_Aligned_type_of, - BExp_unchanged_mem_interval_distinct_type_of, - bir_number_of_mem_splits_REWRS, - BType_Bool_def, - bir_exp_true_def, - bir_exp_false_def, - BExp_MSB_type_of, - BExp_nzcv_ADD_DEFS, - BExp_nzcv_SUB_DEFS, - n2bs_def, - BExp_word_bit_def, - BExp_Align_type_of, - BExp_ror_type_of, - BExp_LSB_type_of, - BExp_word_bit_exp_type_of, - BExp_ADD_WITH_CARRY_type_of, - BExp_word_reverse_type_of, - BExp_ror_exp_type_of - ] end; - val bprog_P_entails_thm = prove (``P_entails_an_interpret (bir_symb_rec_sbir ^bprog_tm) @@ -573,7 +503,7 @@ fun bir_symb_transfer_two POP_ASSUM (fn thm => FULL_SIMP_TAC std_ss [thm]) >> `IS_SOME (type_of_bir_exp ^bspec_pre_tm)` by ( SIMP_TAC std_ss [bspec_pre_def] >> - CONV_TAC (RAND_CONV (SIMP_CONV (srw_ss()) type_of_bir_exp_thms)) >> + CONV_TAC (RAND_CONV (bir_exp_typecheckLib.type_of_bir_exp_gen_CONV)) >> SIMP_TAC (std_ss++holBACore_ss) [optionTheory.option_CLAUSES]) >> POP_ASSUM (fn thm => FULL_SIMP_TAC std_ss [thm])); diff --git a/src/tools/symbexec/bir_vars_ofLib.sml b/src/tools/symbexec/bir_vars_ofLib.sml index 401d74741..2b69d85ae 100644 --- a/src/tools/symbexec/bir_vars_ofLib.sml +++ b/src/tools/symbexec/bir_vars_ofLib.sml @@ -17,7 +17,7 @@ open HolBACoreSimps; in (* local *) - (* TODO: can probably speed this up by extending the caching into the evaluation of variables subexpressions, + (* TODO: can probably speed this up by extending the caching into the evaluation of variables subexpressions, like in the function type_of_bir_exp_DIRECT_CONV, but only relevant for handling of bigger expressions *) fun bir_vars_of_exp_DIRECT_CONV tm = let diff --git a/src/tools/symbexec/birs_simpLib.sml b/src/tools/symbexec/birs_simpLib.sml index c692fada6..ec8111595 100644 --- a/src/tools/symbexec/birs_simpLib.sml +++ b/src/tools/symbexec/birs_simpLib.sml @@ -160,7 +160,7 @@ birs_simp_try_fix_assumptions instd_thm; *) fun birs_simp_try_justify_assumption assmpt = let - val type_ofbirexp_CONV = GEN_match_conv (bir_typing_expSyntax.is_type_of_bir_exp) (type_of_bir_exp_DIRECT_CONV); + val type_ofbirexp_CONV = type_of_bir_exp_CONV; val assmpt_thm = (type_ofbirexp_CONV THENC EVAL) assmpt; val assmpt_new = (snd o dest_eq o concl) assmpt_thm; diff --git a/src/tools/symbexec/birs_simp_instancesLib.sml b/src/tools/symbexec/birs_simp_instancesLib.sml index 2c9d66a51..5be4db50f 100644 --- a/src/tools/symbexec/birs_simp_instancesLib.sml +++ b/src/tools/symbexec/birs_simp_instancesLib.sml @@ -61,18 +61,8 @@ val simp_tm = birs_simp_gen_term pcond bexp; birs_simp_load simp_tm; *) local - open optionSyntax; - open bir_typing_expSyntax; - open bslSyntax; + open bir_exp_typecheckLib; in - fun get_type_of_bexp tm = - let - val thm = type_of_bir_exp_DIRECT_CONV (mk_type_of_bir_exp tm); - in - (dest_some o snd o dest_eq o concl) thm - end - handle _ => raise ERR "get_type_of_bexp" "not well-typed expression or other issue"; - (* val (expad1:term, endi1:term, expv1:term) = store_to_check; *) @@ -84,7 +74,7 @@ in val endi_eq = identical endi1 endi2; val vsz_eq = identical (get_type_of_bexp expv1) (get_type_of_bexp expv2); - val imp_tm = birsSyntax.mk_birs_exp_imp (pcond, beq (expad1, expad2)); + val imp_tm = birsSyntax.mk_birs_exp_imp (pcond, bslSyntax.beq (expad1, expad2)); val ad_is_eq = isSome (check_imp_tm imp_tm); in endi_eq andalso diff --git a/src/tools/symbexec/birs_stepLib.sml b/src/tools/symbexec/birs_stepLib.sml index 97d249e00..3c5b8f358 100644 --- a/src/tools/symbexec/birs_stepLib.sml +++ b/src/tools/symbexec/birs_stepLib.sml @@ -565,7 +565,7 @@ val birs_state_ss = rewrites (type_rws ``:birs_state_t``); fun birs_senv_typecheck_CONV eq_thms = ( RESTR_EVAL_CONV [bir_typing_expSyntax.type_of_bir_exp_tm] THENC REWRITE_CONV eq_thms THENC - GEN_match_conv (bir_typing_expSyntax.is_type_of_bir_exp) (type_of_bir_exp_DIRECT_CONV) THENC + type_of_bir_exp_CONV THENC EVAL ); val birs_senv_typecheck_CONV = fn x => Profile.profile "senv_typecheck_CONV" (birs_senv_typecheck_CONV x); @@ -616,7 +616,7 @@ fun birs_eval_exp_CONV_p1 t = val birs_eval_exp_CONV_p2 = REWRITE_CONV [birs_eval_exp_def] THENC - GEN_match_conv (bir_typing_expSyntax.is_type_of_bir_exp) (type_of_bir_exp_DIRECT_CONV); + type_of_bir_exp_CONV; fun birs_eval_exp_CONV_p3 eq_thms = GEN_match_conv (is_birs_senv_typecheck) (birs_senv_typecheck_CONV eq_thms); @@ -802,7 +802,7 @@ val birs_exec_step_CONV_p4 = GEN_match_conv is_birs_eval_exp (birs_eval_exp_CONV) THENC REWRITE_CONV [birs_gen_env_GET_thm, birs_gen_env_GET_NULL_thm] THENC RESTR_EVAL_CONV [birs_update_env_tm, birs_gen_env_tm, bir_typing_expSyntax.type_of_bir_exp_tm] THENC - GEN_match_conv (bir_typing_expSyntax.is_type_of_bir_exp) (type_of_bir_exp_DIRECT_CONV) THENC + type_of_bir_exp_CONV THENC RESTR_EVAL_CONV [birs_update_env_tm, birs_gen_env_tm]; val birs_exec_step_CONV_p4 = Profile.profile "exec_step_CONV_p4" birs_exec_step_CONV_p4; @@ -867,7 +867,7 @@ let (GEN_match_conv is_OPTION_BIND ( RATOR_CONV (RAND_CONV (REWRITE_CONV ([birs_gen_env_GET_thm, birs_gen_env_GET_NULL_thm]@eq_thms) THENC EVAL (* TODO: this can be improved, I think *))) THENC REWRITE_CONV [optionTheory.OPTION_BIND_def] (* OPTION_BIND semantics *) THENC - GEN_match_conv (bir_typing_expSyntax.is_type_of_bir_exp) (type_of_bir_exp_DIRECT_CONV) + type_of_bir_exp_CONV )) ) res_b_eval_exp; From 03accefa79bc1509de9e667070c11dd74c2504b6 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sun, 29 Sep 2024 14:25:57 +0200 Subject: [PATCH 47/95] Refactor more --- src/tools/symbexec/aux_setLib.sml | 2013 ++++++++++-------------- src/tools/symbexec/bir_vars_ofLib.sml | 499 ++++++ src/tools/symbexec/birs_composeLib.sml | 42 +- 3 files changed, 1292 insertions(+), 1262 deletions(-) diff --git a/src/tools/symbexec/aux_setLib.sml b/src/tools/symbexec/aux_setLib.sml index 2197720cc..60d96f014 100644 --- a/src/tools/symbexec/aux_setLib.sml +++ b/src/tools/symbexec/aux_setLib.sml @@ -13,8 +13,6 @@ open birs_auxTheory; open HolBACoreSimps; - - val birs_state_ss = rewrites (type_rws ``:birs_state_t``); (* error handling *) @@ -26,1308 +24,875 @@ val birs_state_ss = rewrites (type_rws ``:birs_state_t``); in (* local *) -(* -fun stx_tm addr_tm index_tm symbname_tm = `` - <|bsst_pc := <|bpc_label := BL_Address (Imm32 (^addr_tm)); bpc_index := (^index_tm)|>; - bsst_environ := - birs_gen_env - [("MEM",BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); - ("PSR_C",BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); - ("PSR_N",BExp_Den (BVar "sy_PSR_N" (BType_Imm Bit1))); - ("PSR_V",BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); - ("PSR_Z",BExp_Den (BVar (^symbname_tm) (BType_Imm Bit1)))]; - bsst_status := BST_Running; - bsst_pcond := - (BExp_BinPred BIExp_LessOrEqual - (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) - (BExp_Const (Imm64 0xFFFFFFFFFFFFFF00w)))|> -``; -val st1_tm = stx_tm ``2824w:word32`` ``1:num`` ``"sy_PSR_Z"``; -val st2_tm = stx_tm ``2824w:word32`` ``2:num`` ``"sy_PSR_Z"``; -val st3_tm = stx_tm ``2825w:word32`` ``1:num`` ``"sy_PSR_A"``; -val st4_tm = stx_tm ``2824w:word32`` ``3:num`` ``"sy_PSR_Z"``; +(* ---------------------------------------------------------------------------------- *) +(* faster set operations for bir variable sets (for computing freevarset, symbexec composition, merging, etc) *) +(* ---------------------------------------------------------------------------------- *) -val st_eq_1_tm = ``^st1_tm = ^st1_tm``; -val st_eq_2_tm = ``^st1_tm = ^st2_tm``; -val st_eq_3_tm = ``^st1_tm = ^st3_tm``; -val st_eq_4_tm = ``^st2_tm = ^st3_tm``; +(* +EVAL tm -val tm = st_eq_2_tm; -val tm = st_eq_3_tm; -val tm = st_eq_4_tm; + val birs_exps_of_senv_CONV = ( + debug_conv2 THENC + REPEATC (CHANGED_CONV ( + (fn x => REWRITE_CONV [Once birs_exps_of_senv_COMP_thm] x) THENC + (SIMP_CONV (std_ss) []) THENC + (ONCE_DEPTH_CONV ( (PAT_CONV ``\A. if A then B else (C)`` (REWRITE_CONV [pred_setTheory.COMPONENT] THENC SIMP_CONV std_ss [pred_setTheory.IN_INSERT])))) THENC + SIMP_CONV (std_ss) [] + )) + ); -birs_state_EQ_CONV st_eq_1_tm -birs_state_EQ_CONV st_eq_2_tm -birs_state_EQ_CONV st_eq_3_tm -birs_state_EQ_CONV st_eq_4_tm + val birs_symb_symbols_CONV = ( + SIMP_CONV std_ss [birs_symb_symbols_thm] THENC + SIMP_CONV (std_ss++birs_state_ss) [] THENC + SIMP_CONV (std_ss) [birs_exps_of_senv_thm] + (*(PAT_CONV ``\A. IMAGE bir_vars_of_exp A`` birs_exps_of_senv_CONV)*) + ); + val conv = birs_symb_symbols_CONV (*THENC EVAL*); + val conv_ = computeLib.RESTR_EVAL_CONV [``birs_symb_symbols``] THENC conv; *) -val birs_state_NEQ_pc_thm = prove(`` -!bsys1 bsys2. - (bsys1.bsst_pc <> bsys2.bsst_pc) ==> - (bsys1 <> bsys2) -``, - SIMP_TAC (std_ss++birs_state_ss) [] -); -val birs_state_NEQ_pcond_thm = prove(`` -!bsys1 bsys2. - (bsys1.bsst_pcond <> bsys2.bsst_pcond) ==> - (bsys1 <> bsys2) -``, - SIMP_TAC (std_ss++birs_state_ss) [] -); -val birs_state_NEQ_status_thm = prove(`` -!bsys1 bsys2. - (bsys1.bsst_status <> bsys2.bsst_status) ==> - (bsys1 <> bsys2) -``, - SIMP_TAC (std_ss++birs_state_ss) [] -); +(* +val tm = `` +{BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1); + BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1); + BVar "sy_PSR_Z" (BType_Imm Bit1); BVar "sy_R0" (BType_Imm Bit32); + BVar "sy_R1" (BType_Imm Bit32); BVar "sy_R2" (BType_Imm Bit32); + BVar "sy_R3" (BType_Imm Bit32); BVar "sy_R4" (BType_Imm Bit32); + BVar "sy_R5" (BType_Imm Bit32); BVar "sy_R6" (BType_Imm Bit32); + BVar "sy_R7" (BType_Imm Bit32); BVar "sy_R8" (BType_Imm Bit32); + BVar "sy_R9" (BType_Imm Bit32); BVar "sy_R10" (BType_Imm Bit32); + BVar "sy_R11" (BType_Imm Bit32); BVar "sy_R12" (BType_Imm Bit32); + BVar "sy_LR" (BType_Imm Bit32); BVar "sy_SP_main" (BType_Imm Bit32); + BVar "sy_SP_process" (BType_Imm Bit32); + BVar "sy_ModeHandler" (BType_Imm Bit1); + BVar "sy_countw" (BType_Imm Bit64); BVar "sy_tmp_PC" (BType_Imm Bit32); + BVar "sy_tmp_COND" (BType_Imm Bit1); + BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); + BVar "sy_tmp_PSR_C" (BType_Imm Bit1); + BVar "sy_tmp_PSR_N" (BType_Imm Bit1); + BVar "sy_tmp_PSR_V" (BType_Imm Bit1); + BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); BVar "sy_tmp_R0" (BType_Imm Bit32); + BVar "sy_tmp_R1" (BType_Imm Bit32); BVar "sy_tmp_R2" (BType_Imm Bit32); + BVar "sy_tmp_R3" (BType_Imm Bit32); BVar "sy_tmp_R4" (BType_Imm Bit32); + BVar "sy_tmp_R5" (BType_Imm Bit32); BVar "sy_tmp_R6" (BType_Imm Bit32); + BVar "sy_tmp_R7" (BType_Imm Bit32); BVar "sy_tmp_R8" (BType_Imm Bit32); + BVar "sy_tmp_R9" (BType_Imm Bit32); BVar "sy_tmp_R10" (BType_Imm Bit32); + BVar "sy_tmp_R11" (BType_Imm Bit32); BVar "sy_tmp_R12" (BType_Imm Bit32); + BVar "sy_tmp_LR" (BType_Imm Bit32); + BVar "sy_tmp_SP_main" (BType_Imm Bit32); + BVar "sy_tmp_SP_process" (BType_Imm Bit32); + BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); + BVar "sy_tmp_countw" (BType_Imm Bit64)} ∩ + ({BVar "sy_countw" (BType_Imm Bit64); + BVar "sy_SP_process" (BType_Imm Bit32); + BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1); + BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1); + BVar "sy_PSR_Z" (BType_Imm Bit1); BVar "sy_R0" (BType_Imm Bit32); + BVar "sy_R1" (BType_Imm Bit32); BVar "sy_R2" (BType_Imm Bit32); + BVar "sy_R3" (BType_Imm Bit32); BVar "sy_R4" (BType_Imm Bit32); + BVar "sy_R5" (BType_Imm Bit32); BVar "sy_R6" (BType_Imm Bit32); + BVar "sy_R7" (BType_Imm Bit32); BVar "sy_R8" (BType_Imm Bit32); + BVar "sy_R9" (BType_Imm Bit32); BVar "sy_R10" (BType_Imm Bit32); + BVar "sy_R11" (BType_Imm Bit32); BVar "sy_R12" (BType_Imm Bit32); + BVar "sy_LR" (BType_Imm Bit32); BVar "sy_SP_main" (BType_Imm Bit32); + BVar "sy_SP_process" (BType_Imm Bit32); + BVar "sy_ModeHandler" (BType_Imm Bit1); + BVar "sy_countw" (BType_Imm Bit64); BVar "sy_tmp_PC" (BType_Imm Bit32); + BVar "sy_tmp_COND" (BType_Imm Bit1); + BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); + BVar "sy_tmp_PSR_C" (BType_Imm Bit1); + BVar "sy_tmp_PSR_N" (BType_Imm Bit1); + BVar "sy_tmp_PSR_V" (BType_Imm Bit1); + BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); + BVar "sy_tmp_R0" (BType_Imm Bit32); BVar "sy_tmp_R1" (BType_Imm Bit32); + BVar "sy_tmp_R2" (BType_Imm Bit32); BVar "sy_tmp_R3" (BType_Imm Bit32); + BVar "sy_tmp_R4" (BType_Imm Bit32); BVar "sy_tmp_R5" (BType_Imm Bit32); + BVar "sy_tmp_R6" (BType_Imm Bit32); BVar "sy_tmp_R7" (BType_Imm Bit32); + BVar "sy_tmp_R8" (BType_Imm Bit32); BVar "sy_tmp_R9" (BType_Imm Bit32); + BVar "sy_tmp_R10" (BType_Imm Bit32); + BVar "sy_tmp_R11" (BType_Imm Bit32); + BVar "sy_tmp_R12" (BType_Imm Bit32); BVar "sy_tmp_LR" (BType_Imm Bit32); + BVar "sy_tmp_SP_main" (BType_Imm Bit32); + BVar "sy_tmp_SP_process" (BType_Imm Bit32); + BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); + BVar "sy_tmp_countw" (BType_Imm Bit64); + BVar "sy_countw" (BType_Imm Bit64); + BVar "sy_SP_process" (BType_Imm Bit32); + BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1); + BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1); + BVar "sy_PSR_Z" (BType_Imm Bit1); BVar "sy_R0" (BType_Imm Bit32); + BVar "sy_R1" (BType_Imm Bit32); BVar "sy_R2" (BType_Imm Bit32); + BVar "sy_R3" (BType_Imm Bit32); BVar "sy_R4" (BType_Imm Bit32); + BVar "sy_R5" (BType_Imm Bit32); BVar "sy_R6" (BType_Imm Bit32); + BVar "sy_R7" (BType_Imm Bit32); BVar "sy_R8" (BType_Imm Bit32); + BVar "sy_R9" (BType_Imm Bit32); BVar "sy_R10" (BType_Imm Bit32); + BVar "sy_R11" (BType_Imm Bit32); BVar "sy_R12" (BType_Imm Bit32); + BVar "sy_LR" (BType_Imm Bit32); BVar "sy_SP_main" (BType_Imm Bit32); + BVar "sy_SP_process" (BType_Imm Bit32); + BVar "sy_ModeHandler" (BType_Imm Bit1); + BVar "sy_countw" (BType_Imm Bit64); BVar "sy_tmp_PC" (BType_Imm Bit32); + BVar "sy_tmp_COND" (BType_Imm Bit1); + BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); + BVar "sy_tmp_PSR_C" (BType_Imm Bit1); + BVar "sy_tmp_PSR_N" (BType_Imm Bit1); + BVar "sy_tmp_PSR_V" (BType_Imm Bit1); + BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); + BVar "sy_tmp_R0" (BType_Imm Bit32); BVar "sy_tmp_R1" (BType_Imm Bit32); + BVar "sy_tmp_R2" (BType_Imm Bit32); BVar "sy_tmp_R3" (BType_Imm Bit32); + BVar "sy_tmp_R4" (BType_Imm Bit32); BVar "sy_tmp_R5" (BType_Imm Bit32); + BVar "sy_tmp_R6" (BType_Imm Bit32); BVar "sy_tmp_R7" (BType_Imm Bit32); + BVar "sy_tmp_R8" (BType_Imm Bit32); BVar "sy_tmp_R9" (BType_Imm Bit32); + BVar "sy_tmp_R10" (BType_Imm Bit32); + BVar "sy_tmp_R11" (BType_Imm Bit32); + BVar "sy_tmp_R12" (BType_Imm Bit32); BVar "sy_tmp_LR" (BType_Imm Bit32); + BVar "sy_tmp_SP_main" (BType_Imm Bit32); + BVar "sy_tmp_SP_process" (BType_Imm Bit32); + BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); + BVar "sy_tmp_countw" (BType_Imm Bit64)} DIFF + {BVar "sy_countw" (BType_Imm Bit64); + BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1); + BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1); + BVar "sy_PSR_Z" (BType_Imm Bit1); BVar "sy_R0" (BType_Imm Bit32); + BVar "sy_R1" (BType_Imm Bit32); BVar "sy_R2" (BType_Imm Bit32); + BVar "sy_R3" (BType_Imm Bit32); BVar "sy_R4" (BType_Imm Bit32); + BVar "sy_R5" (BType_Imm Bit32); BVar "sy_R6" (BType_Imm Bit32); + BVar "sy_R7" (BType_Imm Bit32); BVar "sy_R8" (BType_Imm Bit32); + BVar "sy_R9" (BType_Imm Bit32); BVar "sy_R10" (BType_Imm Bit32); + BVar "sy_R11" (BType_Imm Bit32); BVar "sy_R12" (BType_Imm Bit32); + BVar "sy_LR" (BType_Imm Bit32); BVar "sy_SP_main" (BType_Imm Bit32); + BVar "sy_SP_process" (BType_Imm Bit32); + BVar "sy_ModeHandler" (BType_Imm Bit1); + BVar "sy_countw" (BType_Imm Bit64); BVar "sy_tmp_PC" (BType_Imm Bit32); + BVar "sy_tmp_COND" (BType_Imm Bit1); + BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); + BVar "sy_tmp_PSR_C" (BType_Imm Bit1); + BVar "sy_tmp_PSR_N" (BType_Imm Bit1); + BVar "sy_tmp_PSR_V" (BType_Imm Bit1); + BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); + BVar "sy_tmp_R0" (BType_Imm Bit32); BVar "sy_tmp_R1" (BType_Imm Bit32); + BVar "sy_tmp_R2" (BType_Imm Bit32); BVar "sy_tmp_R3" (BType_Imm Bit32); + BVar "sy_tmp_R4" (BType_Imm Bit32); BVar "sy_tmp_R5" (BType_Imm Bit32); + BVar "sy_tmp_R6" (BType_Imm Bit32); BVar "sy_tmp_R7" (BType_Imm Bit32); + BVar "sy_tmp_R8" (BType_Imm Bit32); BVar "sy_tmp_R9" (BType_Imm Bit32); + BVar "sy_tmp_R10" (BType_Imm Bit32); + BVar "sy_tmp_R11" (BType_Imm Bit32); + BVar "sy_tmp_R12" (BType_Imm Bit32); BVar "sy_tmp_LR" (BType_Imm Bit32); + BVar "sy_tmp_SP_main" (BType_Imm Bit32); + BVar "sy_tmp_SP_process" (BType_Imm Bit32); + BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); + BVar "sy_tmp_countw" (BType_Imm Bit64)}) +``; - fun try_prove_birs_state_try_justify_assumptions t = - if (is_neg o concl) t orelse - (not o is_imp o concl) t then - t - else - let - val assmpt = (fst o dest_imp o concl) t; - val assmpt_thm = (SIMP_CONV (std_ss++holBACore_ss++birs_state_ss) [] THENC EVAL) assmpt; +val tm = `` +{BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1);BVar "sy_countw" (BType_Imm Bit64); + BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1)} ∩ + ({BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1);BVar "sy_countw" (BType_Imm Bit64); + BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1)} DIFF + { + BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); + BVar "sy_tmp_countw" (BType_Imm Bit64)}) +``; - val assmpt_new = (snd o dest_eq o concl) assmpt_thm; +val tm = (snd o dest_comb o fst o dest_comb o snd o dest_eq o concl o REWRITE_CONV [REWRITE_RULE [Once pred_setTheory.INTER_COMM] pred_setTheory.DIFF_INTER]) tm; +val tm = (snd o dest_comb o snd o dest_eq o concl o REWRITE_CONV [Once (prove(`` +!s t g. +g INTER (s DIFF t) = +s INTER (g DIFF t) +``, +(*REWRITE_RULE [Once pred_setTheory.INTER_COMM] pred_setTheory.DIFF_INTER*) +METIS_TAC [pred_setTheory.INTER_COMM, pred_setTheory.DIFF_INTER] +))]) tm; - (* raise exception when the assumption turns out to be false *) - val _ = if not (identical assmpt_new F) then () else - raise ERR "birs_simp_try_justify_assumptions" "assumption does not hold"; +++pred_setSimps.PRED_SET_ss +val char_ss = rewrites (type_rws ``:char``); - val _ = if identical assmpt_new T then () else - raise ERR "birs_simp_try_justify_assumptions" ("failed to fix the assumption: " ^ (term_to_string assmpt)); - in - try_prove_birs_state_try_justify_assumptions - (REWRITE_RULE [assmpt_thm] t) - end; - -fun try_prove_birs_state_NEQ bsys1_tm bsys2_tm = - let - val thms = [birs_state_NEQ_pc_thm, birs_state_NEQ_pcond_thm, birs_state_NEQ_status_thm]; - val t = hd thms; - fun foldfun (t, r_o) = - if isSome r_o then - r_o - else - (*val t = (SPECL [bsys1_tm, bsys2_tm] t);*) - SOME (try_prove_birs_state_try_justify_assumptions (SPECL [bsys1_tm, bsys2_tm] t)) - handle _ => NONE; - val neq_t_o = List.foldl foldfun NONE thms; - in - if isSome neq_t_o then - valOf neq_t_o - else - (print "\ncould not show inequality of the states, would need to check the environments\n"; - raise ERR "try_prove_birs_state_NEQ" "could not show inequality of the states, would need to check the environments") - end; - -fun birs_state_EQ_CONV tm = - IFC - (CHANGED_CONV (REWRITE_CONV [])) - (fn tm => (print "syntactically equal, done!\n"; REFL tm)) - (fn tm => - let - val (bsys1_tm, bsys2_tm) = dest_eq tm; - val neq_t = try_prove_birs_state_NEQ bsys1_tm bsys2_tm; - in - REWRITE_CONV [neq_t] tm - end) - tm; - -(* -val tm = `` - (IMAGE birs_symb_to_symbst {^st1_tm; ^st2_tm} DIFF - {birs_symb_to_symbst ^st1_tm}) -UNION - IMAGE birs_symb_to_symbst {^st4_tm} -``; - -val tm = `` -IMAGE birs_symb_to_symbst - {<|bsst_pc := <|bpc_label := BL_Address (Imm32 2824w); bpc_index := 1|>; - bsst_environ := - birs_gen_env - [("MEM",BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); - ("PSR_C",BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); - ("PSR_N",BExp_Den (BVar "sy_PSR_N" (BType_Imm Bit1))); - ("PSR_V",BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); - ("PSR_Z",BExp_Den (BVar "sy_PSR_Z" (BType_Imm Bit1))); - ("R0",BExp_Den (BVar "sy_R0" (BType_Imm Bit32))); - ("R1",BExp_Den (BVar "sy_R1" (BType_Imm Bit32))); - ("R2",BExp_Den (BVar "sy_R2" (BType_Imm Bit32))); - ("R3",BExp_Den (BVar "sy_R3" (BType_Imm Bit32))); - ("R4",BExp_Den (BVar "sy_R4" (BType_Imm Bit32))); - ("R5",BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); - ("R6",BExp_Den (BVar "sy_R6" (BType_Imm Bit32))); - ("R7",BExp_Den (BVar "sy_R7" (BType_Imm Bit32))); - ("R8",BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); - ("R9",BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); - ("R10",BExp_Den (BVar "sy_R10" (BType_Imm Bit32))); - ("R11",BExp_Den (BVar "sy_R11" (BType_Imm Bit32))); - ("R12",BExp_Den (BVar "sy_R12" (BType_Imm Bit32))); - ("LR",BExp_Den (BVar "sy_LR" (BType_Imm Bit32))); - ("SP_main",BExp_Den (BVar "sy_SP_main" (BType_Imm Bit32))); - ("SP_process",BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))); - ("ModeHandler",BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1))); - ("countw",BExp_Den (BVar "sy_countw" (BType_Imm Bit64))); - ("tmp_PC",BExp_Den (BVar "sy_tmp_PC" (BType_Imm Bit32))); - ("tmp_COND",BExp_Den (BVar "sy_tmp_COND" (BType_Imm Bit1))); - ("tmp_MEM",BExp_Den (BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8))); - ("tmp_PSR_C",BExp_Den (BVar "sy_tmp_PSR_C" (BType_Imm Bit1))); - ("tmp_PSR_N",BExp_Den (BVar "sy_tmp_PSR_N" (BType_Imm Bit1))); - ("tmp_PSR_V",BExp_Den (BVar "sy_tmp_PSR_V" (BType_Imm Bit1))); - ("tmp_PSR_Z",BExp_Den (BVar "sy_tmp_PSR_Z" (BType_Imm Bit1))); - ("tmp_R0",BExp_Den (BVar "sy_tmp_R0" (BType_Imm Bit32))); - ("tmp_R1",BExp_Den (BVar "sy_tmp_R1" (BType_Imm Bit32))); - ("tmp_R2",BExp_Den (BVar "sy_tmp_R2" (BType_Imm Bit32))); - ("tmp_R3",BExp_Den (BVar "sy_tmp_R3" (BType_Imm Bit32))); - ("tmp_R4",BExp_Den (BVar "sy_tmp_R4" (BType_Imm Bit32))); - ("tmp_R5",BExp_Den (BVar "sy_tmp_R5" (BType_Imm Bit32))); - ("tmp_R6",BExp_Den (BVar "sy_tmp_R6" (BType_Imm Bit32))); - ("tmp_R7",BExp_Den (BVar "sy_tmp_R7" (BType_Imm Bit32))); - ("tmp_R8",BExp_Den (BVar "sy_tmp_R8" (BType_Imm Bit32))); - ("tmp_R9",BExp_Den (BVar "sy_tmp_R9" (BType_Imm Bit32))); - ("tmp_R10",BExp_Den (BVar "sy_tmp_R10" (BType_Imm Bit32))); - ("tmp_R11",BExp_Den (BVar "sy_tmp_R11" (BType_Imm Bit32))); - ("tmp_R12",BExp_Den (BVar "sy_tmp_R12" (BType_Imm Bit32))); - ("tmp_LR",BExp_Den (BVar "sy_tmp_LR" (BType_Imm Bit32))); - ("tmp_SP_main",BExp_Den (BVar "sy_tmp_SP_main" (BType_Imm Bit32))); - ("tmp_SP_process", - BExp_Den (BVar "sy_tmp_SP_process" (BType_Imm Bit32))); - ("tmp_ModeHandler", - BExp_Den (BVar "sy_tmp_ModeHandler" (BType_Imm Bit1))); - ("tmp_countw",BExp_Den (BVar "sy_tmp_countw" (BType_Imm Bit64)))]; - bsst_status := BST_Running; - bsst_pcond := - BExp_BinExp BIExp_And - (BExp_BinExp BIExp_And - (BExp_BinPred BIExp_LessOrEqual (BExp_Const (Imm32 0xFFFFFFw)) - (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32)))) - (BExp_BinPred BIExp_Equal - (BExp_BinExp BIExp_And - (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))) - (BExp_Const (Imm32 3w))) (BExp_Const (Imm32 0w)))) - (BExp_BinPred BIExp_LessOrEqual - (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) - (BExp_Const (Imm64 0xFFFFFFFFFFFFFF00w)))|>} DIFF -{birs_symb_to_symbst - <|bsst_pc := <|bpc_label := BL_Address (Imm32 2824w); bpc_index := 1|>; - bsst_environ := - birs_gen_env - [("MEM",BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); - ("PSR_C",BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); - ("PSR_N",BExp_Den (BVar "sy_PSR_N" (BType_Imm Bit1))); - ("PSR_V",BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); - ("PSR_Z",BExp_Den (BVar "sy_PSR_Z" (BType_Imm Bit1))); - ("R0",BExp_Den (BVar "sy_R0" (BType_Imm Bit32))); - ("R1",BExp_Den (BVar "sy_R1" (BType_Imm Bit32))); - ("R2",BExp_Den (BVar "sy_R2" (BType_Imm Bit32))); - ("R3",BExp_Den (BVar "sy_R3" (BType_Imm Bit32))); - ("R4",BExp_Den (BVar "sy_R4" (BType_Imm Bit32))); - ("R5",BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); - ("R6",BExp_Den (BVar "sy_R6" (BType_Imm Bit32))); - ("R7",BExp_Den (BVar "sy_R7" (BType_Imm Bit32))); - ("R8",BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); - ("R9",BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); - ("R10",BExp_Den (BVar "sy_R10" (BType_Imm Bit32))); - ("R11",BExp_Den (BVar "sy_R11" (BType_Imm Bit32))); - ("R12",BExp_Den (BVar "sy_R12" (BType_Imm Bit32))); - ("LR",BExp_Den (BVar "sy_LR" (BType_Imm Bit32))); - ("SP_main",BExp_Den (BVar "sy_SP_main" (BType_Imm Bit32))); - ("SP_process",BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))); - ("ModeHandler",BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1))); - ("countw",BExp_Den (BVar "sy_countw" (BType_Imm Bit64))); - ("tmp_PC",BExp_Den (BVar "sy_tmp_PC" (BType_Imm Bit32))); - ("tmp_COND",BExp_Den (BVar "sy_tmp_COND" (BType_Imm Bit1))); - ("tmp_MEM",BExp_Den (BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8))); - ("tmp_PSR_C",BExp_Den (BVar "sy_tmp_PSR_C" (BType_Imm Bit1))); - ("tmp_PSR_N",BExp_Den (BVar "sy_tmp_PSR_N" (BType_Imm Bit1))); - ("tmp_PSR_V",BExp_Den (BVar "sy_tmp_PSR_V" (BType_Imm Bit1))); - ("tmp_PSR_Z",BExp_Den (BVar "sy_tmp_PSR_Z" (BType_Imm Bit1))); - ("tmp_R0",BExp_Den (BVar "sy_tmp_R0" (BType_Imm Bit32))); - ("tmp_R1",BExp_Den (BVar "sy_tmp_R1" (BType_Imm Bit32))); - ("tmp_R2",BExp_Den (BVar "sy_tmp_R2" (BType_Imm Bit32))); - ("tmp_R3",BExp_Den (BVar "sy_tmp_R3" (BType_Imm Bit32))); - ("tmp_R4",BExp_Den (BVar "sy_tmp_R4" (BType_Imm Bit32))); - ("tmp_R5",BExp_Den (BVar "sy_tmp_R5" (BType_Imm Bit32))); - ("tmp_R6",BExp_Den (BVar "sy_tmp_R6" (BType_Imm Bit32))); - ("tmp_R7",BExp_Den (BVar "sy_tmp_R7" (BType_Imm Bit32))); - ("tmp_R8",BExp_Den (BVar "sy_tmp_R8" (BType_Imm Bit32))); - ("tmp_R9",BExp_Den (BVar "sy_tmp_R9" (BType_Imm Bit32))); - ("tmp_R10",BExp_Den (BVar "sy_tmp_R10" (BType_Imm Bit32))); - ("tmp_R11",BExp_Den (BVar "sy_tmp_R11" (BType_Imm Bit32))); - ("tmp_R12",BExp_Den (BVar "sy_tmp_R12" (BType_Imm Bit32))); - ("tmp_LR",BExp_Den (BVar "sy_tmp_LR" (BType_Imm Bit32))); - ("tmp_SP_main",BExp_Den (BVar "sy_tmp_SP_main" (BType_Imm Bit32))); - ("tmp_SP_process", - BExp_Den (BVar "sy_tmp_SP_process" (BType_Imm Bit32))); - ("tmp_ModeHandler", - BExp_Den (BVar "sy_tmp_ModeHandler" (BType_Imm Bit1))); - ("tmp_countw",BExp_Den (BVar "sy_tmp_countw" (BType_Imm Bit64)))]; - bsst_status := BST_Running; - bsst_pcond := - BExp_BinExp BIExp_And - (BExp_BinExp BIExp_And - (BExp_BinPred BIExp_LessOrEqual (BExp_Const (Imm32 0xFFFFFFw)) - (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32)))) - (BExp_BinPred BIExp_Equal - (BExp_BinExp BIExp_And - (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))) - (BExp_Const (Imm32 3w))) (BExp_Const (Imm32 0w)))) - (BExp_BinPred BIExp_LessOrEqual - (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) - (BExp_Const (Imm64 0xFFFFFFFFFFFFFF00w)))|>} ∪ -IMAGE birs_symb_to_symbst - {<|bsst_pc := <|bpc_label := BL_Address (Imm32 2824w); bpc_index := 2|>; - bsst_environ := - birs_gen_env - [("MEM",BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); - ("PSR_C",BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); - ("PSR_N",BExp_Den (BVar "sy_PSR_N" (BType_Imm Bit1))); - ("PSR_V",BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); - ("PSR_Z",BExp_Den (BVar "sy_PSR_Z" (BType_Imm Bit1))); - ("R0",BExp_Den (BVar "sy_R0" (BType_Imm Bit32))); - ("R1",BExp_Den (BVar "sy_R1" (BType_Imm Bit32))); - ("R2",BExp_Den (BVar "sy_R2" (BType_Imm Bit32))); - ("R3",BExp_Den (BVar "sy_R3" (BType_Imm Bit32))); - ("R4",BExp_Den (BVar "sy_R4" (BType_Imm Bit32))); - ("R5",BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); - ("R6",BExp_Den (BVar "sy_R6" (BType_Imm Bit32))); - ("R7",BExp_Den (BVar "sy_R7" (BType_Imm Bit32))); - ("R8",BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); - ("R9",BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); - ("R10",BExp_Den (BVar "sy_R10" (BType_Imm Bit32))); - ("R11",BExp_Den (BVar "sy_R11" (BType_Imm Bit32))); - ("R12",BExp_Den (BVar "sy_R12" (BType_Imm Bit32))); - ("LR",BExp_Den (BVar "sy_LR" (BType_Imm Bit32))); - ("SP_main",BExp_Den (BVar "sy_SP_main" (BType_Imm Bit32))); - ("SP_process",BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))); - ("ModeHandler",BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1))); - ("countw",BExp_Den (BVar "sy_countw" (BType_Imm Bit64))); - ("tmp_PC",BExp_Den (BVar "sy_tmp_PC" (BType_Imm Bit32))); - ("tmp_COND",BExp_Den (BVar "sy_tmp_COND" (BType_Imm Bit1))); - ("tmp_MEM",BExp_Den (BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8))); - ("tmp_PSR_C",BExp_Den (BVar "sy_tmp_PSR_C" (BType_Imm Bit1))); - ("tmp_PSR_N",BExp_Den (BVar "sy_tmp_PSR_N" (BType_Imm Bit1))); - ("tmp_PSR_V",BExp_Den (BVar "sy_tmp_PSR_V" (BType_Imm Bit1))); - ("tmp_PSR_Z",BExp_Den (BVar "sy_tmp_PSR_Z" (BType_Imm Bit1))); - ("tmp_R0",BExp_Den (BVar "sy_tmp_R0" (BType_Imm Bit32))); - ("tmp_R1",BExp_Den (BVar "sy_tmp_R1" (BType_Imm Bit32))); - ("tmp_R2",BExp_Den (BVar "sy_tmp_R2" (BType_Imm Bit32))); - ("tmp_R3",BExp_Den (BVar "sy_tmp_R3" (BType_Imm Bit32))); - ("tmp_R4",BExp_Den (BVar "sy_tmp_R4" (BType_Imm Bit32))); - ("tmp_R5",BExp_Den (BVar "sy_tmp_R5" (BType_Imm Bit32))); - ("tmp_R6",BExp_Den (BVar "sy_tmp_R6" (BType_Imm Bit32))); - ("tmp_R7",BExp_Den (BVar "sy_tmp_R7" (BType_Imm Bit32))); - ("tmp_R8",BExp_Den (BVar "sy_tmp_R8" (BType_Imm Bit32))); - ("tmp_R9",BExp_Den (BVar "sy_tmp_R9" (BType_Imm Bit32))); - ("tmp_R10",BExp_Den (BVar "sy_tmp_R10" (BType_Imm Bit32))); - ("tmp_R11",BExp_Den (BVar "sy_tmp_R11" (BType_Imm Bit32))); - ("tmp_R12",BExp_Den (BVar "sy_tmp_R12" (BType_Imm Bit32))); - ("tmp_LR",BExp_Den (BVar "sy_tmp_LR" (BType_Imm Bit32))); - ("tmp_SP_main",BExp_Den (BVar "sy_tmp_SP_main" (BType_Imm Bit32))); - ("tmp_SP_process", - BExp_Den (BVar "sy_tmp_SP_process" (BType_Imm Bit32))); - ("tmp_ModeHandler", - BExp_Den (BVar "sy_tmp_ModeHandler" (BType_Imm Bit1))); - ("tmp_countw",BExp_Den (BVar "sy_tmp_countw" (BType_Imm Bit64)))]; - bsst_status := BST_Running; - bsst_pcond := - BExp_BinExp BIExp_And - (BExp_BinExp BIExp_And - (BExp_BinPred BIExp_LessOrEqual (BExp_Const (Imm32 0xFFFFFFw)) - (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32)))) - (BExp_BinPred BIExp_Equal - (BExp_BinExp BIExp_And - (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))) - (BExp_Const (Imm32 3w))) (BExp_Const (Imm32 0w)))) - (BExp_BinPred BIExp_LessOrEqual - (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) - (BExp_Const (Imm64 0xFFFFFFFFFFFFFF00w)))|>}``; -*) - -val IMAGE_DIFF_SING_thm = prove(`` -!f s x. - (IMAGE f s) DIFF {f x} = - (IMAGE f s) DIFF (IMAGE f {x}) -``, - SIMP_TAC std_ss [IMAGE_INSERT, IMAGE_EMPTY] -); - - -val IMAGE_DIFF_ASSOC_thm = prove(`` -!f s1 s2. - (!x y. f x = f y <=> x = y) ==> - ((IMAGE f s1) DIFF (IMAGE f s2) = - IMAGE f (s1 DIFF s2)) -``, - REPEAT STRIP_TAC >> - SIMP_TAC std_ss [IMAGE_INSERT, IMAGE_EMPTY, EXTENSION] >> - SIMP_TAC (std_ss++pred_setSimps.PRED_SET_ss) [] >> - REPEAT STRIP_TAC >> - EQ_TAC >> ( - REPEAT STRIP_TAC >> - METIS_TAC [] - ) -); - - -val IMAGE_UNION_ASSOC_thm = prove(`` -!f s1 s2. - (!x y. f x = f y <=> x = y) ==> - ((IMAGE f s1) UNION (IMAGE f s2) = - IMAGE f (s1 UNION s2)) -``, - REPEAT STRIP_TAC >> - SIMP_TAC std_ss [IMAGE_INSERT, IMAGE_EMPTY, EXTENSION] >> - SIMP_TAC (std_ss++pred_setSimps.PRED_SET_ss) [] >> - REPEAT STRIP_TAC >> - EQ_TAC >> ( - REPEAT STRIP_TAC >> - METIS_TAC [] - ) -); - - - fun DIFF_UNION_CONV_cheat tm = - let - val pat_tm = ``(IMAGE (birs_symb_to_symbst) Pi_a) DIFF {birs_symb_to_symbst sys_b} UNION (IMAGE birs_symb_to_symbst Pi_b)``; - val (tm_match, ty_match) = match_term pat_tm tm; - - val Pi_a = pred_setSyntax.strip_set(subst tm_match (inst ty_match ``Pi_a:birs_state_t->bool``)); - val sys_b = subst tm_match (inst ty_match ``sys_b:birs_state_t``); - val Pi_b = pred_setSyntax.strip_set(subst tm_match (inst ty_match ``Pi_b:birs_state_t->bool``)); - - fun eq_fun sys1 sys2 = identical sys1 sys2; (* TODO: birs_state_eq_fun*) - fun in_f l x = List.foldr (fn (y, b) => b orelse eq_fun x y) false l; - val Pi_a_minus_b = List.filter (not o eq_fun sys_b) Pi_a; - fun UNION_foldfun (sys,Pi) = if in_f Pi sys then Pi else (sys::Pi); - val Pi_c = List.foldr UNION_foldfun Pi_a_minus_b Pi_b; - val tm_l_set = if List.null Pi_c then pred_setSyntax.mk_empty (``:birs_state_t``) else pred_setSyntax.mk_set Pi_c; -(* -length Pi_a -length Pi_a_minus_b -length Pi_c -*) - in - prove(``^tm = IMAGE birs_symb_to_symbst ^tm_l_set``, cheat) - end; - - val diffunioncheat_on = false; - val birs_state_DIFF_UNION_CONV = - if diffunioncheat_on then - DIFF_UNION_CONV_cheat - else - fn tm => - (REWRITE_CONV [IMAGE_DIFF_SING_thm, MATCH_MP IMAGE_DIFF_ASSOC_thm bir_symbTheory.birs_symb_to_symbst_EQ_thm, GSYM DELETE_DEF] THENC - RATOR_CONV (RAND_CONV (RAND_CONV ( - -fn tm => -( -pred_setLib.DELETE_CONV birs_state_EQ_CONV tm -handle ex => - (print "\n\n\n"; - print_term tm; - print "\n\n\n"; - raise ex - ) -) - - -))) THENC - REWRITE_CONV [MATCH_MP IMAGE_UNION_ASSOC_thm bir_symbTheory.birs_symb_to_symbst_EQ_thm] THENC - RAND_CONV (pred_setLib.UNION_CONV birs_state_EQ_CONV)) - - tm; - - - -(* ------------------------------------------------------------------------ *) -(* COPIED FROM TRANSFER-TEST (and modified) *) -(* ------------------------------------------------------------------------ *) - -(* -val tm = `` -birs_symb_symbols - <|bsst_pc := <|bpc_label := BL_Address (Imm32 2824w); bpc_index := 0|>; - bsst_environ := (K NONE)⦇ - "MEM" ↦ SOME (BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); - "PSR_C" ↦ SOME (BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); - "PSR_N" ↦ SOME (BExp_Den (BVar "sy_PSR_N" (BType_Imm Bit1))); - "PSR_V" ↦ SOME (BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); - "PSR_Z" ↦ SOME (BExp_Den (BVar "sy_PSR_Z" (BType_Imm Bit1))); - "R0" ↦ SOME (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))); - "R1" ↦ SOME (BExp_Den (BVar "sy_R1" (BType_Imm Bit32))); - "R2" ↦ SOME (BExp_Den (BVar "sy_R2" (BType_Imm Bit32))); - "R3" ↦ SOME (BExp_Den (BVar "sy_R3" (BType_Imm Bit32))); - "R4" ↦ SOME (BExp_Den (BVar "sy_R4" (BType_Imm Bit32))); - "R5" ↦ SOME (BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); - "R6" ↦ SOME (BExp_Den (BVar "sy_R6" (BType_Imm Bit32))); - "R7" ↦ SOME (BExp_Den (BVar "sy_R7" (BType_Imm Bit32))); - "R8" ↦ SOME (BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); - "R9" ↦ SOME (BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); - "R10" ↦ SOME (BExp_Den (BVar "sy_R10" (BType_Imm Bit32))); - "R11" ↦ SOME (BExp_Den (BVar "sy_R11" (BType_Imm Bit32))); - "R12" ↦ SOME (BExp_Den (BVar "sy_R12" (BType_Imm Bit32))); - "LR" ↦ SOME (BExp_Den (BVar "sy_LR" (BType_Imm Bit32))); - "SP_main" ↦ - SOME (BExp_Den (BVar "sy_SP_main" (BType_Imm Bit32))); - "SP_process" ↦ - SOME (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))); - "ModeHandler" ↦ - SOME (BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1))); - "countw" ↦ SOME (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))); - "tmp_PC" ↦ SOME (BExp_Den (BVar "sy_tmp_PC" (BType_Imm Bit32))); - "tmp_COND" ↦ - SOME (BExp_Den (BVar "sy_tmp_COND" (BType_Imm Bit1))); - "tmp_MEM" ↦ - SOME (BExp_Den (BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8))); - "tmp_PSR_C" ↦ - SOME (BExp_Den (BVar "sy_tmp_PSR_C" (BType_Imm Bit1))); - "tmp_PSR_N" ↦ - SOME (BExp_Den (BVar "sy_tmp_PSR_N" (BType_Imm Bit1))); - "tmp_PSR_V" ↦ - SOME (BExp_Den (BVar "sy_tmp_PSR_V" (BType_Imm Bit1))); - "tmp_PSR_Z" ↦ - SOME (BExp_Den (BVar "sy_tmp_PSR_Z" (BType_Imm Bit1))); - "tmp_R0" ↦ SOME (BExp_Den (BVar "sy_tmp_R0" (BType_Imm Bit32))); - "tmp_R1" ↦ SOME (BExp_Den (BVar "sy_tmp_R1" (BType_Imm Bit32))); - "tmp_R2" ↦ SOME (BExp_Den (BVar "sy_tmp_R2" (BType_Imm Bit32))); - "tmp_R3" ↦ SOME (BExp_Den (BVar "sy_tmp_R3" (BType_Imm Bit32))); - "tmp_R4" ↦ SOME (BExp_Den (BVar "sy_tmp_R4" (BType_Imm Bit32))); - "tmp_R5" ↦ SOME (BExp_Den (BVar "sy_tmp_R5" (BType_Imm Bit32))); - "tmp_R6" ↦ SOME (BExp_Den (BVar "sy_tmp_R6" (BType_Imm Bit32))); - "tmp_R7" ↦ SOME (BExp_Den (BVar "sy_tmp_R7" (BType_Imm Bit32))); - "tmp_R8" ↦ SOME (BExp_Den (BVar "sy_tmp_R8" (BType_Imm Bit32))); - "tmp_R9" ↦ SOME (BExp_Den (BVar "sy_tmp_R9" (BType_Imm Bit32))); - "tmp_R10" ↦ - SOME (BExp_Den (BVar "sy_tmp_R10" (BType_Imm Bit32))); - "tmp_R11" ↦ - SOME (BExp_Den (BVar "sy_tmp_R11" (BType_Imm Bit32))); - "tmp_R12" ↦ - SOME (BExp_Den (BVar "sy_tmp_R12" (BType_Imm Bit32))); - "tmp_LR" ↦ SOME (BExp_Den (BVar "sy_tmp_LR" (BType_Imm Bit32))); - "tmp_SP_main" ↦ - SOME (BExp_Den (BVar "sy_tmp_SP_main" (BType_Imm Bit32))); - "tmp_SP_process" ↦ - SOME (BExp_Den (BVar "sy_tmp_SP_process" (BType_Imm Bit32))); - "tmp_ModeHandler" ↦ - SOME (BExp_Den (BVar "sy_tmp_ModeHandler" (BType_Imm Bit1))); - "tmp_countw" ↦ - SOME (BExp_Den (BVar "sy_tmp_countw" (BType_Imm Bit64))) - ⦈; - bsst_status := BST_Running; bsst_pcond := BExp_BinExp BIExp_Plus (BExp_Den (BVar "hello" (BType_Imm Bit8))) (BExp_BinExp BIExp_Plus (BExp_Den (BVar "hello" (BType_Imm Bit8))) (BExp_Const (Imm1 1w)))|> -``; - -val tm = `` -birs_exps_of_senv - (K NONE)⦇ - "MEM" ↦ SOME (BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); - "PSR_C" ↦ SOME (BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); - "PSR_N" ↦ SOME (BExp_Den (BVar "sy_PSR_N" (BType_Imm Bit1))); - "PSR_V" ↦ SOME (BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); - "PSR_Z" ↦ SOME (BExp_Den (BVar "sy_PSR_Z" (BType_Imm Bit1))); - "R0" ↦ SOME (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))); - "R1" ↦ SOME (BExp_Den (BVar "sy_R1" (BType_Imm Bit32))); - "R2" ↦ SOME (BExp_Den (BVar "sy_R2" (BType_Imm Bit32))); - "R3" ↦ SOME (BExp_Den (BVar "sy_R3" (BType_Imm Bit32))); - "R4" ↦ SOME (BExp_Den (BVar "sy_R4" (BType_Imm Bit32))); - "R5" ↦ SOME (BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); - "R6" ↦ SOME (BExp_Den (BVar "sy_R6" (BType_Imm Bit32))); - "R7" ↦ SOME (BExp_Den (BVar "sy_R7" (BType_Imm Bit32))); - "R8" ↦ SOME (BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); - "R9" ↦ SOME (BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); - "R10" ↦ SOME (BExp_Den (BVar "sy_R10" (BType_Imm Bit32))); - "R11" ↦ SOME (BExp_Den (BVar "sy_R11" (BType_Imm Bit32))); - "R12" ↦ SOME (BExp_Den (BVar "sy_R12" (BType_Imm Bit32))); - "LR" ↦ SOME (BExp_Den (BVar "sy_LR" (BType_Imm Bit32))); - "SP_main" ↦ SOME (BExp_Den (BVar "sy_SP_main" (BType_Imm Bit32))); - "SP_process" ↦ SOME (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))); - "ModeHandler" ↦ SOME (BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1))); - "countw" ↦ SOME (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))); - "tmp_PC" ↦ SOME (BExp_Den (BVar "sy_tmp_PC" (BType_Imm Bit32))); - "tmp_COND" ↦ SOME (BExp_Den (BVar "sy_tmp_COND" (BType_Imm Bit1))); - "tmp_MEM" ↦ SOME (BExp_Den (BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8))); - "tmp_PSR_C" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_C" (BType_Imm Bit1))); - "tmp_PSR_N" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_N" (BType_Imm Bit1))); - "tmp_PSR_V" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_V" (BType_Imm Bit1))); - "tmp_PSR_Z" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_Z" (BType_Imm Bit1))); - "tmp_R0" ↦ SOME (BExp_Den (BVar "sy_tmp_R0" (BType_Imm Bit32))); - "tmp_R1" ↦ SOME (BExp_Den (BVar "sy_tmp_R1" (BType_Imm Bit32))); - "tmp_R2" ↦ SOME (BExp_Den (BVar "sy_tmp_R2" (BType_Imm Bit32))); - "tmp_R3" ↦ SOME (BExp_Den (BVar "sy_tmp_R3" (BType_Imm Bit32))); - "tmp_R4" ↦ SOME (BExp_Den (BVar "sy_tmp_R4" (BType_Imm Bit32))); - "tmp_R5" ↦ SOME (BExp_Den (BVar "sy_tmp_R5" (BType_Imm Bit32))); - "tmp_R6" ↦ SOME (BExp_Den (BVar "sy_tmp_R6" (BType_Imm Bit32))); - "tmp_R7" ↦ SOME (BExp_Den (BVar "sy_tmp_R7" (BType_Imm Bit32))); - "tmp_R8" ↦ SOME (BExp_Den (BVar "sy_tmp_R8" (BType_Imm Bit32))); - "tmp_R9" ↦ SOME (BExp_Den (BVar "sy_tmp_R9" (BType_Imm Bit32))); - "tmp_R10" ↦ SOME (BExp_Den (BVar "sy_tmp_R10" (BType_Imm Bit32))); - "tmp_R11" ↦ SOME (BExp_Den (BVar "sy_tmp_R11" (BType_Imm Bit32))); - "tmp_R12" ↦ SOME (BExp_Den (BVar "sy_tmp_R12" (BType_Imm Bit32))); - "tmp_LR" ↦ SOME (BExp_Den (BVar "sy_tmp_LR" (BType_Imm Bit32))); - "tmp_SP_main" ↦ SOME (BExp_Den (BVar "sy_tmp_SP_main" (BType_Imm Bit32))); - "tmp_SP_process" ↦ - SOME (BExp_Den (BVar "sy_tmp_SP_process" (BType_Imm Bit32))); - "tmp_ModeHandler" ↦ - SOME (BExp_Den (BVar "sy_tmp_ModeHandler" (BType_Imm Bit1))); - "tmp_countw" ↦ SOME (BExp_Den (BVar "sy_tmp_countw" (BType_Imm Bit64))) - ⦈ -``; - -val tm = `` - birs_exps_of_senv_COMP ∅ - (K NONE)⦇ - "MEM" ↦ SOME (BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); - "PSR_C" ↦ SOME (BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); - "PSR_N" ↦ SOME (BExp_Den (BVar "sy_PSR_N" (BType_Imm Bit1))); - "PSR_V" ↦ SOME (BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); - "PSR_Z" ↦ SOME (BExp_Den (BVar "sy_PSR_Z" (BType_Imm Bit1))); - "R0" ↦ SOME (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))); - "R1" ↦ SOME (BExp_Den (BVar "sy_R1" (BType_Imm Bit32))); - "R2" ↦ SOME (BExp_Den (BVar "sy_R2" (BType_Imm Bit32))); - "R3" ↦ SOME (BExp_Den (BVar "sy_R3" (BType_Imm Bit32))); - "R4" ↦ SOME (BExp_Den (BVar "sy_R4" (BType_Imm Bit32))); - "R5" ↦ SOME (BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); - "R6" ↦ SOME (BExp_Den (BVar "sy_R6" (BType_Imm Bit32))); - "R7" ↦ SOME (BExp_Den (BVar "sy_R7" (BType_Imm Bit32))); - "R8" ↦ SOME (BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); - "R9" ↦ SOME (BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); - "R10" ↦ SOME (BExp_Den (BVar "sy_R10" (BType_Imm Bit32))); - "R11" ↦ SOME (BExp_Den (BVar "sy_R11" (BType_Imm Bit32))); - "R12" ↦ SOME (BExp_Den (BVar "sy_R12" (BType_Imm Bit32))); - "LR" ↦ SOME (BExp_Den (BVar "sy_LR" (BType_Imm Bit32))); - "SP_main" ↦ SOME (BExp_Den (BVar "sy_SP_main" (BType_Imm Bit32))); - "SP_process" ↦ - SOME (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))); - "ModeHandler" ↦ - SOME (BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1))); - "countw" ↦ SOME (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))); - "tmp_PC" ↦ SOME (BExp_Den (BVar "sy_tmp_PC" (BType_Imm Bit32))); - "tmp_COND" ↦ SOME (BExp_Den (BVar "sy_tmp_COND" (BType_Imm Bit1))); - "tmp_MEM" ↦ - SOME (BExp_Den (BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8))); - "tmp_PSR_C" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_C" (BType_Imm Bit1))); - "tmp_PSR_N" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_N" (BType_Imm Bit1))); - "tmp_PSR_V" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_V" (BType_Imm Bit1))); - "tmp_PSR_Z" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_Z" (BType_Imm Bit1))); - "tmp_R0" ↦ SOME (BExp_Den (BVar "sy_tmp_R0" (BType_Imm Bit32))); - "tmp_R1" ↦ SOME (BExp_Den (BVar "sy_tmp_R1" (BType_Imm Bit32))); - "tmp_R2" ↦ SOME (BExp_Den (BVar "sy_tmp_R2" (BType_Imm Bit32))); - "tmp_R3" ↦ SOME (BExp_Den (BVar "sy_tmp_R3" (BType_Imm Bit32))); - "tmp_R4" ↦ SOME (BExp_Den (BVar "sy_tmp_R4" (BType_Imm Bit32))); - "tmp_R5" ↦ SOME (BExp_Den (BVar "sy_tmp_R5" (BType_Imm Bit32))); - "tmp_R6" ↦ SOME (BExp_Den (BVar "sy_tmp_R6" (BType_Imm Bit32))); - "tmp_R7" ↦ SOME (BExp_Den (BVar "sy_tmp_R7" (BType_Imm Bit32))); - "tmp_R8" ↦ SOME (BExp_Den (BVar "sy_tmp_R8" (BType_Imm Bit32))); - "tmp_R9" ↦ SOME (BExp_Den (BVar "sy_tmp_R9" (BType_Imm Bit32))); - "tmp_R10" ↦ SOME (BExp_Den (BVar "sy_tmp_R10" (BType_Imm Bit32))); - "tmp_R11" ↦ SOME (BExp_Den (BVar "sy_tmp_R11" (BType_Imm Bit32))); - "tmp_R12" ↦ SOME (BExp_Den (BVar "sy_tmp_R12" (BType_Imm Bit32))); - "tmp_LR" ↦ SOME (BExp_Den (BVar "sy_tmp_LR" (BType_Imm Bit32))); - "tmp_SP_main" ↦ - SOME (BExp_Den (BVar "sy_tmp_SP_main" (BType_Imm Bit32))); - "tmp_SP_process" ↦ - SOME (BExp_Den (BVar "sy_tmp_SP_process" (BType_Imm Bit32))); - "tmp_ModeHandler" ↦ - SOME (BExp_Den (BVar "sy_tmp_ModeHandler" (BType_Imm Bit1))); - "tmp_countw" ↦ - SOME (BExp_Den (BVar "sy_tmp_countw" (BType_Imm Bit64))) - ⦈ -``; - -val tm = `` - birs_exps_of_senv_COMP ∅ - (K NONE)⦇ - "MEM" ↦ SOME (BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); - "PSR_C" ↦ SOME (BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); - "PSR_N" ↦ SOME (BExp_Den (BVar "sy_PSR_N" (BType_Imm Bit1))); - "PSR_V" ↦ SOME (BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); - "PSR_Z" ↦ SOME (BExp_Den (BVar "sy_PSR_Z" (BType_Imm Bit1))) - ⦈ -``; - -val tm2 = `` - birs_exps_of_senv_COMP ∅ - (K NONE) -``; - -val tm = `` -birs_exps_of_senv_COMP {"PSR_Z"; "PSR_V"; "PSR_N"; "PSR_C"; "MEM"} (K NONE) -``; val tm = `` -birs_exps_of_senv - (K NONE)⦇ - "tmp_SP_process" ↦ - SOME - (BExp_BinExp BIExp_Minus - (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))) - (BExp_Const (Imm32 8w))); - "MEM" ↦ SOME (BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); - "PSR_C" ↦ SOME (BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); - "PSR_N" ↦ SOME (BExp_Den (BVar "sy_PSR_N" (BType_Imm Bit1))); - "PSR_V" ↦ SOME (BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); - "PSR_Z" ↦ SOME (BExp_Den (BVar "sy_PSR_Z" (BType_Imm Bit1))); - "R0" ↦ SOME (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))); - "R1" ↦ SOME (BExp_Den (BVar "sy_R1" (BType_Imm Bit32))); - "R2" ↦ SOME (BExp_Den (BVar "sy_R2" (BType_Imm Bit32))); - "R3" ↦ SOME (BExp_Den (BVar "sy_R3" (BType_Imm Bit32))); - "R4" ↦ SOME (BExp_Den (BVar "sy_R4" (BType_Imm Bit32))); - "R5" ↦ SOME (BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); - "R6" ↦ SOME (BExp_Den (BVar "sy_R6" (BType_Imm Bit32))); - "R7" ↦ SOME (BExp_Den (BVar "sy_R7" (BType_Imm Bit32))); - "R8" ↦ SOME (BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); - "R9" ↦ SOME (BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); - "R10" ↦ SOME (BExp_Den (BVar "sy_R10" (BType_Imm Bit32))); - "R11" ↦ SOME (BExp_Den (BVar "sy_R11" (BType_Imm Bit32))); - "R12" ↦ SOME (BExp_Den (BVar "sy_R12" (BType_Imm Bit32))); - "LR" ↦ SOME (BExp_Den (BVar "sy_LR" (BType_Imm Bit32))); - "SP_main" ↦ SOME (BExp_Den (BVar "sy_SP_main" (BType_Imm Bit32))); - "SP_process" ↦ SOME (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))); - "ModeHandler" ↦ SOME (BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1))); - "countw" ↦ SOME (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))); - "tmp_PC" ↦ SOME (BExp_Den (BVar "sy_tmp_PC" (BType_Imm Bit32))); - "tmp_COND" ↦ SOME (BExp_Den (BVar "sy_tmp_COND" (BType_Imm Bit1))); - "tmp_MEM" ↦ SOME (BExp_Den (BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8))); - "tmp_PSR_C" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_C" (BType_Imm Bit1))); - "tmp_PSR_N" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_N" (BType_Imm Bit1))); - "tmp_PSR_V" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_V" (BType_Imm Bit1))); - "tmp_PSR_Z" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_Z" (BType_Imm Bit1))); - "tmp_R0" ↦ SOME (BExp_Den (BVar "sy_tmp_R0" (BType_Imm Bit32))); - "tmp_R1" ↦ SOME (BExp_Den (BVar "sy_tmp_R1" (BType_Imm Bit32))); - "tmp_R2" ↦ SOME (BExp_Den (BVar "sy_tmp_R2" (BType_Imm Bit32))); - "tmp_R3" ↦ SOME (BExp_Den (BVar "sy_tmp_R3" (BType_Imm Bit32))); - "tmp_R4" ↦ SOME (BExp_Den (BVar "sy_tmp_R4" (BType_Imm Bit32))); - "tmp_R5" ↦ SOME (BExp_Den (BVar "sy_tmp_R5" (BType_Imm Bit32))); - "tmp_R6" ↦ SOME (BExp_Den (BVar "sy_tmp_R6" (BType_Imm Bit32))); - "tmp_R7" ↦ SOME (BExp_Den (BVar "sy_tmp_R7" (BType_Imm Bit32))); - "tmp_R8" ↦ SOME (BExp_Den (BVar "sy_tmp_R8" (BType_Imm Bit32))); - "tmp_R9" ↦ SOME (BExp_Den (BVar "sy_tmp_R9" (BType_Imm Bit32))); - "tmp_R10" ↦ SOME (BExp_Den (BVar "sy_tmp_R10" (BType_Imm Bit32))); - "tmp_R11" ↦ SOME (BExp_Den (BVar "sy_tmp_R11" (BType_Imm Bit32))); - "tmp_R12" ↦ SOME (BExp_Den (BVar "sy_tmp_R12" (BType_Imm Bit32))); - "tmp_LR" ↦ SOME (BExp_Den (BVar "sy_tmp_LR" (BType_Imm Bit32))); - "tmp_SP_main" ↦ SOME (BExp_Den (BVar "sy_tmp_SP_main" (BType_Imm Bit32))); - "tmp_SP_process" ↦ - SOME (BExp_Den (BVar "sy_tmp_SP_process" (BType_Imm Bit32))); - "tmp_ModeHandler" ↦ - SOME (BExp_Den (BVar "sy_tmp_ModeHandler" (BType_Imm Bit1))); - "tmp_countw" ↦ SOME (BExp_Den (BVar "sy_tmp_countw" (BType_Imm Bit64))) - ⦈ +BVar "sy_countw" (BType_Imm Bit64) ∈ + {BVar "sy_MEM" (BType_Mem Bit32 Bit8); + BVar "sy_PSR_C" (BType_Imm Bit1); BVar "sy_PSR_N" (BType_Imm Bit1); + BVar "sy_PSR_V" (BType_Imm Bit1); BVar "sy_PSR_Z" (BType_Imm Bit1); + BVar "sy_R0" (BType_Imm Bit32); BVar "sy_R1" (BType_Imm Bit32); + BVar "sy_R2" (BType_Imm Bit32); BVar "sy_R3" (BType_Imm Bit32); + BVar "sy_R4" (BType_Imm Bit32); BVar "sy_R5" (BType_Imm Bit32); + BVar "sy_R6" (BType_Imm Bit32); BVar "sy_R7" (BType_Imm Bit32); + BVar "sy_R8" (BType_Imm Bit32); BVar "sy_R9" (BType_Imm Bit32); + BVar "sy_R10" (BType_Imm Bit32); BVar "sy_R11" (BType_Imm Bit32); + BVar "sy_R12" (BType_Imm Bit32); BVar "sy_LR" (BType_Imm Bit32); + BVar "sy_SP_main" (BType_Imm Bit32); + BVar "sy_SP_process" (BType_Imm Bit32); + BVar "sy_ModeHandler" (BType_Imm Bit1); + BVar "sy_countw" (BType_Imm Bit64); + BVar "sy_tmp_PC" (BType_Imm Bit32); + BVar "sy_tmp_COND" (BType_Imm Bit1); + BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); + BVar "sy_tmp_PSR_C" (BType_Imm Bit1); + BVar "sy_tmp_PSR_N" (BType_Imm Bit1); + BVar "sy_tmp_PSR_V" (BType_Imm Bit1); + BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); + BVar "sy_tmp_R0" (BType_Imm Bit32); + BVar "sy_tmp_R1" (BType_Imm Bit32); + BVar "sy_tmp_R2" (BType_Imm Bit32); + BVar "sy_tmp_R3" (BType_Imm Bit32); + BVar "sy_tmp_R4" (BType_Imm Bit32); + BVar "sy_tmp_R5" (BType_Imm Bit32); + BVar "sy_tmp_R6" (BType_Imm Bit32); + BVar "sy_tmp_R7" (BType_Imm Bit32); + BVar "sy_tmp_R8" (BType_Imm Bit32); + BVar "sy_tmp_R9" (BType_Imm Bit32); + BVar "sy_tmp_R10" (BType_Imm Bit32); + BVar "sy_tmp_R11" (BType_Imm Bit32); + BVar "sy_tmp_R12" (BType_Imm Bit32); + BVar "sy_tmp_LR" (BType_Imm Bit32); + BVar "sy_tmp_SP_main" (BType_Imm Bit32); + BVar "sy_tmp_SP_process" (BType_Imm Bit32); + BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); + BVar "sy_tmp_countw" (BType_Imm Bit64)} ``; -val tm = `` -birs_exps_of_senv_COMP {"tmp_SP_process"} - (K NONE)⦇ - "tmp_SP_process" ↦ - SOME - (BExp_BinExp BIExp_Minus - (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))) - (BExp_Const (Imm32 8w))); - "tmp_ModeHandler" ↦ - SOME (BExp_Den (BVar "sy_tmp_ModeHandler" (BType_Imm Bit1))); - "tmp_countw" ↦ - SOME (BExp_Den (BVar "sy_tmp_countw" (BType_Imm Bit64))) - ⦈ -``; - *) -val debug_conv = (fn tm => (print_term tm; raise Fail "abcdE!!!")); -val debug_conv2 = (fn tm => (if true then print ".\n" else print_term tm; REFL tm)); - -(* -REPEATC - (SIMP_CONV (std_ss) []) THENC - (ONCE_DEPTH_CONV ( (PAT_CONV ``\A. if A then B else (C)`` (REWRITE_CONV [pred_setTheory.COMPONENT] THENC SIMP_CONV std_ss [pred_setTheory.IN_INSERT])))) THENC - SIMP_CONV (std_ss) [] -*) +(* 65 * 30 * t_IN_VAR = 9-10s +t_IN_VAR = 0.005s *) +(* !!!!! try computeLib *) +val string_ss = rewrites (type_rws ``:string``); -(* ................................................ *) +val el_EQ_CONV = SIMP_CONV (std_ss++HolBACoreSimps.holBACore_ss++string_ss) []; +val el_EQ_CONV = RAND_CONV EVAL; -fun string_in_set_CONV tm = +fun IN_INSERT_CONV el_EQ_CONV tm = ( REWRITE_CONV [pred_setTheory.NOT_IN_EMPTY] THENC - REPEATC (CHANGED_CONV ((fn xyz => REWRITE_CONV [Once pred_setTheory.IN_INSERT] xyz) THENC + REPEATC (CHANGED_CONV ( + (fn xyz => REWRITE_CONV [Once pred_setTheory.IN_INSERT] xyz) THENC + (*(fn tm => (if false then print ".\n" else print_term tm; print "aa\n\n"; REFL tm)) THENC*) IFC - (RATOR_CONV EVAL) - (BETA_CONV THENC REWRITE_CONV [pred_setTheory.NOT_IN_EMPTY]) + (RATOR_CONV el_EQ_CONV) + (REWRITE_CONV [pred_setTheory.NOT_IN_EMPTY]) REFL)) ) tm; -fun birs_exps_of_senv_COMP_ONCE_CONV tm = +fun INTER_INSERT_ONCE_CONV el_EQ_CONV tm = ( - (QCHANGED_CONV (CHANGED_CONV (fn x => REWRITE_CONV [Once birs_exps_of_senv_COMP_thm] x))) THENC + (QCHANGED_CONV (CHANGED_CONV (fn x => REWRITE_CONV [Once pred_setTheory.INSERT_INTER, pred_setTheory.INTER_EMPTY] x))) THENC IFC - (RATOR_CONV (RATOR_CONV (RAND_CONV (string_in_set_CONV)))) + (RATOR_CONV (RATOR_CONV (RAND_CONV ( +(* +fn tm => (print_term (concl (prove (mk_eq (tm, F), cheat))); prove (mk_eq (tm, F), cheat)) +*) +(*fn tm => (prove (mk_eq (tm, F), cheat))*) +(*(fn tm => (if false then print ".\n" else print_term tm; print "aa\n\n"; REFL tm)) THENC*) +IN_INSERT_CONV el_EQ_CONV +)))) (REWRITE_CONV []) (REFL) ) tm; -(* TODO: add proper exceptions/exception messages if the unexpected happens... *) -fun birs_exps_of_senv_COMP_CONV_cheat tm = - let - val (s1, s2_l) = strip_comb tm; - val _ = if ((fst o dest_const) s1) = "birs_exps_of_senv_COMP" then () else - raise ERR "birs_exps_of_senv_COMP_CONV_cheat" "constant not found"; - val _ = if length s2_l = 2 then () else - raise ERR "birs_exps_of_senv_COMP_CONV_cheat" "application not right"; - val initvarset = List.nth(s2_l, 0); - val _ = if pred_setSyntax.is_empty initvarset then () else - raise ERR "birs_exps_of_senv_COMP_CONV_cheat" "must start with empty set"; - - val tm_map = List.nth(s2_l, 1); - - fun eq_fun tm1 tm2 = tm1 = tm2; - fun in_f l x = List.foldr (fn (y, b) => b orelse eq_fun x y) false l; - - val base_term = ``(K NONE):string -> bir_exp_t option``; - fun collectfun excl acc tm_map = - if identical tm_map base_term then acc else - if not (combinSyntax.is_update_comb tm_map) then raise ERR "birs_exps_of_senv_COMP_CONV_cheat" "should not happen" else - let - val ((mem_upd_k, mem_upd_v), tm_map_sub) = combinSyntax.dest_update_comb tm_map; - val mem_upd_v_v = optionSyntax.dest_some mem_upd_v; - val mem_upd_k_s = stringSyntax.fromHOLstring mem_upd_k; - val k_s_is_excl = in_f excl mem_upd_k_s; - val new_acc = if k_s_is_excl then (acc) else ([mem_upd_v_v]@acc); - val new_excl = if k_s_is_excl then (excl) else ([mem_upd_k_s]@excl); - in - collectfun new_excl new_acc tm_map_sub - end; - -(* - val s1_l = pred_setSyntax.strip_set s1; - val s2_l = pred_setSyntax.strip_set s2; -List.foldr (fn (x, l) => if not (in_f s2_l x) then x::l else l) [] s1_l; -*) - - val l = collectfun [] [] tm_map; - val tm_l_set = if List.null l then pred_setSyntax.mk_empty(``:bir_exp_t``) else pred_setSyntax.mk_set l; - in - mk_oracle_thm "FISHY_BIRS_BIR_SENV_VARSET" ([], mk_eq (tm, tm_l_set)) - end; - -fun birs_exps_of_senv_COMP_CONV_norm tm = +fun INTER_INSERT_CONV_norm el_EQ_CONV tm = ( -(*(fn tm => (if false then print ".\n" else print_term tm; REFL tm)) THENC*) -(* (fn tm => (if true then print ".\n" else print_term tm; REFL tm)) THENC *) -(* if pred_setSyntax.is_empty tm then REFL else -*) + (fn tm => (if true then print ".\n" else (print_term tm; print "\n\n"); REFL tm)) THENC IFC - (birs_exps_of_senv_COMP_ONCE_CONV) - (TRY_CONV (fn tm => ( - if pred_setSyntax.is_empty tm then - REFL - else if pred_setSyntax.is_insert tm then - RAND_CONV birs_exps_of_senv_COMP_CONV_norm - else - birs_exps_of_senv_COMP_CONV_norm - ) tm)) - (fn tm => (print_term tm; raise Fail "unexpected here")) -) tm; - -val turn_speedcheat_on = false; -val birs_exps_of_senv_COMP_CONV = - if turn_speedcheat_on then - birs_exps_of_senv_COMP_CONV_cheat - else - birs_exps_of_senv_COMP_CONV_norm; - - -fun birs_exps_of_senv_CONV tm = -( -(* -(fn tm => (if false then print ".\n" else print_term tm; REFL tm)) THENC -*) - REWRITE_CONV [birs_exps_of_senv_thm] THENC - ((*TRY_CONV*) birs_exps_of_senv_COMP_CONV) -) tm; - -fun is_birs_exps_of_senv tm = is_comb tm andalso - (is_const o fst o dest_comb) tm andalso - ((fn tm2 => tm2 = "birs_exps_of_senv") o fst o dest_const o fst o dest_comb) tm; -fun birs_symb_symbols_CONV tm = -( - SIMP_CONV (std_ss++birs_state_ss) [birs_symb_symbols_thm] THENC - debug_conv2 THENC - birs_auxLib.GEN_match_conv is_birs_exps_of_senv birs_exps_of_senv_CONV THENC - debug_conv2 THENC - REWRITE_CONV [pred_setTheory.IMAGE_INSERT, pred_setTheory.IMAGE_EMPTY] THENC - bir_vars_ofLib.bir_vars_of_exp_CONV THENC - - debug_conv2 THENC - RATOR_CONV (RAND_CONV (REWRITE_CONV [pred_setTheory.BIGUNION_INSERT, pred_setTheory.BIGUNION_EMPTY])) THENC - - REWRITE_CONV [Once pred_setTheory.UNION_COMM] THENC - REWRITE_CONV [pred_setTheory.UNION_ASSOC, pred_setTheory.INSERT_UNION_EQ, pred_setTheory.UNION_EMPTY] -) tm; - -fun is_birs_symb_symbols tm = is_comb tm andalso - (is_const o fst o dest_comb) tm andalso - ((fn tm2 => tm2 = "birs_symb_symbols") o fst o dest_const o fst o dest_comb) tm; -fun birs_symb_symbols_MATCH_CONV tm = - birs_auxLib.GEN_match_conv is_birs_symb_symbols birs_symb_symbols_CONV tm; - -(* ................................................ *) - + (INTER_INSERT_ONCE_CONV el_EQ_CONV) + ( (* -EVAL tm - - val birs_exps_of_senv_CONV = ( - debug_conv2 THENC - REPEATC (CHANGED_CONV ( - (fn x => REWRITE_CONV [Once birs_exps_of_senv_COMP_thm] x) THENC - (SIMP_CONV (std_ss) []) THENC - (ONCE_DEPTH_CONV ( (PAT_CONV ``\A. if A then B else (C)`` (REWRITE_CONV [pred_setTheory.COMPONENT] THENC SIMP_CONV std_ss [pred_setTheory.IN_INSERT])))) THENC - SIMP_CONV (std_ss) [] - )) - ); - - val birs_symb_symbols_CONV = ( - SIMP_CONV std_ss [birs_symb_symbols_thm] THENC - SIMP_CONV (std_ss++birs_state_ss) [] THENC - SIMP_CONV (std_ss) [birs_exps_of_senv_thm] - (*(PAT_CONV ``\A. IMAGE bir_vars_of_exp A`` birs_exps_of_senv_CONV)*) - ); - val conv = birs_symb_symbols_CONV (*THENC EVAL*); - val conv_ = computeLib.RESTR_EVAL_CONV [``birs_symb_symbols``] THENC conv; +(fn tm => (if false then print ".\n" else print_term tm; print "bb\n\n"; REFL tm)) THENC *) +(fn tm => + ( + (*(fn tm => (if false then print ".\n" else print_term tm; print "bb\n\n"; REFL tm)) THENC *) + (if pred_setSyntax.is_empty tm then + (REFL) + else if pred_setSyntax.is_inter tm then + (INTER_INSERT_CONV_norm el_EQ_CONV) + else if pred_setSyntax.is_insert tm then + (RAND_CONV (INTER_INSERT_CONV_norm el_EQ_CONV)) + else + (REFL))) tm)) +(* the following causes trouble as "normal exit" if there is nothing to be done at the first call *) + (fn tm => (print_term tm; raise Fail "unexpected here")) +) tm; + + +(* TODO: fix this *) +fun bvar_eq_fun_cheat tm1 tm2 = identical tm1 tm2; + +fun INTER_INSERT_CONV_cheat tm = + let + val (s1, s2) = pred_setSyntax.dest_inter tm + val s1_l = pred_setSyntax.strip_set s1; + val s2_l = pred_setSyntax.strip_set s2; + val eq_fun = bvar_eq_fun_cheat; + fun in_f l x = List.foldr (fn (y, b) => b orelse eq_fun x y) false l; + val l = List.foldr (fn (x, l) => if in_f s2_l x then x::l else l) [] s1_l; + val tm_l_set = if List.null l then pred_setSyntax.mk_empty(pred_setSyntax.eltype tm) else pred_setSyntax.mk_set l; + in + mk_oracle_thm "FISHY_BIRS_FREEVARSET" ([], mk_eq (tm, tm_l_set)) + end; + +fun DIFF_INSERT_CONV_cheat tm = + let + val (s1, s2) = pred_setSyntax.dest_diff tm + val s1_l = pred_setSyntax.strip_set s1; + val s2_l = pred_setSyntax.strip_set s2; + val eq_fun = bvar_eq_fun_cheat; + fun in_f l x = List.foldr (fn (y, b) => b orelse eq_fun x y) false l; + val l = List.foldr (fn (x, l) => if not (in_f s2_l x) then x::l else l) [] s1_l; + val tm_l_set = if List.null l then pred_setSyntax.mk_empty(pred_setSyntax.eltype tm) else pred_setSyntax.mk_set l; + in + mk_oracle_thm "FISHY_BIRS_FREEVARSET" ([], mk_eq (tm, tm_l_set)) + end; + + +val speedcheat = ref false; +val INTER_INSERT_CONV = + if !speedcheat then + INTER_INSERT_CONV_cheat + else + INTER_INSERT_CONV_norm el_EQ_CONV; + + +val DIFF_INSERT_CONV = + if !speedcheat then + DIFF_INSERT_CONV_cheat + else + (*SIMP_CONV (std_ss++HolBACoreSimps.holBACore_ss++string_ss) [pred_setTheory.INSERT_INTER, pred_setTheory.INTER_EMPTY, pred_setTheory.IN_DIFF, pred_setTheory.IN_INSERT]*) + EVAL; -(* -val tm = `` -{BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1); - BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1); - BVar "sy_PSR_Z" (BType_Imm Bit1); BVar "sy_R0" (BType_Imm Bit32); - BVar "sy_R1" (BType_Imm Bit32); BVar "sy_R2" (BType_Imm Bit32); - BVar "sy_R3" (BType_Imm Bit32); BVar "sy_R4" (BType_Imm Bit32); - BVar "sy_R5" (BType_Imm Bit32); BVar "sy_R6" (BType_Imm Bit32); - BVar "sy_R7" (BType_Imm Bit32); BVar "sy_R8" (BType_Imm Bit32); - BVar "sy_R9" (BType_Imm Bit32); BVar "sy_R10" (BType_Imm Bit32); - BVar "sy_R11" (BType_Imm Bit32); BVar "sy_R12" (BType_Imm Bit32); - BVar "sy_LR" (BType_Imm Bit32); BVar "sy_SP_main" (BType_Imm Bit32); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_ModeHandler" (BType_Imm Bit1); - BVar "sy_countw" (BType_Imm Bit64); BVar "sy_tmp_PC" (BType_Imm Bit32); - BVar "sy_tmp_COND" (BType_Imm Bit1); - BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); - BVar "sy_tmp_PSR_C" (BType_Imm Bit1); - BVar "sy_tmp_PSR_N" (BType_Imm Bit1); - BVar "sy_tmp_PSR_V" (BType_Imm Bit1); - BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); BVar "sy_tmp_R0" (BType_Imm Bit32); - BVar "sy_tmp_R1" (BType_Imm Bit32); BVar "sy_tmp_R2" (BType_Imm Bit32); - BVar "sy_tmp_R3" (BType_Imm Bit32); BVar "sy_tmp_R4" (BType_Imm Bit32); - BVar "sy_tmp_R5" (BType_Imm Bit32); BVar "sy_tmp_R6" (BType_Imm Bit32); - BVar "sy_tmp_R7" (BType_Imm Bit32); BVar "sy_tmp_R8" (BType_Imm Bit32); - BVar "sy_tmp_R9" (BType_Imm Bit32); BVar "sy_tmp_R10" (BType_Imm Bit32); - BVar "sy_tmp_R11" (BType_Imm Bit32); BVar "sy_tmp_R12" (BType_Imm Bit32); - BVar "sy_tmp_LR" (BType_Imm Bit32); - BVar "sy_tmp_SP_main" (BType_Imm Bit32); - BVar "sy_tmp_SP_process" (BType_Imm Bit32); - BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); - BVar "sy_tmp_countw" (BType_Imm Bit64)} ∩ - ({BVar "sy_countw" (BType_Imm Bit64); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1); - BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1); - BVar "sy_PSR_Z" (BType_Imm Bit1); BVar "sy_R0" (BType_Imm Bit32); - BVar "sy_R1" (BType_Imm Bit32); BVar "sy_R2" (BType_Imm Bit32); - BVar "sy_R3" (BType_Imm Bit32); BVar "sy_R4" (BType_Imm Bit32); - BVar "sy_R5" (BType_Imm Bit32); BVar "sy_R6" (BType_Imm Bit32); - BVar "sy_R7" (BType_Imm Bit32); BVar "sy_R8" (BType_Imm Bit32); - BVar "sy_R9" (BType_Imm Bit32); BVar "sy_R10" (BType_Imm Bit32); - BVar "sy_R11" (BType_Imm Bit32); BVar "sy_R12" (BType_Imm Bit32); - BVar "sy_LR" (BType_Imm Bit32); BVar "sy_SP_main" (BType_Imm Bit32); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_ModeHandler" (BType_Imm Bit1); - BVar "sy_countw" (BType_Imm Bit64); BVar "sy_tmp_PC" (BType_Imm Bit32); - BVar "sy_tmp_COND" (BType_Imm Bit1); - BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); - BVar "sy_tmp_PSR_C" (BType_Imm Bit1); - BVar "sy_tmp_PSR_N" (BType_Imm Bit1); - BVar "sy_tmp_PSR_V" (BType_Imm Bit1); - BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); - BVar "sy_tmp_R0" (BType_Imm Bit32); BVar "sy_tmp_R1" (BType_Imm Bit32); - BVar "sy_tmp_R2" (BType_Imm Bit32); BVar "sy_tmp_R3" (BType_Imm Bit32); - BVar "sy_tmp_R4" (BType_Imm Bit32); BVar "sy_tmp_R5" (BType_Imm Bit32); - BVar "sy_tmp_R6" (BType_Imm Bit32); BVar "sy_tmp_R7" (BType_Imm Bit32); - BVar "sy_tmp_R8" (BType_Imm Bit32); BVar "sy_tmp_R9" (BType_Imm Bit32); - BVar "sy_tmp_R10" (BType_Imm Bit32); - BVar "sy_tmp_R11" (BType_Imm Bit32); - BVar "sy_tmp_R12" (BType_Imm Bit32); BVar "sy_tmp_LR" (BType_Imm Bit32); - BVar "sy_tmp_SP_main" (BType_Imm Bit32); - BVar "sy_tmp_SP_process" (BType_Imm Bit32); - BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); - BVar "sy_tmp_countw" (BType_Imm Bit64); - BVar "sy_countw" (BType_Imm Bit64); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1); - BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1); - BVar "sy_PSR_Z" (BType_Imm Bit1); BVar "sy_R0" (BType_Imm Bit32); - BVar "sy_R1" (BType_Imm Bit32); BVar "sy_R2" (BType_Imm Bit32); - BVar "sy_R3" (BType_Imm Bit32); BVar "sy_R4" (BType_Imm Bit32); - BVar "sy_R5" (BType_Imm Bit32); BVar "sy_R6" (BType_Imm Bit32); - BVar "sy_R7" (BType_Imm Bit32); BVar "sy_R8" (BType_Imm Bit32); - BVar "sy_R9" (BType_Imm Bit32); BVar "sy_R10" (BType_Imm Bit32); - BVar "sy_R11" (BType_Imm Bit32); BVar "sy_R12" (BType_Imm Bit32); - BVar "sy_LR" (BType_Imm Bit32); BVar "sy_SP_main" (BType_Imm Bit32); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_ModeHandler" (BType_Imm Bit1); - BVar "sy_countw" (BType_Imm Bit64); BVar "sy_tmp_PC" (BType_Imm Bit32); - BVar "sy_tmp_COND" (BType_Imm Bit1); - BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); - BVar "sy_tmp_PSR_C" (BType_Imm Bit1); - BVar "sy_tmp_PSR_N" (BType_Imm Bit1); - BVar "sy_tmp_PSR_V" (BType_Imm Bit1); - BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); - BVar "sy_tmp_R0" (BType_Imm Bit32); BVar "sy_tmp_R1" (BType_Imm Bit32); - BVar "sy_tmp_R2" (BType_Imm Bit32); BVar "sy_tmp_R3" (BType_Imm Bit32); - BVar "sy_tmp_R4" (BType_Imm Bit32); BVar "sy_tmp_R5" (BType_Imm Bit32); - BVar "sy_tmp_R6" (BType_Imm Bit32); BVar "sy_tmp_R7" (BType_Imm Bit32); - BVar "sy_tmp_R8" (BType_Imm Bit32); BVar "sy_tmp_R9" (BType_Imm Bit32); - BVar "sy_tmp_R10" (BType_Imm Bit32); - BVar "sy_tmp_R11" (BType_Imm Bit32); - BVar "sy_tmp_R12" (BType_Imm Bit32); BVar "sy_tmp_LR" (BType_Imm Bit32); - BVar "sy_tmp_SP_main" (BType_Imm Bit32); - BVar "sy_tmp_SP_process" (BType_Imm Bit32); - BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); - BVar "sy_tmp_countw" (BType_Imm Bit64)} DIFF - {BVar "sy_countw" (BType_Imm Bit64); - BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1); - BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1); - BVar "sy_PSR_Z" (BType_Imm Bit1); BVar "sy_R0" (BType_Imm Bit32); - BVar "sy_R1" (BType_Imm Bit32); BVar "sy_R2" (BType_Imm Bit32); - BVar "sy_R3" (BType_Imm Bit32); BVar "sy_R4" (BType_Imm Bit32); - BVar "sy_R5" (BType_Imm Bit32); BVar "sy_R6" (BType_Imm Bit32); - BVar "sy_R7" (BType_Imm Bit32); BVar "sy_R8" (BType_Imm Bit32); - BVar "sy_R9" (BType_Imm Bit32); BVar "sy_R10" (BType_Imm Bit32); - BVar "sy_R11" (BType_Imm Bit32); BVar "sy_R12" (BType_Imm Bit32); - BVar "sy_LR" (BType_Imm Bit32); BVar "sy_SP_main" (BType_Imm Bit32); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_ModeHandler" (BType_Imm Bit1); - BVar "sy_countw" (BType_Imm Bit64); BVar "sy_tmp_PC" (BType_Imm Bit32); - BVar "sy_tmp_COND" (BType_Imm Bit1); - BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); - BVar "sy_tmp_PSR_C" (BType_Imm Bit1); - BVar "sy_tmp_PSR_N" (BType_Imm Bit1); - BVar "sy_tmp_PSR_V" (BType_Imm Bit1); - BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); - BVar "sy_tmp_R0" (BType_Imm Bit32); BVar "sy_tmp_R1" (BType_Imm Bit32); - BVar "sy_tmp_R2" (BType_Imm Bit32); BVar "sy_tmp_R3" (BType_Imm Bit32); - BVar "sy_tmp_R4" (BType_Imm Bit32); BVar "sy_tmp_R5" (BType_Imm Bit32); - BVar "sy_tmp_R6" (BType_Imm Bit32); BVar "sy_tmp_R7" (BType_Imm Bit32); - BVar "sy_tmp_R8" (BType_Imm Bit32); BVar "sy_tmp_R9" (BType_Imm Bit32); - BVar "sy_tmp_R10" (BType_Imm Bit32); - BVar "sy_tmp_R11" (BType_Imm Bit32); - BVar "sy_tmp_R12" (BType_Imm Bit32); BVar "sy_tmp_LR" (BType_Imm Bit32); - BVar "sy_tmp_SP_main" (BType_Imm Bit32); - BVar "sy_tmp_SP_process" (BType_Imm Bit32); - BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); - BVar "sy_tmp_countw" (BType_Imm Bit64)}) -``; - -val tm = `` -{BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1);BVar "sy_countw" (BType_Imm Bit64); - BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1)} ∩ - ({BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1);BVar "sy_countw" (BType_Imm Bit64); - BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1)} DIFF - { - BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); - BVar "sy_tmp_countw" (BType_Imm Bit64)}) -``; -val tm = (snd o dest_comb o fst o dest_comb o snd o dest_eq o concl o REWRITE_CONV [REWRITE_RULE [Once pred_setTheory.INTER_COMM] pred_setTheory.DIFF_INTER]) tm; -val tm = (snd o dest_comb o snd o dest_eq o concl o REWRITE_CONV [Once (prove(`` -!s t g. -g INTER (s DIFF t) = -s INTER (g DIFF t) -``, -(*REWRITE_RULE [Once pred_setTheory.INTER_COMM] pred_setTheory.DIFF_INTER*) -METIS_TAC [pred_setTheory.INTER_COMM, pred_setTheory.DIFF_INTER] -))]) tm; -++pred_setSimps.PRED_SET_ss -val char_ss = rewrites (type_rws ``:char``); + +(* val tm = `` -BVar "sy_countw" (BType_Imm Bit64) ∈ - {BVar "sy_MEM" (BType_Mem Bit32 Bit8); - BVar "sy_PSR_C" (BType_Imm Bit1); BVar "sy_PSR_N" (BType_Imm Bit1); - BVar "sy_PSR_V" (BType_Imm Bit1); BVar "sy_PSR_Z" (BType_Imm Bit1); - BVar "sy_R0" (BType_Imm Bit32); BVar "sy_R1" (BType_Imm Bit32); - BVar "sy_R2" (BType_Imm Bit32); BVar "sy_R3" (BType_Imm Bit32); - BVar "sy_R4" (BType_Imm Bit32); BVar "sy_R5" (BType_Imm Bit32); - BVar "sy_R6" (BType_Imm Bit32); BVar "sy_R7" (BType_Imm Bit32); - BVar "sy_R8" (BType_Imm Bit32); BVar "sy_R9" (BType_Imm Bit32); - BVar "sy_R10" (BType_Imm Bit32); BVar "sy_R11" (BType_Imm Bit32); - BVar "sy_R12" (BType_Imm Bit32); BVar "sy_LR" (BType_Imm Bit32); - BVar "sy_SP_main" (BType_Imm Bit32); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_ModeHandler" (BType_Imm Bit1); - BVar "sy_countw" (BType_Imm Bit64); - BVar "sy_tmp_PC" (BType_Imm Bit32); - BVar "sy_tmp_COND" (BType_Imm Bit1); - BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); - BVar "sy_tmp_PSR_C" (BType_Imm Bit1); - BVar "sy_tmp_PSR_N" (BType_Imm Bit1); - BVar "sy_tmp_PSR_V" (BType_Imm Bit1); - BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); + EMPTY DIFF + { + BVar "sy_tmp_R0" (BType_Imm Bit32); + BVar "sy_tmp_R1" (BType_Imm Bit32); + BVar "sy_tmp_R2" (BType_Imm Bit32) + } +``; + +val tm = `` + { + BVar "sy_tmp_R0" (BType_Imm Bit32); + BVar "sy_tmp_R1" (BType_Imm Bit32); + BVar "sy_tmp_R2" (BType_Imm Bit32); + BVar "sy_tmp_R3" (BType_Imm Bit32); + BVar "sy_tmp_R4" (BType_Imm Bit32); + BVar "sy_tmp_R5" (BType_Imm Bit32) + } DIFF + EMPTY +``; + +val tm = `` + { BVar "sy_tmp_R0" (BType_Imm Bit32); BVar "sy_tmp_R1" (BType_Imm Bit32); BVar "sy_tmp_R2" (BType_Imm Bit32); BVar "sy_tmp_R3" (BType_Imm Bit32); BVar "sy_tmp_R4" (BType_Imm Bit32); + BVar "sy_tmp_R5" (BType_Imm Bit32) + } DIFF + { + BVar "sy_tmp_R0" (BType_Imm Bit32); + BVar "sy_tmp_R1" (BType_Imm Bit32); + BVar "sy_tmp_R2" (BType_Imm Bit32) + } +``; + +val tm = `` +{ + BVar "sy_tmp_R0" (BType_Imm Bit32); + BVar "sy_tmp_R1" (BType_Imm Bit32); + BVar "sy_tmp_R4" (BType_Imm Bit32); BVar "sy_tmp_R5" (BType_Imm Bit32); - BVar "sy_tmp_R6" (BType_Imm Bit32); - BVar "sy_tmp_R7" (BType_Imm Bit32); - BVar "sy_tmp_R8" (BType_Imm Bit32); - BVar "sy_tmp_R9" (BType_Imm Bit32); - BVar "sy_tmp_R10" (BType_Imm Bit32); - BVar "sy_tmp_R11" (BType_Imm Bit32); - BVar "sy_tmp_R12" (BType_Imm Bit32); - BVar "sy_tmp_LR" (BType_Imm Bit32); - BVar "sy_tmp_SP_main" (BType_Imm Bit32); - BVar "sy_tmp_SP_process" (BType_Imm Bit32); - BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); - BVar "sy_tmp_countw" (BType_Imm Bit64)} + BVar "sy_tmp_R8" (BType_Imm Bit32) +} INTER (^tm) +``; (* R4 and R5 *) +*) + + +fun DIFF_CONV_Once el_EQ_CONV tm = + ( + IFC + (CHANGED_CONV (fn tm => REWRITE_CONV [Once INSERT_DIFF] tm)) + (RATOR_CONV (RATOR_CONV (RAND_CONV (pred_setLib.IN_CONV el_EQ_CONV))) THENC + REWRITE_CONV []) + (REFL) + ) + tm; + +fun DIFF_CONV el_EQ_CONV tm = + if pred_setSyntax.is_empty tm then + REFL tm + else if pred_setSyntax.is_diff tm then + if (pred_setSyntax.is_empty o fst o pred_setSyntax.dest_diff) tm then + (print_term tm; + REWRITE_CONV [EMPTY_DIFF] tm) + else if (pred_setSyntax.is_insert o fst o pred_setSyntax.dest_diff) tm then + (DIFF_CONV_Once el_EQ_CONV THENC + DIFF_CONV el_EQ_CONV) tm + else + raise ERR "DIFF_CONV" "unexpected1" + else if pred_setSyntax.is_insert tm then + RAND_CONV + (DIFF_CONV el_EQ_CONV) + tm + else + (print_term tm; + raise ERR "DIFF_CONV" "unexpected2"); + +(* +val el_EQ_CONV = EVAL; +DIFF_CONV el_EQ_CONV tm +*) + + +(* ---------------------------------------------------------------------------------- *) +(* ---------------------------------------------------------------------------------- *) +(* ---------------------------------------------------------------------------------- *) +(* ---------------------------------------------------------------------------------- *) +(* ---------------------------------------------------------------------------------- *) +(* ---------------------------------------------------------------------------------- *) +(* ---------------------------------------------------------------------------------- *) +(* ---------------------------------------------------------------------------------- *) +(* ---------------------------------------------------------------------------------- *) + +(* ---------------------------------------------------------------------------------- *) +(* state equality checker *) +(* ---------------------------------------------------------------------------------- *) + +(* +fun stx_tm addr_tm index_tm symbname_tm = `` + <|bsst_pc := <|bpc_label := BL_Address (Imm32 (^addr_tm)); bpc_index := (^index_tm)|>; + bsst_environ := + birs_gen_env + [("MEM",BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); + ("PSR_C",BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); + ("PSR_N",BExp_Den (BVar "sy_PSR_N" (BType_Imm Bit1))); + ("PSR_V",BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); + ("PSR_Z",BExp_Den (BVar (^symbname_tm) (BType_Imm Bit1)))]; + bsst_status := BST_Running; + bsst_pcond := + (BExp_BinPred BIExp_LessOrEqual + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 0xFFFFFFFFFFFFFF00w)))|> ``; +val st1_tm = stx_tm ``2824w:word32`` ``1:num`` ``"sy_PSR_Z"``; +val st2_tm = stx_tm ``2824w:word32`` ``2:num`` ``"sy_PSR_Z"``; +val st3_tm = stx_tm ``2825w:word32`` ``1:num`` ``"sy_PSR_A"``; +val st4_tm = stx_tm ``2824w:word32`` ``3:num`` ``"sy_PSR_Z"``; + +val st_eq_1_tm = ``^st1_tm = ^st1_tm``; +val st_eq_2_tm = ``^st1_tm = ^st2_tm``; +val st_eq_3_tm = ``^st1_tm = ^st3_tm``; +val st_eq_4_tm = ``^st2_tm = ^st3_tm``; + +val tm = st_eq_2_tm; +val tm = st_eq_3_tm; +val tm = st_eq_4_tm; + +birs_state_EQ_CONV st_eq_1_tm +birs_state_EQ_CONV st_eq_2_tm +birs_state_EQ_CONV st_eq_3_tm +birs_state_EQ_CONV st_eq_4_tm +*) + +val birs_state_NEQ_pc_thm = prove(`` +!bsys1 bsys2. + (bsys1.bsst_pc <> bsys2.bsst_pc) ==> + (bsys1 <> bsys2) +``, + SIMP_TAC (std_ss++birs_state_ss) [] +); +val birs_state_NEQ_pcond_thm = prove(`` +!bsys1 bsys2. + (bsys1.bsst_pcond <> bsys2.bsst_pcond) ==> + (bsys1 <> bsys2) +``, + SIMP_TAC (std_ss++birs_state_ss) [] +); +val birs_state_NEQ_status_thm = prove(`` +!bsys1 bsys2. + (bsys1.bsst_status <> bsys2.bsst_status) ==> + (bsys1 <> bsys2) +``, + SIMP_TAC (std_ss++birs_state_ss) [] +); + fun try_prove_birs_state_try_justify_assumptions t = + if (is_neg o concl) t orelse + (not o is_imp o concl) t then + t + else + let + val assmpt = (fst o dest_imp o concl) t; + val assmpt_thm = (SIMP_CONV (std_ss++holBACore_ss++birs_state_ss) [] THENC EVAL) assmpt; -*) + val assmpt_new = (snd o dest_eq o concl) assmpt_thm; -(* 65 * 30 * t_IN_VAR = 9-10s -t_IN_VAR = 0.005s *) -(* !!!!! try computeLib *) -val string_ss = rewrites (type_rws ``:string``); + (* raise exception when the assumption turns out to be false *) + val _ = if not (identical assmpt_new F) then () else + raise ERR "birs_simp_try_justify_assumptions" "assumption does not hold"; -val el_EQ_CONV = SIMP_CONV (std_ss++HolBACoreSimps.holBACore_ss++string_ss) []; -val el_EQ_CONV = RAND_CONV EVAL; + val _ = if identical assmpt_new T then () else + raise ERR "birs_simp_try_justify_assumptions" ("failed to fix the assumption: " ^ (term_to_string assmpt)); + in + try_prove_birs_state_try_justify_assumptions + (REWRITE_RULE [assmpt_thm] t) + end; -fun IN_INSERT_CONV el_EQ_CONV tm = -( - REWRITE_CONV [pred_setTheory.NOT_IN_EMPTY] THENC - REPEATC (CHANGED_CONV ( - (fn xyz => REWRITE_CONV [Once pred_setTheory.IN_INSERT] xyz) THENC - (*(fn tm => (if false then print ".\n" else print_term tm; print "aa\n\n"; REFL tm)) THENC*) - IFC - (RATOR_CONV el_EQ_CONV) - (REWRITE_CONV [pred_setTheory.NOT_IN_EMPTY]) - REFL)) -) tm; +fun try_prove_birs_state_NEQ bsys1_tm bsys2_tm = + let + val thms = [birs_state_NEQ_pc_thm, birs_state_NEQ_pcond_thm, birs_state_NEQ_status_thm]; + val t = hd thms; + fun foldfun (t, r_o) = + if isSome r_o then + r_o + else + (*val t = (SPECL [bsys1_tm, bsys2_tm] t);*) + SOME (try_prove_birs_state_try_justify_assumptions (SPECL [bsys1_tm, bsys2_tm] t)) + handle _ => NONE; + val neq_t_o = List.foldl foldfun NONE thms; + in + if isSome neq_t_o then + valOf neq_t_o + else + (print "\ncould not show inequality of the states, would need to check the environments\n"; + raise ERR "try_prove_birs_state_NEQ" "could not show inequality of the states, would need to check the environments") + end; -fun INTER_INSERT_ONCE_CONV el_EQ_CONV tm = -( - (QCHANGED_CONV (CHANGED_CONV (fn x => REWRITE_CONV [Once pred_setTheory.INSERT_INTER, pred_setTheory.INTER_EMPTY] x))) THENC +fun birs_state_EQ_CONV tm = IFC - (RATOR_CONV (RATOR_CONV (RAND_CONV ( -(* -fn tm => (print_term (concl (prove (mk_eq (tm, F), cheat))); prove (mk_eq (tm, F), cheat)) -*) -(*fn tm => (prove (mk_eq (tm, F), cheat))*) -(*(fn tm => (if false then print ".\n" else print_term tm; print "aa\n\n"; REFL tm)) THENC*) -IN_INSERT_CONV el_EQ_CONV -)))) - (REWRITE_CONV []) - (REFL) -) tm; + (CHANGED_CONV (REWRITE_CONV [])) + (fn tm => (print "syntactically equal, done!\n"; REFL tm)) + (fn tm => + let + val (bsys1_tm, bsys2_tm) = dest_eq tm; + val neq_t = try_prove_birs_state_NEQ bsys1_tm bsys2_tm; + in + REWRITE_CONV [neq_t] tm + end) + tm; + + +(* ---------------------------------------------------------------------------------- *) +(* set operation for composition, using the state equality checker above *) +(* ---------------------------------------------------------------------------------- *) -fun INTER_INSERT_CONV_norm el_EQ_CONV tm = -( - if pred_setSyntax.is_empty tm then - REFL - else - (fn tm => (if true then print ".\n" else (print_term tm; print "\n\n"); REFL tm)) THENC - IFC - (INTER_INSERT_ONCE_CONV el_EQ_CONV) - ( (* -(fn tm => (if false then print ".\n" else print_term tm; print "bb\n\n"; REFL tm)) THENC +val tm = `` + (IMAGE birs_symb_to_symbst {^st1_tm; ^st2_tm} DIFF + {birs_symb_to_symbst ^st1_tm}) +UNION + IMAGE birs_symb_to_symbst {^st4_tm} +``; + +val tm = `` +IMAGE birs_symb_to_symbst + {<|bsst_pc := <|bpc_label := BL_Address (Imm32 2824w); bpc_index := 1|>; + bsst_environ := + birs_gen_env + [("MEM",BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); + ("PSR_C",BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); + ("PSR_N",BExp_Den (BVar "sy_PSR_N" (BType_Imm Bit1))); + ("PSR_V",BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); + ("PSR_Z",BExp_Den (BVar "sy_PSR_Z" (BType_Imm Bit1))); + ("R0",BExp_Den (BVar "sy_R0" (BType_Imm Bit32))); + ("R1",BExp_Den (BVar "sy_R1" (BType_Imm Bit32))); + ("R2",BExp_Den (BVar "sy_R2" (BType_Imm Bit32))); + ("R3",BExp_Den (BVar "sy_R3" (BType_Imm Bit32))); + ("R4",BExp_Den (BVar "sy_R4" (BType_Imm Bit32))); + ("R5",BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); + ("R6",BExp_Den (BVar "sy_R6" (BType_Imm Bit32))); + ("R7",BExp_Den (BVar "sy_R7" (BType_Imm Bit32))); + ("R8",BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); + ("R9",BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); + ("R10",BExp_Den (BVar "sy_R10" (BType_Imm Bit32))); + ("R11",BExp_Den (BVar "sy_R11" (BType_Imm Bit32))); + ("R12",BExp_Den (BVar "sy_R12" (BType_Imm Bit32))); + ("LR",BExp_Den (BVar "sy_LR" (BType_Imm Bit32))); + ("SP_main",BExp_Den (BVar "sy_SP_main" (BType_Imm Bit32))); + ("SP_process",BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))); + ("ModeHandler",BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1))); + ("countw",BExp_Den (BVar "sy_countw" (BType_Imm Bit64))); + ("tmp_PC",BExp_Den (BVar "sy_tmp_PC" (BType_Imm Bit32))); + ("tmp_COND",BExp_Den (BVar "sy_tmp_COND" (BType_Imm Bit1))); + ("tmp_MEM",BExp_Den (BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8))); + ("tmp_PSR_C",BExp_Den (BVar "sy_tmp_PSR_C" (BType_Imm Bit1))); + ("tmp_PSR_N",BExp_Den (BVar "sy_tmp_PSR_N" (BType_Imm Bit1))); + ("tmp_PSR_V",BExp_Den (BVar "sy_tmp_PSR_V" (BType_Imm Bit1))); + ("tmp_PSR_Z",BExp_Den (BVar "sy_tmp_PSR_Z" (BType_Imm Bit1))); + ("tmp_R0",BExp_Den (BVar "sy_tmp_R0" (BType_Imm Bit32))); + ("tmp_R1",BExp_Den (BVar "sy_tmp_R1" (BType_Imm Bit32))); + ("tmp_R2",BExp_Den (BVar "sy_tmp_R2" (BType_Imm Bit32))); + ("tmp_R3",BExp_Den (BVar "sy_tmp_R3" (BType_Imm Bit32))); + ("tmp_R4",BExp_Den (BVar "sy_tmp_R4" (BType_Imm Bit32))); + ("tmp_R5",BExp_Den (BVar "sy_tmp_R5" (BType_Imm Bit32))); + ("tmp_R6",BExp_Den (BVar "sy_tmp_R6" (BType_Imm Bit32))); + ("tmp_R7",BExp_Den (BVar "sy_tmp_R7" (BType_Imm Bit32))); + ("tmp_R8",BExp_Den (BVar "sy_tmp_R8" (BType_Imm Bit32))); + ("tmp_R9",BExp_Den (BVar "sy_tmp_R9" (BType_Imm Bit32))); + ("tmp_R10",BExp_Den (BVar "sy_tmp_R10" (BType_Imm Bit32))); + ("tmp_R11",BExp_Den (BVar "sy_tmp_R11" (BType_Imm Bit32))); + ("tmp_R12",BExp_Den (BVar "sy_tmp_R12" (BType_Imm Bit32))); + ("tmp_LR",BExp_Den (BVar "sy_tmp_LR" (BType_Imm Bit32))); + ("tmp_SP_main",BExp_Den (BVar "sy_tmp_SP_main" (BType_Imm Bit32))); + ("tmp_SP_process", + BExp_Den (BVar "sy_tmp_SP_process" (BType_Imm Bit32))); + ("tmp_ModeHandler", + BExp_Den (BVar "sy_tmp_ModeHandler" (BType_Imm Bit1))); + ("tmp_countw",BExp_Den (BVar "sy_tmp_countw" (BType_Imm Bit64)))]; + bsst_status := BST_Running; + bsst_pcond := + BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual (BExp_Const (Imm32 0xFFFFFFw)) + (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32)))) + (BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_And + (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))) + (BExp_Const (Imm32 3w))) (BExp_Const (Imm32 0w)))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 0xFFFFFFFFFFFFFF00w)))|>} DIFF +{birs_symb_to_symbst + <|bsst_pc := <|bpc_label := BL_Address (Imm32 2824w); bpc_index := 1|>; + bsst_environ := + birs_gen_env + [("MEM",BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); + ("PSR_C",BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); + ("PSR_N",BExp_Den (BVar "sy_PSR_N" (BType_Imm Bit1))); + ("PSR_V",BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); + ("PSR_Z",BExp_Den (BVar "sy_PSR_Z" (BType_Imm Bit1))); + ("R0",BExp_Den (BVar "sy_R0" (BType_Imm Bit32))); + ("R1",BExp_Den (BVar "sy_R1" (BType_Imm Bit32))); + ("R2",BExp_Den (BVar "sy_R2" (BType_Imm Bit32))); + ("R3",BExp_Den (BVar "sy_R3" (BType_Imm Bit32))); + ("R4",BExp_Den (BVar "sy_R4" (BType_Imm Bit32))); + ("R5",BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); + ("R6",BExp_Den (BVar "sy_R6" (BType_Imm Bit32))); + ("R7",BExp_Den (BVar "sy_R7" (BType_Imm Bit32))); + ("R8",BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); + ("R9",BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); + ("R10",BExp_Den (BVar "sy_R10" (BType_Imm Bit32))); + ("R11",BExp_Den (BVar "sy_R11" (BType_Imm Bit32))); + ("R12",BExp_Den (BVar "sy_R12" (BType_Imm Bit32))); + ("LR",BExp_Den (BVar "sy_LR" (BType_Imm Bit32))); + ("SP_main",BExp_Den (BVar "sy_SP_main" (BType_Imm Bit32))); + ("SP_process",BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))); + ("ModeHandler",BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1))); + ("countw",BExp_Den (BVar "sy_countw" (BType_Imm Bit64))); + ("tmp_PC",BExp_Den (BVar "sy_tmp_PC" (BType_Imm Bit32))); + ("tmp_COND",BExp_Den (BVar "sy_tmp_COND" (BType_Imm Bit1))); + ("tmp_MEM",BExp_Den (BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8))); + ("tmp_PSR_C",BExp_Den (BVar "sy_tmp_PSR_C" (BType_Imm Bit1))); + ("tmp_PSR_N",BExp_Den (BVar "sy_tmp_PSR_N" (BType_Imm Bit1))); + ("tmp_PSR_V",BExp_Den (BVar "sy_tmp_PSR_V" (BType_Imm Bit1))); + ("tmp_PSR_Z",BExp_Den (BVar "sy_tmp_PSR_Z" (BType_Imm Bit1))); + ("tmp_R0",BExp_Den (BVar "sy_tmp_R0" (BType_Imm Bit32))); + ("tmp_R1",BExp_Den (BVar "sy_tmp_R1" (BType_Imm Bit32))); + ("tmp_R2",BExp_Den (BVar "sy_tmp_R2" (BType_Imm Bit32))); + ("tmp_R3",BExp_Den (BVar "sy_tmp_R3" (BType_Imm Bit32))); + ("tmp_R4",BExp_Den (BVar "sy_tmp_R4" (BType_Imm Bit32))); + ("tmp_R5",BExp_Den (BVar "sy_tmp_R5" (BType_Imm Bit32))); + ("tmp_R6",BExp_Den (BVar "sy_tmp_R6" (BType_Imm Bit32))); + ("tmp_R7",BExp_Den (BVar "sy_tmp_R7" (BType_Imm Bit32))); + ("tmp_R8",BExp_Den (BVar "sy_tmp_R8" (BType_Imm Bit32))); + ("tmp_R9",BExp_Den (BVar "sy_tmp_R9" (BType_Imm Bit32))); + ("tmp_R10",BExp_Den (BVar "sy_tmp_R10" (BType_Imm Bit32))); + ("tmp_R11",BExp_Den (BVar "sy_tmp_R11" (BType_Imm Bit32))); + ("tmp_R12",BExp_Den (BVar "sy_tmp_R12" (BType_Imm Bit32))); + ("tmp_LR",BExp_Den (BVar "sy_tmp_LR" (BType_Imm Bit32))); + ("tmp_SP_main",BExp_Den (BVar "sy_tmp_SP_main" (BType_Imm Bit32))); + ("tmp_SP_process", + BExp_Den (BVar "sy_tmp_SP_process" (BType_Imm Bit32))); + ("tmp_ModeHandler", + BExp_Den (BVar "sy_tmp_ModeHandler" (BType_Imm Bit1))); + ("tmp_countw",BExp_Den (BVar "sy_tmp_countw" (BType_Imm Bit64)))]; + bsst_status := BST_Running; + bsst_pcond := + BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual (BExp_Const (Imm32 0xFFFFFFw)) + (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32)))) + (BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_And + (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))) + (BExp_Const (Imm32 3w))) (BExp_Const (Imm32 0w)))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 0xFFFFFFFFFFFFFF00w)))|>} ∪ +IMAGE birs_symb_to_symbst + {<|bsst_pc := <|bpc_label := BL_Address (Imm32 2824w); bpc_index := 2|>; + bsst_environ := + birs_gen_env + [("MEM",BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); + ("PSR_C",BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); + ("PSR_N",BExp_Den (BVar "sy_PSR_N" (BType_Imm Bit1))); + ("PSR_V",BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); + ("PSR_Z",BExp_Den (BVar "sy_PSR_Z" (BType_Imm Bit1))); + ("R0",BExp_Den (BVar "sy_R0" (BType_Imm Bit32))); + ("R1",BExp_Den (BVar "sy_R1" (BType_Imm Bit32))); + ("R2",BExp_Den (BVar "sy_R2" (BType_Imm Bit32))); + ("R3",BExp_Den (BVar "sy_R3" (BType_Imm Bit32))); + ("R4",BExp_Den (BVar "sy_R4" (BType_Imm Bit32))); + ("R5",BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); + ("R6",BExp_Den (BVar "sy_R6" (BType_Imm Bit32))); + ("R7",BExp_Den (BVar "sy_R7" (BType_Imm Bit32))); + ("R8",BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); + ("R9",BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); + ("R10",BExp_Den (BVar "sy_R10" (BType_Imm Bit32))); + ("R11",BExp_Den (BVar "sy_R11" (BType_Imm Bit32))); + ("R12",BExp_Den (BVar "sy_R12" (BType_Imm Bit32))); + ("LR",BExp_Den (BVar "sy_LR" (BType_Imm Bit32))); + ("SP_main",BExp_Den (BVar "sy_SP_main" (BType_Imm Bit32))); + ("SP_process",BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))); + ("ModeHandler",BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1))); + ("countw",BExp_Den (BVar "sy_countw" (BType_Imm Bit64))); + ("tmp_PC",BExp_Den (BVar "sy_tmp_PC" (BType_Imm Bit32))); + ("tmp_COND",BExp_Den (BVar "sy_tmp_COND" (BType_Imm Bit1))); + ("tmp_MEM",BExp_Den (BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8))); + ("tmp_PSR_C",BExp_Den (BVar "sy_tmp_PSR_C" (BType_Imm Bit1))); + ("tmp_PSR_N",BExp_Den (BVar "sy_tmp_PSR_N" (BType_Imm Bit1))); + ("tmp_PSR_V",BExp_Den (BVar "sy_tmp_PSR_V" (BType_Imm Bit1))); + ("tmp_PSR_Z",BExp_Den (BVar "sy_tmp_PSR_Z" (BType_Imm Bit1))); + ("tmp_R0",BExp_Den (BVar "sy_tmp_R0" (BType_Imm Bit32))); + ("tmp_R1",BExp_Den (BVar "sy_tmp_R1" (BType_Imm Bit32))); + ("tmp_R2",BExp_Den (BVar "sy_tmp_R2" (BType_Imm Bit32))); + ("tmp_R3",BExp_Den (BVar "sy_tmp_R3" (BType_Imm Bit32))); + ("tmp_R4",BExp_Den (BVar "sy_tmp_R4" (BType_Imm Bit32))); + ("tmp_R5",BExp_Den (BVar "sy_tmp_R5" (BType_Imm Bit32))); + ("tmp_R6",BExp_Den (BVar "sy_tmp_R6" (BType_Imm Bit32))); + ("tmp_R7",BExp_Den (BVar "sy_tmp_R7" (BType_Imm Bit32))); + ("tmp_R8",BExp_Den (BVar "sy_tmp_R8" (BType_Imm Bit32))); + ("tmp_R9",BExp_Den (BVar "sy_tmp_R9" (BType_Imm Bit32))); + ("tmp_R10",BExp_Den (BVar "sy_tmp_R10" (BType_Imm Bit32))); + ("tmp_R11",BExp_Den (BVar "sy_tmp_R11" (BType_Imm Bit32))); + ("tmp_R12",BExp_Den (BVar "sy_tmp_R12" (BType_Imm Bit32))); + ("tmp_LR",BExp_Den (BVar "sy_tmp_LR" (BType_Imm Bit32))); + ("tmp_SP_main",BExp_Den (BVar "sy_tmp_SP_main" (BType_Imm Bit32))); + ("tmp_SP_process", + BExp_Den (BVar "sy_tmp_SP_process" (BType_Imm Bit32))); + ("tmp_ModeHandler", + BExp_Den (BVar "sy_tmp_ModeHandler" (BType_Imm Bit1))); + ("tmp_countw",BExp_Den (BVar "sy_tmp_countw" (BType_Imm Bit64)))]; + bsst_status := BST_Running; + bsst_pcond := + BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual (BExp_Const (Imm32 0xFFFFFFw)) + (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32)))) + (BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_And + (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))) + (BExp_Const (Imm32 3w))) (BExp_Const (Imm32 0w)))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 0xFFFFFFFFFFFFFF00w)))|>}``; *) -(fn tm => - ( - (*(fn tm => (if false then print ".\n" else print_term tm; print "bb\n\n"; REFL tm)) THENC *) - (if pred_setSyntax.is_empty tm then - (REFL) - else if pred_setSyntax.is_inter tm then - (INTER_INSERT_CONV_norm el_EQ_CONV) - else if pred_setSyntax.is_insert tm then - (RAND_CONV (INTER_INSERT_CONV_norm el_EQ_CONV)) - else - (REFL))) tm)) -(* the following causes trouble as "normal exit" if there is nothing to be done at the first call *) - (fn tm => (print_term tm; raise Fail "unexpected here")) -) tm; - - -(* TODO: fix this *) -fun bvar_eq_fun_cheat tm1 tm2 = identical tm1 tm2; - -fun INTER_INSERT_CONV_cheat tm = - let - val (s1, s2) = pred_setSyntax.dest_inter tm - val s1_l = pred_setSyntax.strip_set s1; - val s2_l = pred_setSyntax.strip_set s2; - val eq_fun = bvar_eq_fun_cheat; - fun in_f l x = List.foldr (fn (y, b) => b orelse eq_fun x y) false l; - val l = List.foldr (fn (x, l) => if in_f s2_l x then x::l else l) [] s1_l; - val tm_l_set = if List.null l then pred_setSyntax.mk_empty(pred_setSyntax.eltype tm) else pred_setSyntax.mk_set l; - in - mk_oracle_thm "FISHY_BIRS_FREEVARSET" ([], mk_eq (tm, tm_l_set)) - end; - -fun DIFF_INSERT_CONV_cheat tm = - let - val (s1, s2) = pred_setSyntax.dest_diff tm - val s1_l = pred_setSyntax.strip_set s1; - val s2_l = pred_setSyntax.strip_set s2; - val eq_fun = bvar_eq_fun_cheat; - fun in_f l x = List.foldr (fn (y, b) => b orelse eq_fun x y) false l; - val l = List.foldr (fn (x, l) => if not (in_f s2_l x) then x::l else l) [] s1_l; - val tm_l_set = if List.null l then pred_setSyntax.mk_empty(pred_setSyntax.eltype tm) else pred_setSyntax.mk_set l; - in - mk_oracle_thm "FISHY_BIRS_FREEVARSET" ([], mk_eq (tm, tm_l_set)) - end; - - -val INTER_INSERT_CONV = - if turn_speedcheat_on then - INTER_INSERT_CONV_cheat - else - INTER_INSERT_CONV_norm el_EQ_CONV; +val IMAGE_DIFF_SING_thm = prove(`` +!f s x. + (IMAGE f s) DIFF {f x} = + (IMAGE f s) DIFF (IMAGE f {x}) +``, + SIMP_TAC std_ss [IMAGE_INSERT, IMAGE_EMPTY] +); -val DIFF_INSERT_CONV = - if turn_speedcheat_on then - DIFF_INSERT_CONV_cheat - else - (*SIMP_CONV (std_ss++HolBACoreSimps.holBACore_ss++string_ss) [pred_setTheory.INSERT_INTER, pred_setTheory.INTER_EMPTY, pred_setTheory.IN_DIFF, pred_setTheory.IN_INSERT]*) - EVAL; +val IMAGE_DIFF_ASSOC_thm = prove(`` +!f s1 s2. + (!x y. f x = f y <=> x = y) ==> + ((IMAGE f s1) DIFF (IMAGE f s2) = + IMAGE f (s1 DIFF s2)) +``, + REPEAT STRIP_TAC >> + SIMP_TAC std_ss [IMAGE_INSERT, IMAGE_EMPTY, EXTENSION] >> + SIMP_TAC (std_ss++pred_setSimps.PRED_SET_ss) [] >> + REPEAT STRIP_TAC >> + EQ_TAC >> ( + REPEAT STRIP_TAC >> + METIS_TAC [] + ) +); +val IMAGE_UNION_ASSOC_thm = prove(`` +!f s1 s2. + (!x y. f x = f y <=> x = y) ==> + ((IMAGE f s1) UNION (IMAGE f s2) = + IMAGE f (s1 UNION s2)) +``, + REPEAT STRIP_TAC >> + SIMP_TAC std_ss [IMAGE_INSERT, IMAGE_EMPTY, EXTENSION] >> + SIMP_TAC (std_ss++pred_setSimps.PRED_SET_ss) [] >> + REPEAT STRIP_TAC >> + EQ_TAC >> ( + REPEAT STRIP_TAC >> + METIS_TAC [] + ) +); + fun DIFF_UNION_CONV_cheat tm = + let + val pat_tm = ``(IMAGE (birs_symb_to_symbst) Pi_a) DIFF {birs_symb_to_symbst sys_b} UNION (IMAGE birs_symb_to_symbst Pi_b)``; + val (tm_match, ty_match) = match_term pat_tm tm; + val Pi_a = pred_setSyntax.strip_set(subst tm_match (inst ty_match ``Pi_a:birs_state_t->bool``)); + val sys_b = subst tm_match (inst ty_match ``sys_b:birs_state_t``); + val Pi_b = pred_setSyntax.strip_set(subst tm_match (inst ty_match ``Pi_b:birs_state_t->bool``)); + fun eq_fun sys1 sys2 = identical sys1 sys2; (* TODO: birs_state_eq_fun*) + fun in_f l x = List.foldr (fn (y, b) => b orelse eq_fun x y) false l; + val Pi_a_minus_b = List.filter (not o eq_fun sys_b) Pi_a; + fun UNION_foldfun (sys,Pi) = if in_f Pi sys then Pi else (sys::Pi); + val Pi_c = List.foldr UNION_foldfun Pi_a_minus_b Pi_b; + val tm_l_set = if List.null Pi_c then pred_setSyntax.mk_empty (``:birs_state_t``) else pred_setSyntax.mk_set Pi_c; (* -val tm = `` - EMPTY DIFF - { - BVar "sy_tmp_R0" (BType_Imm Bit32); - BVar "sy_tmp_R1" (BType_Imm Bit32); - BVar "sy_tmp_R2" (BType_Imm Bit32) - } -``; - -val tm = `` - { - BVar "sy_tmp_R0" (BType_Imm Bit32); - BVar "sy_tmp_R1" (BType_Imm Bit32); - BVar "sy_tmp_R2" (BType_Imm Bit32); - BVar "sy_tmp_R3" (BType_Imm Bit32); - BVar "sy_tmp_R4" (BType_Imm Bit32); - BVar "sy_tmp_R5" (BType_Imm Bit32) - } DIFF - EMPTY -``; - -val tm = `` - { - BVar "sy_tmp_R0" (BType_Imm Bit32); - BVar "sy_tmp_R1" (BType_Imm Bit32); - BVar "sy_tmp_R2" (BType_Imm Bit32); - BVar "sy_tmp_R3" (BType_Imm Bit32); - BVar "sy_tmp_R4" (BType_Imm Bit32); - BVar "sy_tmp_R5" (BType_Imm Bit32) - } DIFF - { - BVar "sy_tmp_R0" (BType_Imm Bit32); - BVar "sy_tmp_R1" (BType_Imm Bit32); - BVar "sy_tmp_R2" (BType_Imm Bit32) - } -``; - -val tm = `` -{ - BVar "sy_tmp_R0" (BType_Imm Bit32); - BVar "sy_tmp_R1" (BType_Imm Bit32); - BVar "sy_tmp_R4" (BType_Imm Bit32); - BVar "sy_tmp_R5" (BType_Imm Bit32); - BVar "sy_tmp_R8" (BType_Imm Bit32) -} INTER (^tm) -``; (* R4 and R5 *) +length Pi_a +length Pi_a_minus_b +length Pi_c *) + in + prove(``^tm = IMAGE birs_symb_to_symbst ^tm_l_set``, cheat) + end; + val speedcheat_diffunion = ref false; + val birs_state_DIFF_UNION_CONV = + if !speedcheat_diffunion then + DIFF_UNION_CONV_cheat + else + fn tm => + (REWRITE_CONV [IMAGE_DIFF_SING_thm, MATCH_MP IMAGE_DIFF_ASSOC_thm bir_symbTheory.birs_symb_to_symbst_EQ_thm, GSYM DELETE_DEF] THENC + RATOR_CONV (RAND_CONV (RAND_CONV ( -fun DIFF_CONV_Once el_EQ_CONV tm = - ( - IFC - (CHANGED_CONV (fn tm => REWRITE_CONV [Once INSERT_DIFF] tm)) - (RATOR_CONV (RATOR_CONV (RAND_CONV (pred_setLib.IN_CONV el_EQ_CONV))) THENC - REWRITE_CONV []) - (REFL) +fn tm => +( +pred_setLib.DELETE_CONV birs_state_EQ_CONV tm +handle ex => + (print "\n\n\n"; + print_term tm; + print "\n\n\n"; + raise ex ) - tm; - -fun DIFF_CONV el_EQ_CONV tm = - if pred_setSyntax.is_empty tm then - REFL tm - else if pred_setSyntax.is_diff tm then - if (pred_setSyntax.is_empty o fst o pred_setSyntax.dest_diff) tm then - (print_term tm; - REWRITE_CONV [EMPTY_DIFF] tm) - else if (pred_setSyntax.is_insert o fst o pred_setSyntax.dest_diff) tm then - (DIFF_CONV_Once el_EQ_CONV THENC - DIFF_CONV el_EQ_CONV) tm - else - raise ERR "DIFF_CONV" "unexpected1" - else if pred_setSyntax.is_insert tm then - RAND_CONV - (DIFF_CONV el_EQ_CONV) - tm - else - (print_term tm; - raise ERR "DIFF_CONV" "unexpected2"); - -(* -val el_EQ_CONV = EVAL; -DIFF_CONV el_EQ_CONV tm -*) - -val simplerewrite_thm = prove(`` -!s t g. -g INTER (s DIFF t) = -s INTER (g DIFF t) -``, -(*REWRITE_RULE [Once pred_setTheory.INTER_COMM] pred_setTheory.DIFF_INTER*) -METIS_TAC [pred_setTheory.INTER_COMM, pred_setTheory.DIFF_INTER] -); +) -fun freevarset_CONV tm = -( - REWRITE_CONV [Once (simplerewrite_thm)] THENC +))) THENC + REWRITE_CONV [MATCH_MP IMAGE_UNION_ASSOC_thm bir_symbTheory.birs_symb_to_symbst_EQ_thm] THENC + RAND_CONV (pred_setLib.UNION_CONV birs_state_EQ_CONV)) - (RAND_CONV ( - DIFF_CONV EVAL - )) THENC + tm; - (* then INTER *) - INTER_INSERT_CONV -) tm; end (* local *) diff --git a/src/tools/symbexec/bir_vars_ofLib.sml b/src/tools/symbexec/bir_vars_ofLib.sml index 2b69d85ae..c026580b8 100644 --- a/src/tools/symbexec/bir_vars_ofLib.sml +++ b/src/tools/symbexec/bir_vars_ofLib.sml @@ -10,6 +10,9 @@ open bir_typing_expSyntax; open HolBACoreSimps; +open birs_auxTheory; +val birs_state_ss = rewrites (type_rws ``:birs_state_t``); + (* error handling *) val libname = "bir_vars_ofLib" val ERR = Feedback.mk_HOL_ERR libname @@ -31,6 +34,502 @@ in (* local *) val bir_vars_of_exp_CONV = birs_auxLib.GEN_match_conv (is_bir_vars_of_exp) bir_vars_of_exp_DIRECT_CONV; +(* ------------------------------------------------------------ *) + +(* ------------------------------------------------------------------------ *) +(* COPIED FROM TRANSFER-TEST (and modified) *) +(* ------------------------------------------------------------------------ *) + +(* +val tm = `` +birs_symb_symbols + <|bsst_pc := <|bpc_label := BL_Address (Imm32 2824w); bpc_index := 0|>; + bsst_environ := (K NONE)⦇ + "MEM" ↦ SOME (BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); + "PSR_C" ↦ SOME (BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); + "PSR_N" ↦ SOME (BExp_Den (BVar "sy_PSR_N" (BType_Imm Bit1))); + "PSR_V" ↦ SOME (BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); + "PSR_Z" ↦ SOME (BExp_Den (BVar "sy_PSR_Z" (BType_Imm Bit1))); + "R0" ↦ SOME (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))); + "R1" ↦ SOME (BExp_Den (BVar "sy_R1" (BType_Imm Bit32))); + "R2" ↦ SOME (BExp_Den (BVar "sy_R2" (BType_Imm Bit32))); + "R3" ↦ SOME (BExp_Den (BVar "sy_R3" (BType_Imm Bit32))); + "R4" ↦ SOME (BExp_Den (BVar "sy_R4" (BType_Imm Bit32))); + "R5" ↦ SOME (BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); + "R6" ↦ SOME (BExp_Den (BVar "sy_R6" (BType_Imm Bit32))); + "R7" ↦ SOME (BExp_Den (BVar "sy_R7" (BType_Imm Bit32))); + "R8" ↦ SOME (BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); + "R9" ↦ SOME (BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); + "R10" ↦ SOME (BExp_Den (BVar "sy_R10" (BType_Imm Bit32))); + "R11" ↦ SOME (BExp_Den (BVar "sy_R11" (BType_Imm Bit32))); + "R12" ↦ SOME (BExp_Den (BVar "sy_R12" (BType_Imm Bit32))); + "LR" ↦ SOME (BExp_Den (BVar "sy_LR" (BType_Imm Bit32))); + "SP_main" ↦ + SOME (BExp_Den (BVar "sy_SP_main" (BType_Imm Bit32))); + "SP_process" ↦ + SOME (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))); + "ModeHandler" ↦ + SOME (BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1))); + "countw" ↦ SOME (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))); + "tmp_PC" ↦ SOME (BExp_Den (BVar "sy_tmp_PC" (BType_Imm Bit32))); + "tmp_COND" ↦ + SOME (BExp_Den (BVar "sy_tmp_COND" (BType_Imm Bit1))); + "tmp_MEM" ↦ + SOME (BExp_Den (BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8))); + "tmp_PSR_C" ↦ + SOME (BExp_Den (BVar "sy_tmp_PSR_C" (BType_Imm Bit1))); + "tmp_PSR_N" ↦ + SOME (BExp_Den (BVar "sy_tmp_PSR_N" (BType_Imm Bit1))); + "tmp_PSR_V" ↦ + SOME (BExp_Den (BVar "sy_tmp_PSR_V" (BType_Imm Bit1))); + "tmp_PSR_Z" ↦ + SOME (BExp_Den (BVar "sy_tmp_PSR_Z" (BType_Imm Bit1))); + "tmp_R0" ↦ SOME (BExp_Den (BVar "sy_tmp_R0" (BType_Imm Bit32))); + "tmp_R1" ↦ SOME (BExp_Den (BVar "sy_tmp_R1" (BType_Imm Bit32))); + "tmp_R2" ↦ SOME (BExp_Den (BVar "sy_tmp_R2" (BType_Imm Bit32))); + "tmp_R3" ↦ SOME (BExp_Den (BVar "sy_tmp_R3" (BType_Imm Bit32))); + "tmp_R4" ↦ SOME (BExp_Den (BVar "sy_tmp_R4" (BType_Imm Bit32))); + "tmp_R5" ↦ SOME (BExp_Den (BVar "sy_tmp_R5" (BType_Imm Bit32))); + "tmp_R6" ↦ SOME (BExp_Den (BVar "sy_tmp_R6" (BType_Imm Bit32))); + "tmp_R7" ↦ SOME (BExp_Den (BVar "sy_tmp_R7" (BType_Imm Bit32))); + "tmp_R8" ↦ SOME (BExp_Den (BVar "sy_tmp_R8" (BType_Imm Bit32))); + "tmp_R9" ↦ SOME (BExp_Den (BVar "sy_tmp_R9" (BType_Imm Bit32))); + "tmp_R10" ↦ + SOME (BExp_Den (BVar "sy_tmp_R10" (BType_Imm Bit32))); + "tmp_R11" ↦ + SOME (BExp_Den (BVar "sy_tmp_R11" (BType_Imm Bit32))); + "tmp_R12" ↦ + SOME (BExp_Den (BVar "sy_tmp_R12" (BType_Imm Bit32))); + "tmp_LR" ↦ SOME (BExp_Den (BVar "sy_tmp_LR" (BType_Imm Bit32))); + "tmp_SP_main" ↦ + SOME (BExp_Den (BVar "sy_tmp_SP_main" (BType_Imm Bit32))); + "tmp_SP_process" ↦ + SOME (BExp_Den (BVar "sy_tmp_SP_process" (BType_Imm Bit32))); + "tmp_ModeHandler" ↦ + SOME (BExp_Den (BVar "sy_tmp_ModeHandler" (BType_Imm Bit1))); + "tmp_countw" ↦ + SOME (BExp_Den (BVar "sy_tmp_countw" (BType_Imm Bit64))) + ⦈; + bsst_status := BST_Running; bsst_pcond := BExp_BinExp BIExp_Plus (BExp_Den (BVar "hello" (BType_Imm Bit8))) (BExp_BinExp BIExp_Plus (BExp_Den (BVar "hello" (BType_Imm Bit8))) (BExp_Const (Imm1 1w)))|> +``; + +val tm = `` +birs_exps_of_senv + (K NONE)⦇ + "MEM" ↦ SOME (BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); + "PSR_C" ↦ SOME (BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); + "PSR_N" ↦ SOME (BExp_Den (BVar "sy_PSR_N" (BType_Imm Bit1))); + "PSR_V" ↦ SOME (BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); + "PSR_Z" ↦ SOME (BExp_Den (BVar "sy_PSR_Z" (BType_Imm Bit1))); + "R0" ↦ SOME (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))); + "R1" ↦ SOME (BExp_Den (BVar "sy_R1" (BType_Imm Bit32))); + "R2" ↦ SOME (BExp_Den (BVar "sy_R2" (BType_Imm Bit32))); + "R3" ↦ SOME (BExp_Den (BVar "sy_R3" (BType_Imm Bit32))); + "R4" ↦ SOME (BExp_Den (BVar "sy_R4" (BType_Imm Bit32))); + "R5" ↦ SOME (BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); + "R6" ↦ SOME (BExp_Den (BVar "sy_R6" (BType_Imm Bit32))); + "R7" ↦ SOME (BExp_Den (BVar "sy_R7" (BType_Imm Bit32))); + "R8" ↦ SOME (BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); + "R9" ↦ SOME (BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); + "R10" ↦ SOME (BExp_Den (BVar "sy_R10" (BType_Imm Bit32))); + "R11" ↦ SOME (BExp_Den (BVar "sy_R11" (BType_Imm Bit32))); + "R12" ↦ SOME (BExp_Den (BVar "sy_R12" (BType_Imm Bit32))); + "LR" ↦ SOME (BExp_Den (BVar "sy_LR" (BType_Imm Bit32))); + "SP_main" ↦ SOME (BExp_Den (BVar "sy_SP_main" (BType_Imm Bit32))); + "SP_process" ↦ SOME (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))); + "ModeHandler" ↦ SOME (BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1))); + "countw" ↦ SOME (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))); + "tmp_PC" ↦ SOME (BExp_Den (BVar "sy_tmp_PC" (BType_Imm Bit32))); + "tmp_COND" ↦ SOME (BExp_Den (BVar "sy_tmp_COND" (BType_Imm Bit1))); + "tmp_MEM" ↦ SOME (BExp_Den (BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8))); + "tmp_PSR_C" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_C" (BType_Imm Bit1))); + "tmp_PSR_N" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_N" (BType_Imm Bit1))); + "tmp_PSR_V" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_V" (BType_Imm Bit1))); + "tmp_PSR_Z" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_Z" (BType_Imm Bit1))); + "tmp_R0" ↦ SOME (BExp_Den (BVar "sy_tmp_R0" (BType_Imm Bit32))); + "tmp_R1" ↦ SOME (BExp_Den (BVar "sy_tmp_R1" (BType_Imm Bit32))); + "tmp_R2" ↦ SOME (BExp_Den (BVar "sy_tmp_R2" (BType_Imm Bit32))); + "tmp_R3" ↦ SOME (BExp_Den (BVar "sy_tmp_R3" (BType_Imm Bit32))); + "tmp_R4" ↦ SOME (BExp_Den (BVar "sy_tmp_R4" (BType_Imm Bit32))); + "tmp_R5" ↦ SOME (BExp_Den (BVar "sy_tmp_R5" (BType_Imm Bit32))); + "tmp_R6" ↦ SOME (BExp_Den (BVar "sy_tmp_R6" (BType_Imm Bit32))); + "tmp_R7" ↦ SOME (BExp_Den (BVar "sy_tmp_R7" (BType_Imm Bit32))); + "tmp_R8" ↦ SOME (BExp_Den (BVar "sy_tmp_R8" (BType_Imm Bit32))); + "tmp_R9" ↦ SOME (BExp_Den (BVar "sy_tmp_R9" (BType_Imm Bit32))); + "tmp_R10" ↦ SOME (BExp_Den (BVar "sy_tmp_R10" (BType_Imm Bit32))); + "tmp_R11" ↦ SOME (BExp_Den (BVar "sy_tmp_R11" (BType_Imm Bit32))); + "tmp_R12" ↦ SOME (BExp_Den (BVar "sy_tmp_R12" (BType_Imm Bit32))); + "tmp_LR" ↦ SOME (BExp_Den (BVar "sy_tmp_LR" (BType_Imm Bit32))); + "tmp_SP_main" ↦ SOME (BExp_Den (BVar "sy_tmp_SP_main" (BType_Imm Bit32))); + "tmp_SP_process" ↦ + SOME (BExp_Den (BVar "sy_tmp_SP_process" (BType_Imm Bit32))); + "tmp_ModeHandler" ↦ + SOME (BExp_Den (BVar "sy_tmp_ModeHandler" (BType_Imm Bit1))); + "tmp_countw" ↦ SOME (BExp_Den (BVar "sy_tmp_countw" (BType_Imm Bit64))) + ⦈ +``; + +val tm = `` + birs_exps_of_senv_COMP ∅ + (K NONE)⦇ + "MEM" ↦ SOME (BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); + "PSR_C" ↦ SOME (BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); + "PSR_N" ↦ SOME (BExp_Den (BVar "sy_PSR_N" (BType_Imm Bit1))); + "PSR_V" ↦ SOME (BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); + "PSR_Z" ↦ SOME (BExp_Den (BVar "sy_PSR_Z" (BType_Imm Bit1))); + "R0" ↦ SOME (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))); + "R1" ↦ SOME (BExp_Den (BVar "sy_R1" (BType_Imm Bit32))); + "R2" ↦ SOME (BExp_Den (BVar "sy_R2" (BType_Imm Bit32))); + "R3" ↦ SOME (BExp_Den (BVar "sy_R3" (BType_Imm Bit32))); + "R4" ↦ SOME (BExp_Den (BVar "sy_R4" (BType_Imm Bit32))); + "R5" ↦ SOME (BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); + "R6" ↦ SOME (BExp_Den (BVar "sy_R6" (BType_Imm Bit32))); + "R7" ↦ SOME (BExp_Den (BVar "sy_R7" (BType_Imm Bit32))); + "R8" ↦ SOME (BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); + "R9" ↦ SOME (BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); + "R10" ↦ SOME (BExp_Den (BVar "sy_R10" (BType_Imm Bit32))); + "R11" ↦ SOME (BExp_Den (BVar "sy_R11" (BType_Imm Bit32))); + "R12" ↦ SOME (BExp_Den (BVar "sy_R12" (BType_Imm Bit32))); + "LR" ↦ SOME (BExp_Den (BVar "sy_LR" (BType_Imm Bit32))); + "SP_main" ↦ SOME (BExp_Den (BVar "sy_SP_main" (BType_Imm Bit32))); + "SP_process" ↦ + SOME (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))); + "ModeHandler" ↦ + SOME (BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1))); + "countw" ↦ SOME (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))); + "tmp_PC" ↦ SOME (BExp_Den (BVar "sy_tmp_PC" (BType_Imm Bit32))); + "tmp_COND" ↦ SOME (BExp_Den (BVar "sy_tmp_COND" (BType_Imm Bit1))); + "tmp_MEM" ↦ + SOME (BExp_Den (BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8))); + "tmp_PSR_C" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_C" (BType_Imm Bit1))); + "tmp_PSR_N" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_N" (BType_Imm Bit1))); + "tmp_PSR_V" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_V" (BType_Imm Bit1))); + "tmp_PSR_Z" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_Z" (BType_Imm Bit1))); + "tmp_R0" ↦ SOME (BExp_Den (BVar "sy_tmp_R0" (BType_Imm Bit32))); + "tmp_R1" ↦ SOME (BExp_Den (BVar "sy_tmp_R1" (BType_Imm Bit32))); + "tmp_R2" ↦ SOME (BExp_Den (BVar "sy_tmp_R2" (BType_Imm Bit32))); + "tmp_R3" ↦ SOME (BExp_Den (BVar "sy_tmp_R3" (BType_Imm Bit32))); + "tmp_R4" ↦ SOME (BExp_Den (BVar "sy_tmp_R4" (BType_Imm Bit32))); + "tmp_R5" ↦ SOME (BExp_Den (BVar "sy_tmp_R5" (BType_Imm Bit32))); + "tmp_R6" ↦ SOME (BExp_Den (BVar "sy_tmp_R6" (BType_Imm Bit32))); + "tmp_R7" ↦ SOME (BExp_Den (BVar "sy_tmp_R7" (BType_Imm Bit32))); + "tmp_R8" ↦ SOME (BExp_Den (BVar "sy_tmp_R8" (BType_Imm Bit32))); + "tmp_R9" ↦ SOME (BExp_Den (BVar "sy_tmp_R9" (BType_Imm Bit32))); + "tmp_R10" ↦ SOME (BExp_Den (BVar "sy_tmp_R10" (BType_Imm Bit32))); + "tmp_R11" ↦ SOME (BExp_Den (BVar "sy_tmp_R11" (BType_Imm Bit32))); + "tmp_R12" ↦ SOME (BExp_Den (BVar "sy_tmp_R12" (BType_Imm Bit32))); + "tmp_LR" ↦ SOME (BExp_Den (BVar "sy_tmp_LR" (BType_Imm Bit32))); + "tmp_SP_main" ↦ + SOME (BExp_Den (BVar "sy_tmp_SP_main" (BType_Imm Bit32))); + "tmp_SP_process" ↦ + SOME (BExp_Den (BVar "sy_tmp_SP_process" (BType_Imm Bit32))); + "tmp_ModeHandler" ↦ + SOME (BExp_Den (BVar "sy_tmp_ModeHandler" (BType_Imm Bit1))); + "tmp_countw" ↦ + SOME (BExp_Den (BVar "sy_tmp_countw" (BType_Imm Bit64))) + ⦈ +``; + +val tm = `` + birs_exps_of_senv_COMP ∅ + (K NONE)⦇ + "MEM" ↦ SOME (BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); + "PSR_C" ↦ SOME (BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); + "PSR_N" ↦ SOME (BExp_Den (BVar "sy_PSR_N" (BType_Imm Bit1))); + "PSR_V" ↦ SOME (BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); + "PSR_Z" ↦ SOME (BExp_Den (BVar "sy_PSR_Z" (BType_Imm Bit1))) + ⦈ +``; + +val tm2 = `` + birs_exps_of_senv_COMP ∅ + (K NONE) +``; + +val tm = `` +birs_exps_of_senv_COMP {"PSR_Z"; "PSR_V"; "PSR_N"; "PSR_C"; "MEM"} (K NONE) +``; + + +val tm = `` +birs_exps_of_senv + (K NONE)⦇ + "tmp_SP_process" ↦ + SOME + (BExp_BinExp BIExp_Minus + (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))) + (BExp_Const (Imm32 8w))); + "MEM" ↦ SOME (BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); + "PSR_C" ↦ SOME (BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); + "PSR_N" ↦ SOME (BExp_Den (BVar "sy_PSR_N" (BType_Imm Bit1))); + "PSR_V" ↦ SOME (BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); + "PSR_Z" ↦ SOME (BExp_Den (BVar "sy_PSR_Z" (BType_Imm Bit1))); + "R0" ↦ SOME (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))); + "R1" ↦ SOME (BExp_Den (BVar "sy_R1" (BType_Imm Bit32))); + "R2" ↦ SOME (BExp_Den (BVar "sy_R2" (BType_Imm Bit32))); + "R3" ↦ SOME (BExp_Den (BVar "sy_R3" (BType_Imm Bit32))); + "R4" ↦ SOME (BExp_Den (BVar "sy_R4" (BType_Imm Bit32))); + "R5" ↦ SOME (BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); + "R6" ↦ SOME (BExp_Den (BVar "sy_R6" (BType_Imm Bit32))); + "R7" ↦ SOME (BExp_Den (BVar "sy_R7" (BType_Imm Bit32))); + "R8" ↦ SOME (BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); + "R9" ↦ SOME (BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); + "R10" ↦ SOME (BExp_Den (BVar "sy_R10" (BType_Imm Bit32))); + "R11" ↦ SOME (BExp_Den (BVar "sy_R11" (BType_Imm Bit32))); + "R12" ↦ SOME (BExp_Den (BVar "sy_R12" (BType_Imm Bit32))); + "LR" ↦ SOME (BExp_Den (BVar "sy_LR" (BType_Imm Bit32))); + "SP_main" ↦ SOME (BExp_Den (BVar "sy_SP_main" (BType_Imm Bit32))); + "SP_process" ↦ SOME (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))); + "ModeHandler" ↦ SOME (BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1))); + "countw" ↦ SOME (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))); + "tmp_PC" ↦ SOME (BExp_Den (BVar "sy_tmp_PC" (BType_Imm Bit32))); + "tmp_COND" ↦ SOME (BExp_Den (BVar "sy_tmp_COND" (BType_Imm Bit1))); + "tmp_MEM" ↦ SOME (BExp_Den (BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8))); + "tmp_PSR_C" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_C" (BType_Imm Bit1))); + "tmp_PSR_N" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_N" (BType_Imm Bit1))); + "tmp_PSR_V" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_V" (BType_Imm Bit1))); + "tmp_PSR_Z" ↦ SOME (BExp_Den (BVar "sy_tmp_PSR_Z" (BType_Imm Bit1))); + "tmp_R0" ↦ SOME (BExp_Den (BVar "sy_tmp_R0" (BType_Imm Bit32))); + "tmp_R1" ↦ SOME (BExp_Den (BVar "sy_tmp_R1" (BType_Imm Bit32))); + "tmp_R2" ↦ SOME (BExp_Den (BVar "sy_tmp_R2" (BType_Imm Bit32))); + "tmp_R3" ↦ SOME (BExp_Den (BVar "sy_tmp_R3" (BType_Imm Bit32))); + "tmp_R4" ↦ SOME (BExp_Den (BVar "sy_tmp_R4" (BType_Imm Bit32))); + "tmp_R5" ↦ SOME (BExp_Den (BVar "sy_tmp_R5" (BType_Imm Bit32))); + "tmp_R6" ↦ SOME (BExp_Den (BVar "sy_tmp_R6" (BType_Imm Bit32))); + "tmp_R7" ↦ SOME (BExp_Den (BVar "sy_tmp_R7" (BType_Imm Bit32))); + "tmp_R8" ↦ SOME (BExp_Den (BVar "sy_tmp_R8" (BType_Imm Bit32))); + "tmp_R9" ↦ SOME (BExp_Den (BVar "sy_tmp_R9" (BType_Imm Bit32))); + "tmp_R10" ↦ SOME (BExp_Den (BVar "sy_tmp_R10" (BType_Imm Bit32))); + "tmp_R11" ↦ SOME (BExp_Den (BVar "sy_tmp_R11" (BType_Imm Bit32))); + "tmp_R12" ↦ SOME (BExp_Den (BVar "sy_tmp_R12" (BType_Imm Bit32))); + "tmp_LR" ↦ SOME (BExp_Den (BVar "sy_tmp_LR" (BType_Imm Bit32))); + "tmp_SP_main" ↦ SOME (BExp_Den (BVar "sy_tmp_SP_main" (BType_Imm Bit32))); + "tmp_SP_process" ↦ + SOME (BExp_Den (BVar "sy_tmp_SP_process" (BType_Imm Bit32))); + "tmp_ModeHandler" ↦ + SOME (BExp_Den (BVar "sy_tmp_ModeHandler" (BType_Imm Bit1))); + "tmp_countw" ↦ SOME (BExp_Den (BVar "sy_tmp_countw" (BType_Imm Bit64))) + ⦈ +``; + + +val tm = `` +birs_exps_of_senv_COMP {"tmp_SP_process"} + (K NONE)⦇ + "tmp_SP_process" ↦ + SOME + (BExp_BinExp BIExp_Minus + (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))) + (BExp_Const (Imm32 8w))); + "tmp_ModeHandler" ↦ + SOME (BExp_Den (BVar "sy_tmp_ModeHandler" (BType_Imm Bit1))); + "tmp_countw" ↦ + SOME (BExp_Den (BVar "sy_tmp_countw" (BType_Imm Bit64))) + ⦈ +``; + +*) + +val debug_conv = (fn tm => (print_term tm; raise Fail "abcdE!!!")); +val debug_conv2 = (fn tm => (if true then print ".\n" else print_term tm; REFL tm)); + +(* +REPEATC + (SIMP_CONV (std_ss) []) THENC + (ONCE_DEPTH_CONV ( (PAT_CONV ``\A. if A then B else (C)`` (REWRITE_CONV [pred_setTheory.COMPONENT] THENC SIMP_CONV std_ss [pred_setTheory.IN_INSERT])))) THENC + SIMP_CONV (std_ss) [] +*) + +(* ................................................ *) + +fun string_in_set_CONV tm = +( + REWRITE_CONV [pred_setTheory.NOT_IN_EMPTY] THENC + REPEATC (CHANGED_CONV ((fn xyz => REWRITE_CONV [Once pred_setTheory.IN_INSERT] xyz) THENC + IFC + (RATOR_CONV EVAL) + (BETA_CONV THENC REWRITE_CONV [pred_setTheory.NOT_IN_EMPTY]) + REFL)) +) tm; + +fun birs_exps_of_senv_COMP_ONCE_CONV tm = +( + (QCHANGED_CONV (CHANGED_CONV (fn x => REWRITE_CONV [Once birs_exps_of_senv_COMP_thm] x))) THENC + IFC + (RATOR_CONV (RATOR_CONV (RAND_CONV (string_in_set_CONV)))) + (REWRITE_CONV []) + (REFL) +) tm; + +(* TODO: add proper exceptions/exception messages if the unexpected happens... *) +fun birs_exps_of_senv_COMP_CONV_cheat tm = + let + val (s1, s2_l) = strip_comb tm; + val _ = if ((fst o dest_const) s1) = "birs_exps_of_senv_COMP" then () else + raise ERR "birs_exps_of_senv_COMP_CONV_cheat" "constant not found"; + val _ = if length s2_l = 2 then () else + raise ERR "birs_exps_of_senv_COMP_CONV_cheat" "application not right"; + val initvarset = List.nth(s2_l, 0); + val _ = if pred_setSyntax.is_empty initvarset then () else + raise ERR "birs_exps_of_senv_COMP_CONV_cheat" "must start with empty set"; + + val tm_map = List.nth(s2_l, 1); + + fun eq_fun tm1 tm2 = tm1 = tm2; + fun in_f l x = List.foldr (fn (y, b) => b orelse eq_fun x y) false l; + + val base_term = ``(K NONE):string -> bir_exp_t option``; + fun collectfun excl acc tm_map = + if identical tm_map base_term then acc else + if not (combinSyntax.is_update_comb tm_map) then raise ERR "birs_exps_of_senv_COMP_CONV_cheat" "should not happen" else + let + val ((mem_upd_k, mem_upd_v), tm_map_sub) = combinSyntax.dest_update_comb tm_map; + val mem_upd_v_v = optionSyntax.dest_some mem_upd_v; + val mem_upd_k_s = stringSyntax.fromHOLstring mem_upd_k; + val k_s_is_excl = in_f excl mem_upd_k_s; + val new_acc = if k_s_is_excl then (acc) else ([mem_upd_v_v]@acc); + val new_excl = if k_s_is_excl then (excl) else ([mem_upd_k_s]@excl); + in + collectfun new_excl new_acc tm_map_sub + end; + +(* + val s1_l = pred_setSyntax.strip_set s1; + val s2_l = pred_setSyntax.strip_set s2; +List.foldr (fn (x, l) => if not (in_f s2_l x) then x::l else l) [] s1_l; +*) + + val l = collectfun [] [] tm_map; + val tm_l_set = if List.null l then pred_setSyntax.mk_empty(``:bir_exp_t``) else pred_setSyntax.mk_set l; + in + mk_oracle_thm "FISHY_BIRS_BIR_SENV_VARSET" ([], mk_eq (tm, tm_l_set)) + end; + +fun birs_exps_of_senv_COMP_CONV_norm tm = +( +(*(fn tm => (if false then print ".\n" else print_term tm; REFL tm)) THENC*) +(* (fn tm => (if true then print ".\n" else print_term tm; REFL tm)) THENC *) +(* + if pred_setSyntax.is_empty tm then + REFL + else +*) + IFC + (birs_exps_of_senv_COMP_ONCE_CONV) + (TRY_CONV (fn tm => ( + if pred_setSyntax.is_empty tm then + REFL + else if pred_setSyntax.is_insert tm then + RAND_CONV birs_exps_of_senv_COMP_CONV_norm + else + birs_exps_of_senv_COMP_CONV_norm + ) tm)) + (fn tm => (print_term tm; raise Fail "unexpected here")) +) tm; + +val speedcheat = ref false; +val birs_exps_of_senv_COMP_CONV = + if !speedcheat then + birs_exps_of_senv_COMP_CONV_cheat + else + birs_exps_of_senv_COMP_CONV_norm; + + +fun birs_exps_of_senv_CONV tm = +( +(* +(fn tm => (if false then print ".\n" else print_term tm; REFL tm)) THENC +*) + REWRITE_CONV [birs_exps_of_senv_thm] THENC + ((*TRY_CONV*) birs_exps_of_senv_COMP_CONV) +) tm; + +fun is_birs_exps_of_senv tm = is_comb tm andalso + (is_const o fst o dest_comb) tm andalso + ((fn tm2 => tm2 = "birs_exps_of_senv") o fst o dest_const o fst o dest_comb) tm; +fun birs_symb_symbols_CONV tm = +( + SIMP_CONV (std_ss++birs_state_ss) [birs_symb_symbols_thm] THENC + debug_conv2 THENC + birs_auxLib.GEN_match_conv is_birs_exps_of_senv birs_exps_of_senv_CONV THENC + debug_conv2 THENC + REWRITE_CONV [pred_setTheory.IMAGE_INSERT, pred_setTheory.IMAGE_EMPTY] THENC + bir_vars_of_exp_CONV THENC + + debug_conv2 THENC + RATOR_CONV (RAND_CONV (REWRITE_CONV [pred_setTheory.BIGUNION_INSERT, pred_setTheory.BIGUNION_EMPTY])) THENC + + REWRITE_CONV [Once pred_setTheory.UNION_COMM] THENC + REWRITE_CONV [pred_setTheory.UNION_ASSOC, pred_setTheory.INSERT_UNION_EQ, pred_setTheory.UNION_EMPTY] +) tm; + +fun is_birs_symb_symbols tm = is_comb tm andalso + (is_const o fst o dest_comb) tm andalso + ((fn tm2 => tm2 = "birs_symb_symbols") o fst o dest_const o fst o dest_comb) tm; +fun birs_symb_symbols_MATCH_CONV tm = + birs_auxLib.GEN_match_conv is_birs_symb_symbols birs_symb_symbols_CONV tm; + + +(* ---------------------------------------------------------------------------------- *) +(* set of free vars *) +(* ---------------------------------------------------------------------------------- *) +val simplerewrite_thm = prove(`` +!s t g. +g INTER (s DIFF t) = +s INTER (g DIFF t) +``, +(*REWRITE_RULE [Once pred_setTheory.INTER_COMM] pred_setTheory.DIFF_INTER*) +METIS_TAC [pred_setTheory.INTER_COMM, pred_setTheory.DIFF_INTER] +); + +fun freevarset_CONV tm = +( + REWRITE_CONV [Once (simplerewrite_thm)] THENC + + (RAND_CONV ( + aux_setLib.DIFF_CONV EVAL + )) THENC + + (* then INTER *) + aux_setLib.INTER_INSERT_CONV +) tm; + +(* +fun freevarset_CONV tm = +( + REWRITE_CONV [Once (prove(`` +!s t g. +g INTER (s DIFF t) = +s INTER (g DIFF t) +``, +(*REWRITE_RULE [Once pred_setTheory.INTER_COMM] pred_setTheory.DIFF_INTER*) +METIS_TAC [pred_setTheory.INTER_COMM, pred_setTheory.DIFF_INTER] +))] THENC + + (* DIFF first *) +(* + RATOR_CONV (RAND_CONV (SIMP_CONV (std_ss++HolBACoreSimps.holBACore_ss++string_ss) [pred_setTheory.INSERT_INTER, pred_setTheory.INTER_EMPTY])) THENC +*) + (* RATOR_CONV (RAND_CONV (INTER_INSERT_CONV)) THENC*) + (RAND_CONV ( +(* + (fn tm => prove (``^tm = EMPTY``, cheat)) +*) + aux_setLib.DIFF_INSERT_CONV +)) THENC +(* +(fn tm => (if false then print ".\n" else print_term tm; print "aa\n\n"; REFL tm)) THENC +*) + + + + (* then INTER *) + aux_setLib.INTER_INSERT_CONV +) tm; + +(* EVAL tm *) +*) + end (* local *) end (* struct *) diff --git a/src/tools/symbexec/birs_composeLib.sml b/src/tools/symbexec/birs_composeLib.sml index 998a2b37e..23a7c1c1e 100644 --- a/src/tools/symbexec/birs_composeLib.sml +++ b/src/tools/symbexec/birs_composeLib.sml @@ -61,47 +61,13 @@ fun birs_rule_SEQ_prog_fun bprog_tm = fun birs_rule_SEQ_free_symbols_fun freesymbols_tm freesymbols_B_thm_o = let -fun freevarset_CONV tm = -( - REWRITE_CONV [Once (prove(`` -!s t g. -g INTER (s DIFF t) = -s INTER (g DIFF t) -``, -(*REWRITE_RULE [Once pred_setTheory.INTER_COMM] pred_setTheory.DIFF_INTER*) -METIS_TAC [pred_setTheory.INTER_COMM, pred_setTheory.DIFF_INTER] -))] THENC - - (* DIFF first *) -(* - RATOR_CONV (RAND_CONV (SIMP_CONV (std_ss++HolBACoreSimps.holBACore_ss++string_ss) [pred_setTheory.INSERT_INTER, pred_setTheory.INTER_EMPTY])) THENC -*) - (* RATOR_CONV (RAND_CONV (INTER_INSERT_CONV)) THENC*) - (RAND_CONV ( -(* - (fn tm => prove (``^tm = EMPTY``, cheat)) -*) - aux_setLib.DIFF_INSERT_CONV -)) THENC -(* -(fn tm => (if false then print ".\n" else print_term tm; print "aa\n\n"; REFL tm)) THENC -*) - - - - (* then INTER *) - aux_setLib.INTER_INSERT_CONV -) tm; - -(* EVAL tm *) - (* ------------------------------------------------------------------------ *) (* ------------------------------------------------------------------------ *) - val superspeedcheat = false; + val speedcheat = ref false; val freesymbols_thm = prove(freesymbols_tm, - (if superspeedcheat then cheat else ALL_TAC) >> + (if !speedcheat then cheat else ALL_TAC) >> (case freesymbols_B_thm_o of NONE => ALL_TAC | SOME freesymbols_B_thm => REWRITE_TAC [freesymbols_B_thm, pred_setTheory.INTER_EMPTY]) >> @@ -113,7 +79,7 @@ METIS_TAC [pred_setTheory.INTER_COMM, pred_setTheory.DIFF_INTER] - CONV_TAC (aux_setLib.birs_symb_symbols_MATCH_CONV) >> + CONV_TAC (bir_vars_ofLib.birs_symb_symbols_MATCH_CONV) >> (* CONV_TAC ( SIMP_CONV (std_ss++birs_state_ss) [birs_symb_symbols_thm] THENC @@ -240,7 +206,7 @@ prove(``{BVar "sy_tmp_countw" (BType_Imm Bit64); *) - CONV_TAC (RATOR_CONV (RAND_CONV (aux_setLib.freevarset_CONV))) >> + CONV_TAC (RATOR_CONV (RAND_CONV (bir_vars_ofLib.freevarset_CONV))) >> (fn (al,g) => (print "finished to proof free symbols operation\n"; ([(al,g)], fn ([t]) => t))) >> REWRITE_TAC [pred_setTheory.EMPTY_SUBSET] From 1358b7f757c75d900f20473a38c10fb3b5978925 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 30 Sep 2024 17:57:56 +0200 Subject: [PATCH 48/95] Refactor free symbol definition --- .../tools/symbexec/birs_rulesScript.sml | 226 ++++++++++++------ .../tools/symbexec/symb_recordScript.sml | 12 + .../tools/symbexec/symb_rulesScript.sml | 16 +- src/tools/symbexec/bir_vars_ofLib.sml | 63 ++--- src/tools/symbexec/birsSyntax.sml | 12 +- src/tools/symbexec/birs_composeLib.sml | 41 +--- .../analysis/motorfunc_transfScript.sml | 4 +- 7 files changed, 229 insertions(+), 145 deletions(-) diff --git a/src/theory/tools/symbexec/birs_rulesScript.sml b/src/theory/tools/symbexec/birs_rulesScript.sml index aae8aae2e..52a508534 100644 --- a/src/theory/tools/symbexec/birs_rulesScript.sml +++ b/src/theory/tools/symbexec/birs_rulesScript.sml @@ -359,45 +359,110 @@ QED (* ******************************************************* *) -(* NO FRESH SYMBS *) +(* FREE SYMBS *) (* ******************************************************* *) -Definition birs_fresh_symbs_def: - birs_fresh_symbs bs1 bs2 = - ((birs_symb_symbols bs2) DIFF (birs_symb_symbols bs1)) +Definition birs_symb_symbols_set_def: + birs_symb_symbols_set Pi = + BIGUNION (IMAGE birs_symb_symbols Pi) End -Definition birs_NO_fresh_symbs_def: - birs_NO_fresh_symbs bs1 bs2 = - (birs_fresh_symbs bs1 bs2 = EMPTY) -End +Theorem birs_symb_symbols_set_EQ_thm: + !prog Pi. symb_symbols_set (bir_symb_rec_sbir prog) (IMAGE birs_symb_to_symbst Pi) = birs_symb_symbols_set Pi +Proof + REWRITE_TAC [birs_auxTheory.symb_symbols_set_ALT_thm, birs_symb_symbols_set_def] >> + REWRITE_TAC [pred_setTheory.IMAGE_IMAGE, combinTheory.o_DEF, birs_symb_symbols_EQ_thm] >> + METIS_TAC [] +QED -Definition birs_set_fresh_symbs_def: - birs_set_fresh_symbs bs sbs = +Definition birs_freesymbs_def: + birs_freesymbs bs sbs = ((BIGUNION (IMAGE birs_symb_symbols sbs)) DIFF (birs_symb_symbols bs)) End -Definition birs_set_NO_fresh_symbs_def: - birs_set_NO_fresh_symbs bs sbs = - (birs_set_fresh_symbs bs sbs = EMPTY) +Theorem birs_freesymbs_EQ_thm: + !prog L bs sbs. + birs_freesymbs bs sbs = symb_freesymbs (bir_symb_rec_sbir prog) (birs_symb_to_symbst bs, L, IMAGE birs_symb_to_symbst sbs) +Proof + REWRITE_TAC [birs_freesymbs_def, symb_freesymbs_def] >> + REWRITE_TAC [birs_auxTheory.symb_symbols_set_ALT_thm] >> + REWRITE_TAC [pred_setTheory.IMAGE_IMAGE, combinTheory.o_DEF, birs_symb_symbols_EQ_thm] >> + METIS_TAC [] +QED + +Definition birs_freesymbs_SING_def: + birs_freesymbs_SING bs1 bs2 = + ((birs_symb_symbols bs2) DIFF (birs_symb_symbols bs1)) End -Theorem birs_NO_fresh_symbs_SUFFICIENT_thm: + +(* ******************************************************* *) +(* SEQ rule *) +(* ******************************************************* *) +val betterTheorem = prove(`` +!sr. +!sys_A L_A Pi_A sys_B L_B Pi_B. + (symb_symbols_f_sound sr) ==> + + (symb_hl_step_in_L_sound sr (sys_A, L_A, Pi_A)) ==> + (symb_hl_step_in_L_sound sr (sys_B, L_B, Pi_B)) ==> + + (* can't reintroduce symbols in fragment B that have been lost in A *) + ((symb_symbols sr sys_A) INTER (symb_freesymbs sr (sys_B, L_B, Pi_B)) = EMPTY) ==> + + (symb_hl_step_in_L_sound sr (sys_A, L_A UNION L_B, (Pi_A DIFF {sys_B}) UNION Pi_B)) +``, + METIS_TAC[symb_rulesTheory.symb_rule_SEQ_thm] +); + +Theorem birs_rule_SEQ_gen_thm: + !prog bsys_A L_A bPi_A bsys_B L_B bPi_B. + (symb_hl_step_in_L_sound (bir_symb_rec_sbir prog) (birs_symb_to_symbst bsys_A, L_A, IMAGE birs_symb_to_symbst bPi_A)) ==> + (symb_hl_step_in_L_sound (bir_symb_rec_sbir prog) (birs_symb_to_symbst bsys_B, L_B, IMAGE birs_symb_to_symbst bPi_B)) ==> + + ((birs_symb_symbols bsys_A) INTER (birs_freesymbs bsys_B bPi_B) = EMPTY) ==> + + (*(symb_hl_step_in_L_sound (bir_symb_rec_sbir prog) (birs_symb_to_symbst bsys_A, L_A UNION L_B, IMAGE birs_symb_to_symbst ((bPi_A DIFF {bsys_B}) UNION bPi_B))) *) + (symb_hl_step_in_L_sound (bir_symb_rec_sbir prog) (birs_symb_to_symbst bsys_A, L_A UNION L_B, ((IMAGE birs_symb_to_symbst bPi_A) DIFF {birs_symb_to_symbst bsys_B}) UNION (IMAGE birs_symb_to_symbst bPi_B))) +Proof + REPEAT GEN_TAC >> + REWRITE_TAC [ISPECL [``prog: 'a bir_program_t``, ``L_B:bir_programcounter_t -> bool``, ``bsys_B:birs_state_t``, ``bPi_B:birs_state_t -> bool``] birs_freesymbs_EQ_thm] >> + REWRITE_TAC [GSYM birs_symb_symbols_EQ_thm] >> + REPEAT STRIP_TAC >> + ASSUME_TAC (ISPEC ``prog: 'a bir_program_t`` bir_symb_soundTheory.birs_symb_symbols_f_sound_thm) >> + METIS_TAC [betterTheorem] +QED + + +(* ******************************************************* *) +(* NO FREE SYMBS *) +(* ******************************************************* *) +Definition birs_freesymbs_EMPTY_def: + birs_freesymbs_EMPTY bs sbs = + (birs_freesymbs bs sbs = EMPTY) +End + +Definition birs_freesymbs_SING_EMPTY_def: + birs_freesymbs_SING_EMPTY bs1 bs2 = + (birs_freesymbs_SING bs1 bs2 = EMPTY) +End + +Theorem birs_freesymbs_SING_EMPTY_SUFFICIENT_thm: !bs1 bs2. (bs1.bsst_environ = bs2.bsst_environ /\ bs1.bsst_pcond = bs2.bsst_pcond) ==> - (birs_NO_fresh_symbs bs1 bs2) + (birs_freesymbs_SING_EMPTY bs1 bs2) Proof -SIMP_TAC std_ss [birs_NO_fresh_symbs_def, birs_fresh_symbs_def, birs_symb_symbols_def, DIFF_EQ_EMPTY] +SIMP_TAC std_ss [birs_freesymbs_SING_EMPTY_def, birs_freesymbs_SING_def, birs_symb_symbols_def, DIFF_EQ_EMPTY] QED -Theorem birs_NO_fresh_symbs_SUFFICIENT2_thm: +Theorem birs_freesymbs_SING_EMPTY_SUFFICIENT2_thm: !bs1 bs2 bs2'. - (birs_NO_fresh_symbs bs1 bs2 /\ + (birs_freesymbs_SING_EMPTY bs1 bs2 /\ bs2.bsst_environ = bs2'.bsst_environ /\ bs2.bsst_pcond = bs2'.bsst_pcond) ==> - (birs_NO_fresh_symbs bs1 bs2') + (birs_freesymbs_SING_EMPTY bs1 bs2') Proof -SIMP_TAC std_ss [birs_NO_fresh_symbs_def, birs_fresh_symbs_def, birs_symb_symbols_def, DIFF_EQ_EMPTY] >> +SIMP_TAC std_ss [birs_freesymbs_SING_EMPTY_def, birs_freesymbs_SING_def, birs_symb_symbols_def, DIFF_EQ_EMPTY] >> REPEAT STRIP_TAC >> METIS_TAC [] QED @@ -412,13 +477,13 @@ FULL_SIMP_TAC (std_ss++pred_setSimps.PRED_SET_ss) [SUBSET_DEF] >> METIS_TAC [] QED -Theorem birs_NO_fresh_symbs_SUFFICIENT3_thm: +Theorem birs_freesymbs_SING_EMPTY_SUFFICIENT3_thm: !bs1 bs1' bs2. - (birs_NO_fresh_symbs bs1 bs2 /\ + (birs_freesymbs_SING_EMPTY bs1 bs2 /\ (birs_symb_symbols bs1) SUBSET (birs_symb_symbols bs1')) ==> - (birs_NO_fresh_symbs bs1' bs2) + (birs_freesymbs_SING_EMPTY bs1' bs2) Proof -SIMP_TAC std_ss [birs_NO_fresh_symbs_def, birs_fresh_symbs_def, DIFF_EQ_EMPTY] >> +SIMP_TAC std_ss [birs_freesymbs_SING_EMPTY_def, birs_freesymbs_SING_def, DIFF_EQ_EMPTY] >> REPEAT STRIP_TAC >> METIS_TAC [SUBSET_of_DIFF_2_thm, SUBSET_EMPTY] @@ -432,19 +497,19 @@ SIMP_TAC (std_ss) [EXTENSION, IN_BIGUNION_IMAGE, IN_DIFF] >> METIS_TAC [] QED -Theorem birs_set_fresh_symbs_thm: +Theorem birs_freesymbs_thm: !bs sbs. - (birs_set_fresh_symbs bs sbs = BIGUNION (IMAGE (\bs2. birs_fresh_symbs bs bs2) sbs)) + (birs_freesymbs bs sbs = BIGUNION (IMAGE (\bs2. birs_freesymbs_SING bs bs2) sbs)) Proof -SIMP_TAC std_ss [birs_set_fresh_symbs_def, birs_fresh_symbs_def, BIGUNION_IMAGE_DIFF_EQ_thm] +SIMP_TAC std_ss [birs_freesymbs_def, birs_freesymbs_SING_def, BIGUNION_IMAGE_DIFF_EQ_thm] QED -Theorem birs_set_NO_fresh_symbs_thm: +Theorem birs_freesymbs_EMPTY_thm: !bs sbs. - (birs_set_NO_fresh_symbs bs sbs = - !bs2. bs2 IN sbs ==> (birs_NO_fresh_symbs bs bs2)) + (birs_freesymbs_EMPTY bs sbs = + !bs2. bs2 IN sbs ==> (birs_freesymbs_SING_EMPTY bs bs2)) Proof -SIMP_TAC std_ss [birs_set_NO_fresh_symbs_def, birs_set_fresh_symbs_thm, birs_NO_fresh_symbs_def] >> +SIMP_TAC std_ss [birs_freesymbs_EMPTY_def, birs_freesymbs_thm, birs_freesymbs_SING_EMPTY_def] >> SIMP_TAC (std_ss) [EXTENSION, IN_BIGUNION_IMAGE, NOT_IN_EMPTY] >> METIS_TAC [] QED @@ -539,16 +604,16 @@ QED Theorem birs_exec_stmt_jmp_NO_FRESH_SYMBS: !prog bsys l. - birs_set_NO_fresh_symbs bsys (birs_exec_stmt_jmp prog l bsys) + birs_freesymbs_EMPTY bsys (birs_exec_stmt_jmp prog l bsys) Proof SIMP_TAC std_ss [birs_exec_stmt_jmp_def] >> REPEAT STRIP_TAC >> CASE_TAC >> ( - SIMP_TAC std_ss [birs_set_NO_fresh_symbs_thm, FORALL_IN_INSERT, NOT_IN_EMPTY, FORALL_IN_IMAGE] >> + SIMP_TAC std_ss [birs_freesymbs_EMPTY_thm, FORALL_IN_INSERT, NOT_IN_EMPTY, FORALL_IN_IMAGE] >> REPEAT STRIP_TAC >> - MATCH_MP_TAC birs_NO_fresh_symbs_SUFFICIENT_thm >> + MATCH_MP_TAC birs_freesymbs_SING_EMPTY_SUFFICIENT_thm >> SIMP_TAC (std_ss++birs_state_ss) [birs_exec_stmt_jmp_to_label_def] >> TRY CASE_TAC >> ( SIMP_TAC (std_ss++birs_state_ss) [birs_state_set_typeerror_def] @@ -558,26 +623,26 @@ QED Theorem birs_exec_stmt_cjmp_NO_FRESH_SYMBS: !prog bsys e l1 l2. - birs_set_NO_fresh_symbs bsys (birs_exec_stmt_cjmp prog e l1 l2 bsys) + birs_freesymbs_EMPTY bsys (birs_exec_stmt_cjmp prog e l1 l2 bsys) Proof SIMP_TAC std_ss [birs_exec_stmtE_def, birs_exec_stmt_cjmp_def] >> REPEAT STRIP_TAC >> CASE_TAC >- ( - SIMP_TAC std_ss [birs_set_NO_fresh_symbs_thm, FORALL_IN_INSERT, NOT_IN_EMPTY] >> - TRY (MATCH_MP_TAC birs_NO_fresh_symbs_SUFFICIENT_thm) >> + SIMP_TAC std_ss [birs_freesymbs_EMPTY_thm, FORALL_IN_INSERT, NOT_IN_EMPTY] >> + TRY (MATCH_MP_TAC birs_freesymbs_SING_EMPTY_SUFFICIENT_thm) >> SIMP_TAC (std_ss++birs_state_ss) [birs_state_set_typeerror_def] ) >> Cases_on `x` >> Cases_on `r` >> ( - SIMP_TAC (std_ss++holBACore_ss) [birs_set_NO_fresh_symbs_thm, FORALL_IN_INSERT, NOT_IN_EMPTY, pairTheory.pair_CASE_def] >> - TRY (MATCH_MP_TAC birs_NO_fresh_symbs_SUFFICIENT_thm) >> + SIMP_TAC (std_ss++holBACore_ss) [birs_freesymbs_EMPTY_thm, FORALL_IN_INSERT, NOT_IN_EMPTY, pairTheory.pair_CASE_def] >> + TRY (MATCH_MP_TAC birs_freesymbs_SING_EMPTY_SUFFICIENT_thm) >> SIMP_TAC (std_ss++birs_state_ss) [birs_state_set_typeerror_def] ) >> Cases_on `b` >> ( - SIMP_TAC (std_ss++holBACore_ss) [birs_set_NO_fresh_symbs_thm, FORALL_IN_INSERT, NOT_IN_EMPTY, pairTheory.pair_CASE_def] >> - TRY (MATCH_MP_TAC birs_NO_fresh_symbs_SUFFICIENT_thm) >> + SIMP_TAC (std_ss++holBACore_ss) [birs_freesymbs_EMPTY_thm, FORALL_IN_INSERT, NOT_IN_EMPTY, pairTheory.pair_CASE_def] >> + TRY (MATCH_MP_TAC birs_freesymbs_SING_EMPTY_SUFFICIENT_thm) >> SIMP_TAC (std_ss++birs_state_ss) [birs_state_set_typeerror_def] ) >> @@ -593,15 +658,15 @@ SIMP_TAC std_ss [birs_exec_stmtE_def, birs_exec_stmt_cjmp_def] >> ) >> REPEAT STRIP_TAC >> ( - IMP_RES_TAC (REWRITE_RULE [birs_set_NO_fresh_symbs_thm] birs_exec_stmt_jmp_NO_FRESH_SYMBS) >> - METIS_TAC [birs_NO_fresh_symbs_SUFFICIENT3_thm, SUBSET_REFL] + IMP_RES_TAC (REWRITE_RULE [birs_freesymbs_EMPTY_thm] birs_exec_stmt_jmp_NO_FRESH_SYMBS) >> + METIS_TAC [birs_freesymbs_SING_EMPTY_SUFFICIENT3_thm, SUBSET_REFL] ) QED Theorem birs_exec_stmtE_NO_FRESH_SYMBS: !prog bsys estmt. - birs_set_NO_fresh_symbs bsys (birs_exec_stmtE prog estmt bsys) + birs_freesymbs_EMPTY bsys (birs_exec_stmtE prog estmt bsys) Proof REPEAT STRIP_TAC >> Cases_on `estmt` >- ( @@ -610,22 +675,22 @@ REPEAT STRIP_TAC >> SIMP_TAC std_ss [birs_exec_stmtE_def, birs_exec_stmt_cjmp_NO_FRESH_SYMBS] ) >> ( SIMP_TAC std_ss [birs_exec_stmtE_def, birs_exec_stmt_halt_def] >> - SIMP_TAC std_ss [birs_set_NO_fresh_symbs_thm, FORALL_IN_INSERT, NOT_IN_EMPTY, FORALL_IN_IMAGE] >> - MATCH_MP_TAC birs_NO_fresh_symbs_SUFFICIENT_thm >> + SIMP_TAC std_ss [birs_freesymbs_EMPTY_thm, FORALL_IN_INSERT, NOT_IN_EMPTY, FORALL_IN_IMAGE] >> + MATCH_MP_TAC birs_freesymbs_SING_EMPTY_SUFFICIENT_thm >> SIMP_TAC (std_ss++birs_state_ss) [birs_state_set_typeerror_def] ) QED Theorem birs_exec_stmt_assign_NO_FRESH_SYMBS: !bsys var be. - birs_set_NO_fresh_symbs bsys (birs_exec_stmt_assign var be bsys) + birs_freesymbs_EMPTY bsys (birs_exec_stmt_assign var be bsys) Proof SIMP_TAC std_ss [birs_exec_stmt_assign_def] >> REPEAT STRIP_TAC >> CASE_TAC >- ( - SIMP_TAC std_ss [birs_set_NO_fresh_symbs_thm, FORALL_IN_INSERT, NOT_IN_EMPTY] >> - TRY (MATCH_MP_TAC birs_NO_fresh_symbs_SUFFICIENT_thm) >> + SIMP_TAC std_ss [birs_freesymbs_EMPTY_thm, FORALL_IN_INSERT, NOT_IN_EMPTY] >> + TRY (MATCH_MP_TAC birs_freesymbs_SING_EMPTY_SUFFICIENT_thm) >> SIMP_TAC (std_ss++birs_state_ss) [birs_state_set_typeerror_def] ) >> @@ -634,40 +699,40 @@ SIMP_TAC std_ss [birs_exec_stmt_assign_def] >> CASE_TAC >- ( IMP_RES_TAC birs_eval_exp_IMP_symb_symbols_SUBSET_environ_thm >> - SIMP_TAC (std_ss++holBACore_ss) [birs_set_NO_fresh_symbs_thm, FORALL_IN_INSERT, NOT_IN_EMPTY] >> + SIMP_TAC (std_ss++holBACore_ss) [birs_freesymbs_EMPTY_thm, FORALL_IN_INSERT, NOT_IN_EMPTY] >> - SIMP_TAC std_ss [birs_NO_fresh_symbs_def, birs_fresh_symbs_def] >> + SIMP_TAC std_ss [birs_freesymbs_SING_EMPTY_def, birs_freesymbs_SING_def] >> METIS_TAC [SUBSET_DIFF_EMPTY] ) >> - SIMP_TAC std_ss [birs_set_NO_fresh_symbs_thm, FORALL_IN_INSERT, NOT_IN_EMPTY] >> - TRY (MATCH_MP_TAC birs_NO_fresh_symbs_SUFFICIENT_thm) >> + SIMP_TAC std_ss [birs_freesymbs_EMPTY_thm, FORALL_IN_INSERT, NOT_IN_EMPTY] >> + TRY (MATCH_MP_TAC birs_freesymbs_SING_EMPTY_SUFFICIENT_thm) >> SIMP_TAC (std_ss++birs_state_ss) [birs_state_set_typeerror_def] QED Theorem birs_exec_stmt_assert_assume_NO_FRESH_SYMBS: !bsys be. - birs_set_NO_fresh_symbs bsys (birs_exec_stmt_assert be bsys) /\ - birs_set_NO_fresh_symbs bsys (birs_exec_stmt_assume be bsys) + birs_freesymbs_EMPTY bsys (birs_exec_stmt_assert be bsys) /\ + birs_freesymbs_EMPTY bsys (birs_exec_stmt_assume be bsys) Proof SIMP_TAC std_ss [birs_exec_stmt_assert_def, birs_exec_stmt_assume_def] >> REPEAT STRIP_TAC >> ( CASE_TAC >- ( - SIMP_TAC std_ss [birs_set_NO_fresh_symbs_thm, FORALL_IN_INSERT, NOT_IN_EMPTY] >> - TRY (MATCH_MP_TAC birs_NO_fresh_symbs_SUFFICIENT_thm) >> + SIMP_TAC std_ss [birs_freesymbs_EMPTY_thm, FORALL_IN_INSERT, NOT_IN_EMPTY] >> + TRY (MATCH_MP_TAC birs_freesymbs_SING_EMPTY_SUFFICIENT_thm) >> SIMP_TAC (std_ss++birs_state_ss) [birs_state_set_typeerror_def] ) >> Cases_on `x` >> Cases_on `r` >> ( - SIMP_TAC (std_ss++holBACore_ss) [birs_set_NO_fresh_symbs_thm, FORALL_IN_INSERT, NOT_IN_EMPTY, pairTheory.pair_CASE_def] >> - TRY (MATCH_MP_TAC birs_NO_fresh_symbs_SUFFICIENT_thm) >> + SIMP_TAC (std_ss++holBACore_ss) [birs_freesymbs_EMPTY_thm, FORALL_IN_INSERT, NOT_IN_EMPTY, pairTheory.pair_CASE_def] >> + TRY (MATCH_MP_TAC birs_freesymbs_SING_EMPTY_SUFFICIENT_thm) >> SIMP_TAC (std_ss++birs_state_ss) [birs_state_set_typeerror_def] ) >> Cases_on `b` >> ( - SIMP_TAC (std_ss++holBACore_ss) [birs_set_NO_fresh_symbs_thm, FORALL_IN_INSERT, NOT_IN_EMPTY, pairTheory.pair_CASE_def] >> - TRY (MATCH_MP_TAC birs_NO_fresh_symbs_SUFFICIENT_thm) >> + SIMP_TAC (std_ss++holBACore_ss) [birs_freesymbs_EMPTY_thm, FORALL_IN_INSERT, NOT_IN_EMPTY, pairTheory.pair_CASE_def] >> + TRY (MATCH_MP_TAC birs_freesymbs_SING_EMPTY_SUFFICIENT_thm) >> SIMP_TAC (std_ss++birs_state_ss) [birs_state_set_typeerror_def] ) >> @@ -686,7 +751,7 @@ SIMP_TAC std_ss [birs_exec_stmt_assert_def, birs_exec_stmt_assume_def] >> ) >> REPEAT STRIP_TAC >> ( - ASM_SIMP_TAC std_ss [birs_NO_fresh_symbs_def, birs_fresh_symbs_def] >> + ASM_SIMP_TAC std_ss [birs_freesymbs_SING_EMPTY_def, birs_freesymbs_SING_def] >> METIS_TAC [DIFF_EQ_EMPTY] ) ) @@ -694,7 +759,7 @@ QED Theorem birs_exec_stmtB_NO_FRESH_SYMBS: !bsys stmt. - birs_set_NO_fresh_symbs bsys (birs_exec_stmtB stmt bsys) + birs_freesymbs_EMPTY bsys (birs_exec_stmtB stmt bsys) Proof REPEAT STRIP_TAC >> Cases_on `stmt` >- ( @@ -706,8 +771,8 @@ REPEAT STRIP_TAC >> ) >> ( SIMP_TAC std_ss [birs_exec_stmtB_def, birs_exec_stmt_observe_def, LET_DEF] >> CASE_TAC >- ( - SIMP_TAC std_ss [birs_set_NO_fresh_symbs_thm, FORALL_IN_INSERT, NOT_IN_EMPTY] >> - MATCH_MP_TAC birs_NO_fresh_symbs_SUFFICIENT_thm >> + SIMP_TAC std_ss [birs_freesymbs_EMPTY_thm, FORALL_IN_INSERT, NOT_IN_EMPTY] >> + MATCH_MP_TAC birs_freesymbs_SING_EMPTY_SUFFICIENT_thm >> SIMP_TAC (std_ss++birs_state_ss) [birs_state_set_typeerror_def] ) >> @@ -715,8 +780,8 @@ REPEAT STRIP_TAC >> CASE_TAC >> ( TRY CASE_TAC >> ( TRY CASE_TAC >> ( - SIMP_TAC std_ss [birs_set_NO_fresh_symbs_thm, FORALL_IN_INSERT, NOT_IN_EMPTY] >> - MATCH_MP_TAC birs_NO_fresh_symbs_SUFFICIENT_thm >> + SIMP_TAC std_ss [birs_freesymbs_EMPTY_thm, FORALL_IN_INSERT, NOT_IN_EMPTY] >> + MATCH_MP_TAC birs_freesymbs_SING_EMPTY_SUFFICIENT_thm >> SIMP_TAC (std_ss++birs_state_ss) [birs_state_set_typeerror_def] ) ) @@ -730,19 +795,19 @@ Theorem birs_exec_step_NO_FRESH_SYMBS[local]: (* this assumption is only needed because of the proof with the soundness of steps *) (bir_prog_has_no_halt prog) ==> *) - birs_set_NO_fresh_symbs bsys (birs_exec_step prog bsys) + birs_freesymbs_EMPTY bsys (birs_exec_step prog bsys) Proof SIMP_TAC std_ss [birs_exec_step_def] >> REPEAT STRIP_TAC >> Cases_on `birs_state_is_terminated bsys` >- ( - ASM_SIMP_TAC std_ss [birs_set_NO_fresh_symbs_thm, FORALL_IN_INSERT, NOT_IN_EMPTY] >> - METIS_TAC [birs_NO_fresh_symbs_SUFFICIENT_thm] + ASM_SIMP_TAC std_ss [birs_freesymbs_EMPTY_thm, FORALL_IN_INSERT, NOT_IN_EMPTY] >> + METIS_TAC [birs_freesymbs_SING_EMPTY_SUFFICIENT_thm] ) >> ASM_SIMP_TAC std_ss [] >> Cases_on `bir_get_current_statement prog bsys.bsst_pc` >- ( - ASM_SIMP_TAC std_ss [birs_set_NO_fresh_symbs_thm, FORALL_IN_INSERT, NOT_IN_EMPTY] >> - MATCH_MP_TAC birs_NO_fresh_symbs_SUFFICIENT_thm >> + ASM_SIMP_TAC std_ss [birs_freesymbs_EMPTY_thm, FORALL_IN_INSERT, NOT_IN_EMPTY] >> + MATCH_MP_TAC birs_freesymbs_SING_EMPTY_SUFFICIENT_thm >> SIMP_TAC (std_ss++birs_state_ss) [birs_state_set_failed_def] ) >> @@ -752,16 +817,16 @@ SIMP_TAC std_ss [birs_exec_step_def] >> ASM_SIMP_TAC std_ss [birs_exec_stmt_def, LET_DEF, birs_exec_stmtE_NO_FRESH_SYMBS] ) >> - SIMP_TAC std_ss [birs_set_NO_fresh_symbs_thm, FORALL_IN_IMAGE] >> + SIMP_TAC std_ss [birs_freesymbs_EMPTY_thm, FORALL_IN_IMAGE] >> REPEAT STRIP_TAC >> ASSUME_TAC (Q.SPECL [`bsys`, `b`] birs_exec_stmtB_NO_FRESH_SYMBS) >> - IMP_RES_TAC birs_set_NO_fresh_symbs_thm >> + IMP_RES_TAC birs_freesymbs_EMPTY_thm >> Cases_on `birs_state_is_terminated st'` >> ( ASM_SIMP_TAC std_ss [] ) >> - MATCH_MP_TAC birs_NO_fresh_symbs_SUFFICIENT2_thm >> + MATCH_MP_TAC birs_freesymbs_SING_EMPTY_SUFFICIENT2_thm >> SIMP_TAC (std_ss++birs_state_ss) [] >> METIS_TAC [] QED @@ -786,16 +851,16 @@ Theorem birs_rule_STEP_SEQ_gen_thm: IMAGE birs_symb_to_symbst (birs_exec_step prog bsys2) )) Proof -REPEAT STRIP_TAC >> + REPEAT STRIP_TAC >> ASSUME_TAC (Q.SPECL [`prog`, `bsys2`] birs_rule_STEP_gen2_thm) >> REV_FULL_SIMP_TAC std_ss [] >> ASSUME_TAC (Q.SPEC `prog` bir_symb_soundTheory.birs_symb_symbols_f_sound_thm) >> - IMP_RES_TAC symb_rulesTheory.symb_rule_SEQ_thm >> + IMP_RES_TAC (REWRITE_RULE [symb_freesymbs_def] symb_rulesTheory.symb_rule_SEQ_thm) >> POP_ASSUM (ASSUME_TAC o Q.SPECL [`birs_symb_to_symbst bsys2`, `birs_symb_to_symbst bsys1`, `IMAGE birs_symb_to_symbst (birs_exec_step prog bsys2)`]) >> - ASSUME_TAC (REWRITE_RULE [birs_set_NO_fresh_symbs_def, birs_set_fresh_symbs_def] birs_exec_step_NO_FRESH_SYMBS) >> + ASSUME_TAC (REWRITE_RULE [birs_freesymbs_EMPTY_def, birs_freesymbs_def] birs_exec_step_NO_FRESH_SYMBS) >> FULL_SIMP_TAC std_ss [INTER_EMPTY, birs_auxTheory.birs_symb_symbols_set_EQ_thm, bir_symb_sound_coreTheory.birs_symb_symbols_EQ_thm] >> @@ -829,6 +894,11 @@ QED *) + +(* ******************************************************* *) +(* jump resolution - birs_symbval_concretizations *) +(* ******************************************************* *) + local open bir_bool_expTheory in diff --git a/src/theory/tools/symbexec/symb_recordScript.sml b/src/theory/tools/symbexec/symb_recordScript.sml index 47eb3186c..c091bd5f7 100644 --- a/src/theory/tools/symbexec/symb_recordScript.sml +++ b/src/theory/tools/symbexec/symb_recordScript.sml @@ -329,6 +329,18 @@ REPEAT STRIP_TAC >> METIS_TAC [SUBSET_UNION, SUBSET_TRANS] QED + +(* +NOTATION: FREE SYMBOLS +======================================================= +*) + +Definition symb_freesymbs_def: + symb_freesymbs sr (sys, L, Pi) = + (symb_symbols_set sr Pi) DIFF (symb_symbols sr sys) +End + + (* NOTATION: WELL-TYPED INTERPRETATION ======================================================= diff --git a/src/theory/tools/symbexec/symb_rulesScript.sml b/src/theory/tools/symbexec/symb_rulesScript.sml index d80d85703..92940d6fb 100644 --- a/src/theory/tools/symbexec/symb_rulesScript.sml +++ b/src/theory/tools/symbexec/symb_rulesScript.sml @@ -153,14 +153,14 @@ Theorem symb_rule_SEQ_thm: (* can't reintroduce symbols in fragment B that have been lost in A *) (((symb_symbols sr sys_A) (* DIFF (symb_symbols sr sys_B) *)) - INTER ((symb_symbols_set sr Pi_B) DIFF (symb_symbols sr sys_B)) + INTER (symb_freesymbs sr (sys_B, L_B, Pi_B)) = EMPTY) ==> (symb_hl_step_in_L_sound sr (sys_A, L_A, Pi_A)) ==> (symb_hl_step_in_L_sound sr (sys_B, L_B, Pi_B)) ==> (symb_hl_step_in_L_sound sr (sys_A, L_A UNION L_B, (Pi_A DIFF {sys_B}) UNION Pi_B)) Proof -REWRITE_TAC [symb_hl_step_in_L_sound_def, conc_step_n_in_L_def] >> + REWRITE_TAC [symb_freesymbs_def, symb_hl_step_in_L_sound_def, conc_step_n_in_L_def] >> REPEAT STRIP_TAC >> PAT_X_ASSUM ``!s H. symb_minimal_interpretation sr sys_A H ==> A`` (ASSUME_TAC o (Q.SPECL [`s`, `H`])) >> @@ -474,15 +474,15 @@ Theorem symb_rule_CONS_thm: (symb_ARB_val_sound sr) ==> (* can't reintroduce symbols in fragment that have been lost in the path condition widening *) - (((symb_symbols sr sys1) (* DIFF (symb_symbols sr sys') *)) - INTER ((symb_symbols_set sr Pi) DIFF (symb_symbols sr sys1')) = EMPTY) ==> + ((symb_symbols sr sys1) INTER (symb_freesymbs sr (sys1', L, Pi)) = EMPTY) ==> (symb_hl_step_in_L_sound sr (sys1', L, Pi)) ==> (symb_pcondwiden_sys sr sys1 sys1') ==> (symb_pcondwiden_sys sr sys2 sys2') ==> (symb_hl_step_in_L_sound sr (sys1, L, (Pi DIFF {sys2}) UNION {sys2'})) Proof -METIS_TAC [symb_rule_CONS_S_thm, symb_rule_CONS_E_thm] + REWRITE_TAC [symb_freesymbs_def] >> + METIS_TAC [symb_rule_CONS_S_thm, symb_rule_CONS_E_thm] QED @@ -1089,12 +1089,12 @@ Theorem symb_rule_INST_thm: (sr.sr_typeof_exp symb_inst = SOME (sr.sr_typeof_symb symb)) ==> (* exclude the freshly introduced symbols between sys and Pi in the expression symb_inst *) - ((sr.sr_symbols_f symb_inst) INTER ((symb_symbols_set sr Pi) DIFF (symb_symbols sr sys)) = EMPTY) ==> + ((sr.sr_symbols_f symb_inst) INTER (symb_freesymbs sr (sys, L, Pi)) = EMPTY) ==> (symb_hl_step_in_L_sound sr (sys, L, Pi)) ==> (symb_hl_step_in_L_sound sr (symb_subst sr (symb, symb_inst) sys, L, symb_subst_set sr (symb, symb_inst) Pi)) Proof -REWRITE_TAC [symb_hl_step_in_L_sound_def, conc_step_n_in_L_def] >> + REWRITE_TAC [symb_freesymbs_def, symb_hl_step_in_L_sound_def, conc_step_n_in_L_def] >> REPEAT STRIP_TAC >> Q.ABBREV_TAC `sys_s = symb_subst sr (symb,symb_inst) sys` >> @@ -1688,7 +1688,7 @@ REPEAT STRIP_TAC >> METIS_TAC [INTER_COMM, DIFF_INTER, EMPTY_DIFF] ) >> - METIS_TAC [symb_rule_INST_thm] + METIS_TAC [symb_rule_INST_thm, symb_freesymbs_def] ) >> (* do we have theorem that substition has no effect if substituted symbol is not present? then this part of the proof will be relatively simple and just needs a bit argument for the last step *) diff --git a/src/tools/symbexec/bir_vars_ofLib.sml b/src/tools/symbexec/bir_vars_ofLib.sml index c026580b8..2676b8e2a 100644 --- a/src/tools/symbexec/bir_vars_ofLib.sml +++ b/src/tools/symbexec/bir_vars_ofLib.sml @@ -7,6 +7,7 @@ open HolKernel Parse boolLib bossLib; open bir_typing_expTheory; open bir_typing_expSyntax; +open birsSyntax; open HolBACoreSimps; @@ -20,6 +21,9 @@ val birs_state_ss = rewrites (type_rws ``:birs_state_t``); in (* local *) +(* ---------------------------------------------------------------------------------- *) +(* variables of bir expressions *) +(* ---------------------------------------------------------------------------------- *) (* TODO: can probably speed this up by extending the caching into the evaluation of variables subexpressions, like in the function type_of_bir_exp_DIRECT_CONV, but only relevant for handling of bigger expressions *) fun bir_vars_of_exp_DIRECT_CONV tm = @@ -34,12 +38,11 @@ in (* local *) val bir_vars_of_exp_CONV = birs_auxLib.GEN_match_conv (is_bir_vars_of_exp) bir_vars_of_exp_DIRECT_CONV; -(* ------------------------------------------------------------ *) +(* ---------------------------------------------------------------------------------- *) +(* symbols of set of symbolic states *) +(* ---------------------------------------------------------------------------------- *) -(* ------------------------------------------------------------------------ *) (* COPIED FROM TRANSFER-TEST (and modified) *) -(* ------------------------------------------------------------------------ *) - (* val tm = `` birs_symb_symbols @@ -444,35 +447,39 @@ fun birs_exps_of_senv_CONV tm = ((*TRY_CONV*) birs_exps_of_senv_COMP_CONV) ) tm; -fun is_birs_exps_of_senv tm = is_comb tm andalso - (is_const o fst o dest_comb) tm andalso - ((fn tm2 => tm2 = "birs_exps_of_senv") o fst o dest_const o fst o dest_comb) tm; +fun birs_symb_symbols_DIRECT_CONV tm = + if not (is_birs_symb_symbols tm) then + raise ERR "birs_symb_symbols_DIRECT_CONV" "cannot handle term" + else + ( + SIMP_CONV (std_ss++birs_state_ss) [birs_symb_symbols_thm] THENC + debug_conv2 THENC + birs_auxLib.GEN_match_conv is_birs_exps_of_senv birs_exps_of_senv_CONV THENC + debug_conv2 THENC + REWRITE_CONV [pred_setTheory.IMAGE_INSERT, pred_setTheory.IMAGE_EMPTY] THENC + bir_vars_of_exp_CONV THENC + + debug_conv2 THENC + RATOR_CONV (RAND_CONV (REWRITE_CONV [pred_setTheory.BIGUNION_INSERT, pred_setTheory.BIGUNION_EMPTY])) THENC + + REWRITE_CONV [Once pred_setTheory.UNION_COMM] THENC + REWRITE_CONV [pred_setTheory.UNION_ASSOC, pred_setTheory.INSERT_UNION_EQ, pred_setTheory.UNION_EMPTY] + ) tm; +val birs_symb_symbols_DIRECT_CONV = aux_moveawayLib.wrap_cache_result Term.compare birs_symb_symbols_DIRECT_CONV; + fun birs_symb_symbols_CONV tm = -( - SIMP_CONV (std_ss++birs_state_ss) [birs_symb_symbols_thm] THENC - debug_conv2 THENC - birs_auxLib.GEN_match_conv is_birs_exps_of_senv birs_exps_of_senv_CONV THENC - debug_conv2 THENC - REWRITE_CONV [pred_setTheory.IMAGE_INSERT, pred_setTheory.IMAGE_EMPTY] THENC - bir_vars_of_exp_CONV THENC - - debug_conv2 THENC - RATOR_CONV (RAND_CONV (REWRITE_CONV [pred_setTheory.BIGUNION_INSERT, pred_setTheory.BIGUNION_EMPTY])) THENC - - REWRITE_CONV [Once pred_setTheory.UNION_COMM] THENC - REWRITE_CONV [pred_setTheory.UNION_ASSOC, pred_setTheory.INSERT_UNION_EQ, pred_setTheory.UNION_EMPTY] -) tm; + birs_auxLib.GEN_match_conv is_birs_symb_symbols birs_symb_symbols_DIRECT_CONV tm; -fun is_birs_symb_symbols tm = is_comb tm andalso - (is_const o fst o dest_comb) tm andalso - ((fn tm2 => tm2 = "birs_symb_symbols") o fst o dest_const o fst o dest_comb) tm; -fun birs_symb_symbols_MATCH_CONV tm = - birs_auxLib.GEN_match_conv is_birs_symb_symbols birs_symb_symbols_CONV tm; + +(* ---------------------------------------------------------------------------------- *) +(* symbols of set of symbolic bir states *) +(* ---------------------------------------------------------------------------------- *) (* ---------------------------------------------------------------------------------- *) -(* set of free vars *) +(* free symbols of execution structure (sys, L, Pi) *) (* ---------------------------------------------------------------------------------- *) +(* TODO: this should go to auxTheory *) val simplerewrite_thm = prove(`` !s t g. g INTER (s DIFF t) = @@ -484,7 +491,7 @@ METIS_TAC [pred_setTheory.INTER_COMM, pred_setTheory.DIFF_INTER] fun freevarset_CONV tm = ( - REWRITE_CONV [Once (simplerewrite_thm)] THENC + (*REWRITE_CONV [Once (simplerewrite_thm)] THENC*) (* TODO: was this a good thing for composition when there are many unused/unchanged symbols around? *) (RAND_CONV ( aux_setLib.DIFF_CONV EVAL diff --git a/src/tools/symbexec/birsSyntax.sml b/src/tools/symbexec/birsSyntax.sml index 733eddb91..611884232 100644 --- a/src/tools/symbexec/birsSyntax.sml +++ b/src/tools/symbexec/birsSyntax.sml @@ -41,8 +41,10 @@ local fun syntax_fns n d m = HolKernel.syntax_fns {n = n, dest = d, make = m} "birs_aux" val syntax_fns1 = syntax_fns 1 HolKernel.dest_monop HolKernel.mk_monop; val syntax_fns1_env = syntax_fns 2 HolKernel.dest_monop HolKernel.mk_monop; + val syntax_fns1_set = syntax_fns 2 HolKernel.dest_monop HolKernel.mk_monop; in - val (birs_gen_env_tm, mk_birs_gen_env, dest_birs_gen_env, is_birs_gen_env) = syntax_fns1_env "birs_gen_env"; + val (birs_gen_env_tm, mk_birs_gen_env, dest_birs_gen_env, is_birs_gen_env) = syntax_fns1_env "birs_gen_env"; + val (birs_exps_of_senv_tm, mk_birs_exps_of_senv, dest_birs_exps_of_senv, is_birs_exps_of_senv) = syntax_fns1_set "birs_exps_of_senv"; end; local @@ -97,6 +99,14 @@ in (* val (_tm, mk_, dest_, is_) = syntax_fns2_set "";*) end +local + open bir_symb_sound_coreTheory; + fun syntax_fns n d m = HolKernel.syntax_fns {n = n, dest = d, make = m} "bir_symb_sound_core"; + val syntax_fns1_set = syntax_fns 2 HolKernel.dest_monop HolKernel.mk_monop; +in + val (birs_symb_symbols_tm, mk_birs_symb_symbols, dest_birs_symb_symbols, is_birs_symb_symbols) = syntax_fns1_set "birs_symb_symbols"; +end + local open bir_symb_simpTheory; fun syntax_fns n d m = HolKernel.syntax_fns {n = n, dest = d, make = m} "bir_symb_simp"; diff --git a/src/tools/symbexec/birs_composeLib.sml b/src/tools/symbexec/birs_composeLib.sml index 23a7c1c1e..642abd9ff 100644 --- a/src/tools/symbexec/birs_composeLib.sml +++ b/src/tools/symbexec/birs_composeLib.sml @@ -27,35 +27,21 @@ open pred_setTheory; in -(* TODO: *) -val betterTheorem = prove(`` -!sr. -!sys_A L_A Pi_A sys_B L_B Pi_B. - (symb_symbols_f_sound sr) ==> - - (symb_hl_step_in_L_sound sr (sys_A, L_A, Pi_A)) ==> - (symb_hl_step_in_L_sound sr (sys_B, L_B, Pi_B)) ==> - - (* can't reintroduce symbols in fragment B that have been lost in A *) - (((symb_symbols sr sys_A) (* DIFF (symb_symbols sr sys_B) *)) - INTER ((symb_symbols_set sr Pi_B) DIFF (symb_symbols sr sys_B)) - = EMPTY) ==> - - (symb_hl_step_in_L_sound sr (sys_A, L_A UNION L_B, (Pi_A DIFF {sys_B}) UNION Pi_B)) -``, - METIS_TAC[symb_rulesTheory.symb_rule_SEQ_thm] -); - (* first prepare the SEQ rule for prog *) fun birs_rule_SEQ_prog_fun bprog_tm = + (ISPEC (bprog_tm) birs_rulesTheory.birs_rule_SEQ_gen_thm, bprog_tm); + (* let val prog_type = (hd o snd o dest_type o type_of) bprog_tm; val symbols_f_sound_thm = INST_TYPE [Type.alpha |-> prog_type] bir_symb_soundTheory.birs_symb_symbols_f_sound_thm; val birs_symb_symbols_f_sound_prog_thm = (SPEC (bprog_tm) symbols_f_sound_thm); in - (MATCH_MP betterTheorem birs_symb_symbols_f_sound_prog_thm) + print_thm (MATCH_MP birs_rule_SEQ_gen_thm birs_symb_symbols_f_sound_prog_thm); + raise ERR "" ""; + (MATCH_MP birs_rule_SEQ_gen_thm birs_symb_symbols_f_sound_prog_thm) end; + *) (* symbol freedom helper function *) fun birs_rule_SEQ_free_symbols_fun freesymbols_tm freesymbols_B_thm_o = @@ -70,7 +56,7 @@ fun birs_rule_SEQ_free_symbols_fun freesymbols_tm freesymbols_B_thm_o = (if !speedcheat then cheat else ALL_TAC) >> (case freesymbols_B_thm_o of NONE => ALL_TAC - | SOME freesymbols_B_thm => REWRITE_TAC [freesymbols_B_thm, pred_setTheory.INTER_EMPTY]) >> + | SOME freesymbols_B_thm => (print_thm freesymbols_B_thm; raise ERR "" ""; REWRITE_TAC [freesymbols_B_thm, pred_setTheory.INTER_EMPTY])) >> FULL_SIMP_TAC (std_ss) [bir_symb_sound_coreTheory.birs_symb_symbols_EQ_thm, birs_symb_symbols_set_EQ_thm] >> @@ -79,7 +65,7 @@ fun birs_rule_SEQ_free_symbols_fun freesymbols_tm freesymbols_B_thm_o = - CONV_TAC (bir_vars_ofLib.birs_symb_symbols_MATCH_CONV) >> + CONV_TAC (bir_vars_ofLib.birs_symb_symbols_CONV) >> (* CONV_TAC ( SIMP_CONV (std_ss++birs_state_ss) [birs_symb_symbols_thm] THENC @@ -273,11 +259,9 @@ val step_A_thm = single_step_A_thm; val step_B_thm = single_step_B_thm; val freesymbols_B_thm_o = SOME (prove(T, cheat)); *) -fun birs_rule_SEQ_fun birs_rule_SEQ_thm step_A_thm step_B_thm freesymbols_B_thm_o = +fun birs_rule_SEQ_fun (birs_rule_SEQ_thm, bprog_tm) step_A_thm step_B_thm freesymbols_B_thm_o = let - val get_SEQ_thm_concl_symb_struct_fun = snd o strip_imp o snd o strip_binder (SOME boolSyntax.universal) o concl; val symb_struct_get_bprog_fun = snd o dest_comb o hd o snd o strip_comb; - val bprog_tm = (symb_struct_get_bprog_fun o get_SEQ_thm_concl_symb_struct_fun) birs_rule_SEQ_thm; val bprog_A_tm = (symb_struct_get_bprog_fun o concl) step_A_thm; val bprog_B_tm = (symb_struct_get_bprog_fun o concl) step_B_thm; val _ = if identical bprog_tm bprog_A_tm andalso identical bprog_tm bprog_B_tm then () else @@ -290,8 +274,9 @@ fun birs_rule_SEQ_fun birs_rule_SEQ_thm step_A_thm step_B_thm freesymbols_B_thm_ val prep_thm = HO_MATCH_MP (HO_MATCH_MP birs_rule_SEQ_thm step_A_thm) step_B_thm; - val freesymbols_tm = (hd o fst o strip_imp o concl) prep_thm; + (* has to solve this implication ((birs_symb_symbols bsys_A) INTER (birs_freesymbs bsys_B bPi_B) = EMPTY) *) + val freesymbols_tm = (hd o fst o strip_imp o concl) prep_thm; val freesymbols_thm = birs_rule_SEQ_free_symbols_fun freesymbols_tm freesymbols_B_thm_o; val _ = print "finished to proof free symbols altogether\n"; (* @@ -317,10 +302,10 @@ val tm = (snd o dest_comb o snd o dest_comb o snd o dest_comb o concl) bprog_com val conv = aux_setLib.birs_state_DIFF_UNION_CONV; *) fun Pi_CONV conv tm = - RAND_CONV (RAND_CONV (conv)) tm; + RAND_CONV (RAND_CONV (conv handle e => (print "\n\nPi_CONV failed\n\n"; raise e))) tm; fun L_CONV conv tm = - RAND_CONV (LAND_CONV (conv)) tm; + RAND_CONV (LAND_CONV (conv handle e => (print "\n\nL_CONV failed\n\n"; raise e))) tm; val bprog_Pi_fixed_thm = CONV_RULE (RAND_CONV (Pi_CONV aux_setLib.birs_state_DIFF_UNION_CONV)) bprog_composed_thm; diff --git a/src/tools/symbexec/examples/analysis/motorfunc_transfScript.sml b/src/tools/symbexec/examples/analysis/motorfunc_transfScript.sml index dea72ba2b..64b82f87c 100644 --- a/src/tools/symbexec/examples/analysis/motorfunc_transfScript.sml +++ b/src/tools/symbexec/examples/analysis/motorfunc_transfScript.sml @@ -322,7 +322,7 @@ REWRITE_TAC [bir_Pi_overapprox_Q_thm] >> POP_ASSUM (ASSUME_TAC o CONV_RULE ( REWRITE_CONV [bsysprecond_thm, birenvtyl_EVAL_thm] THENC computeLib.RESTR_EVAL_CONV [``birs_symb_symbols``] THENC - aux_setLib.birs_symb_symbols_MATCH_CONV) + bir_vars_ofLib.birs_symb_symbols_CONV) ) >> FULL_SIMP_TAC (std_ss) [symb_interpr_for_symbs_def, INSERT_SUBSET] @@ -336,7 +336,7 @@ REWRITE_TAC [bir_Pi_overapprox_Q_thm] >> POP_ASSUM (ASSUME_TAC o CONV_RULE ( REWRITE_CONV [bsysprecond_thm, birenvtyl_EVAL_thm] THENC computeLib.RESTR_EVAL_CONV [``birs_symb_symbols``] THENC - aux_setLib.birs_symb_symbols_MATCH_CONV) + bir_vars_ofLib.birs_symb_symbols_CONV) ) >> FULL_SIMP_TAC (std_ss) [symb_interpr_for_symbs_def, INSERT_SUBSET] From d07fb89af092b5ad7d5c8236bffdcabd911453a3 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 30 Sep 2024 19:36:09 +0200 Subject: [PATCH 49/95] Introduce sound structure predicate for BIR directly --- .../tools/symbexec/birs_rulesScript.sml | 226 +++++++++++------- src/tools/symbexec/aux_setLib.sml | 78 +----- src/tools/symbexec/birsSyntax.sml | 31 ++- src/tools/symbexec/birs_composeLib.sml | 184 +------------- src/tools/symbexec/birs_execLib.sml | 1 + 5 files changed, 176 insertions(+), 344 deletions(-) diff --git a/src/theory/tools/symbexec/birs_rulesScript.sml b/src/theory/tools/symbexec/birs_rulesScript.sml index 52a508534..9a23af8f4 100644 --- a/src/theory/tools/symbexec/birs_rulesScript.sml +++ b/src/theory/tools/symbexec/birs_rulesScript.sml @@ -55,6 +55,48 @@ REWRITE_TAC [symb_rulesTheory.symb_pcondwiden_def, birs_pcondwiden_def] >> SIMP_TAC (std_ss++symb_TYPES_ss) [bir_symb_rec_sbir_def, symb_interpr_symbpcond_def, bir_bool_expTheory.bir_val_TF_dist] QED +(* ******************************************************* *) +(* sound execution structure for SBIR *) +(* ******************************************************* *) +Definition birs_symb_exec_def: + birs_symb_exec p (bs, L, bP) = + (symb_hl_step_in_L_sound (bir_symb_rec_sbir p) (birs_symb_to_symbst bs, L, IMAGE birs_symb_to_symbst bP)) +End + + +(* ******************************************************* *) +(* FREE SYMBS *) +(* ******************************************************* *) +Definition birs_symb_symbols_set_def: + birs_symb_symbols_set Pi = + BIGUNION (IMAGE birs_symb_symbols Pi) +End + +Theorem birs_symb_symbols_set_EQ_thm2: + !prog Pi. symb_symbols_set (bir_symb_rec_sbir prog) (IMAGE birs_symb_to_symbst Pi) = birs_symb_symbols_set Pi +Proof + REWRITE_TAC [birs_auxTheory.symb_symbols_set_ALT_thm, birs_symb_symbols_set_def] >> + REWRITE_TAC [pred_setTheory.IMAGE_IMAGE, combinTheory.o_DEF, birs_symb_symbols_EQ_thm] >> + METIS_TAC [] + (* birs_symb_symbols_set_EQ_thm *) +QED + +Definition birs_freesymbs_def: + birs_freesymbs bs sbs = + ((BIGUNION (IMAGE birs_symb_symbols sbs)) DIFF (birs_symb_symbols bs)) +End + +Theorem birs_freesymbs_EQ_thm: + !prog L bs sbs. + birs_freesymbs bs sbs = symb_freesymbs (bir_symb_rec_sbir prog) (birs_symb_to_symbst bs, L, IMAGE birs_symb_to_symbst sbs) +Proof + REWRITE_TAC [birs_freesymbs_def, symb_freesymbs_def] >> + REWRITE_TAC [birs_auxTheory.symb_symbols_set_ALT_thm] >> + REWRITE_TAC [pred_setTheory.IMAGE_IMAGE, combinTheory.o_DEF, birs_symb_symbols_EQ_thm] >> + METIS_TAC [] +QED + + (* ******************************************************* *) (* ASSERT statement justification *) @@ -106,9 +148,9 @@ QED Theorem assert_spec_thm: - !bprog sys L lbl1 env1 status pre cond lbl2 env2. - (symb_hl_step_in_L_sound (bir_symb_rec_sbir bprog) - (sys, L, IMAGE birs_symb_to_symbst { + !bprog bs L lbl1 env1 status pre cond lbl2 env2. + (birs_symb_exec bprog + (bs, L, { <|bsst_pc := lbl1; bsst_environ := env1; bsst_status := status; @@ -122,14 +164,15 @@ Theorem assert_spec_thm: status <> BST_AssertionViolated) ==> (birs_pcondinf (BExp_BinExp BIExp_And pre (BExp_UnaryExp BIExp_Not cond))) ==> - (symb_hl_step_in_L_sound (bir_symb_rec_sbir bprog) - (sys, L, IMAGE birs_symb_to_symbst { + (birs_symb_exec bprog + (bs, L, { <|bsst_pc := lbl1; bsst_environ := env1; bsst_status := status; bsst_pcond := pre|>})) Proof -REPEAT STRIP_TAC >> ( + REWRITE_TAC [birs_symb_exec_def] >> + REPEAT STRIP_TAC >> ( IMP_RES_TAC symb_rulesTheory.symb_rule_INF_thm >> PAT_X_ASSUM ``!x. A`` (ASSUME_TAC o SPEC ``birs_symb_to_symbst <|bsst_pc := lbl2; bsst_environ := env2; bsst_status := BST_AssertionViolated; @@ -146,6 +189,7 @@ REPEAT STRIP_TAC >> ( FULL_SIMP_TAC (std_ss++symb_TYPES_ss) [symb_symbst_pcond_def, DIFF_INSERT, DIFF_EMPTY, DELETE_INSERT, EMPTY_DELETE] >> REV_FULL_SIMP_TAC (std_ss) [] >> + Q.ABBREV_TAC `sys = SymbSymbSt bs.bsst_pc bs.bsst_environ bs.bsst_pcond bs.bsst_status` >> Q.ABBREV_TAC `sys2 = SymbSymbSt lbl1 env1 (BExp_BinExp BIExp_And pre cond) status` >> Q.ABBREV_TAC `sys2' = SymbSymbSt lbl1 env1 pre status` >> @@ -171,9 +215,9 @@ QED Theorem branch_prune1_spec_thm: - !bprog sys L lbl1 env1 status1 pre cond lbl2 env2 status2. - (symb_hl_step_in_L_sound (bir_symb_rec_sbir bprog) - (sys, L, IMAGE birs_symb_to_symbst { + !bprog bs L lbl1 env1 status1 pre cond lbl2 env2 status2. + (birs_symb_exec bprog + (bs, L, { <|bsst_pc := lbl1; bsst_environ := env1; bsst_status := status1; @@ -186,14 +230,15 @@ Theorem branch_prune1_spec_thm: (lbl1 <> lbl2 \/ status1 <> status2) ==> (birs_pcondinf (BExp_BinExp BIExp_And pre cond)) ==> - (symb_hl_step_in_L_sound (bir_symb_rec_sbir bprog) - (sys, L, IMAGE birs_symb_to_symbst { + (birs_symb_exec bprog + (bs, L, { <|bsst_pc := lbl2; bsst_environ := env2; bsst_status := status2; bsst_pcond := BExp_BinExp BIExp_And pre (BExp_UnaryExp BIExp_Not cond)|>})) Proof + REWRITE_TAC [birs_symb_exec_def] >> REPEAT STRIP_TAC >> ( IMP_RES_TAC symb_rulesTheory.symb_rule_INF_thm >> PAT_X_ASSUM ``!x. A`` (ASSUME_TAC o SPEC ``birs_symb_to_symbst <|bsst_pc := lbl1; @@ -215,9 +260,9 @@ QED Theorem branch_prune2_spec_thm: - !bprog sys L lbl1 env1 status1 pre cond lbl2 env2 status2. - (symb_hl_step_in_L_sound (bir_symb_rec_sbir bprog) - (sys, L, IMAGE birs_symb_to_symbst { + !bprog bs L lbl1 env1 status1 pre cond lbl2 env2 status2. + (birs_symb_exec bprog + (bs, L, { <|bsst_pc := lbl1; bsst_environ := env1; bsst_status := status1; @@ -231,14 +276,15 @@ Theorem branch_prune2_spec_thm: status1 <> status2) ==> (birs_pcondinf (BExp_BinExp BIExp_And pre (BExp_UnaryExp BIExp_Not cond))) ==> - (symb_hl_step_in_L_sound (bir_symb_rec_sbir bprog) - (sys, L, IMAGE birs_symb_to_symbst { + (birs_symb_exec bprog + (bs, L, { <|bsst_pc := lbl1; bsst_environ := env1; bsst_status := status1; bsst_pcond := BExp_BinExp BIExp_And pre cond|>})) Proof - REPEAT STRIP_TAC >> ( + REWRITE_TAC [birs_symb_exec_def] >> + REPEAT STRIP_TAC >> ( IMP_RES_TAC symb_rulesTheory.symb_rule_INF_thm >> PAT_X_ASSUM ``!x. A`` (ASSUME_TAC o SPEC ``birs_symb_to_symbst <|bsst_pc := lbl2; bsst_environ := env2; @@ -285,24 +331,25 @@ REPEAT STRIP_TAC >> QED Theorem birs_rule_SUBST_spec_thm: - !prog sys L sys2 sys2' lbl envl status pcond vn symbexp symbexp'. - (sys2 = + !prog bs L bs2 bs2' lbl envl status pcond vn symbexp symbexp'. + (bs2 = <|bsst_pc := lbl; bsst_environ := birs_gen_env ((vn, symbexp)::envl); bsst_status := status; bsst_pcond := pcond|>) ==> - (sys2' = + (bs2' = <|bsst_pc := lbl; bsst_environ := birs_gen_env ((vn, symbexp')::envl); bsst_status := status; bsst_pcond := pcond|>) ==> - symb_hl_step_in_L_sound (bir_symb_rec_sbir prog) (sys,L,IMAGE birs_symb_to_symbst {sys2}) ==> + birs_symb_exec prog (bs, L, {bs2}) ==> birs_simplification pcond symbexp symbexp' ==> - symb_hl_step_in_L_sound (bir_symb_rec_sbir prog) (sys,L,IMAGE birs_symb_to_symbst {sys2'}) + birs_symb_exec prog (bs, L, {bs2'}) Proof -REPEAT STRIP_TAC >> + REWRITE_TAC [birs_symb_exec_def] >> + REPEAT STRIP_TAC >> ASSUME_TAC ( - (Q.SPECL [`sys`, `L`, `birs_symb_to_symbst sys2`, `vn`, `symbexp`, `symbexp'`] o + (Q.SPECL [`birs_symb_to_symbst bs`, `L`, `birs_symb_to_symbst bs2`, `vn`, `symbexp`, `symbexp'`] o SIMP_RULE std_ss [bir_symb_soundTheory.birs_symb_ARB_val_sound_thm] o MATCH_MP symb_rule_SUBST_SING_thm o Q.SPEC `prog`) @@ -344,13 +391,13 @@ Theorem birs_rule_STEP_gen2_thm: !prog bsys. (bir_prog_has_no_halt prog) ==> - (symb_hl_step_in_L_sound (bir_symb_rec_sbir prog) - (birs_symb_to_symbst bsys, + (birs_symb_exec prog + (bsys, {bsys.bsst_pc}, - IMAGE birs_symb_to_symbst - (birs_exec_step prog bsys))) + (birs_exec_step prog bsys))) Proof -REPEAT STRIP_TAC >> + REWRITE_TAC [birs_symb_exec_def] >> + REPEAT STRIP_TAC >> IMP_RES_TAC birs_rule_STEP_gen1_thm >> POP_ASSUM (ASSUME_TAC o Q.SPEC `birs_symb_to_symbst bsys`) >> @@ -358,43 +405,6 @@ REPEAT STRIP_TAC >> QED -(* ******************************************************* *) -(* FREE SYMBS *) -(* ******************************************************* *) -Definition birs_symb_symbols_set_def: - birs_symb_symbols_set Pi = - BIGUNION (IMAGE birs_symb_symbols Pi) -End - -Theorem birs_symb_symbols_set_EQ_thm: - !prog Pi. symb_symbols_set (bir_symb_rec_sbir prog) (IMAGE birs_symb_to_symbst Pi) = birs_symb_symbols_set Pi -Proof - REWRITE_TAC [birs_auxTheory.symb_symbols_set_ALT_thm, birs_symb_symbols_set_def] >> - REWRITE_TAC [pred_setTheory.IMAGE_IMAGE, combinTheory.o_DEF, birs_symb_symbols_EQ_thm] >> - METIS_TAC [] -QED - -Definition birs_freesymbs_def: - birs_freesymbs bs sbs = - ((BIGUNION (IMAGE birs_symb_symbols sbs)) DIFF (birs_symb_symbols bs)) -End - -Theorem birs_freesymbs_EQ_thm: - !prog L bs sbs. - birs_freesymbs bs sbs = symb_freesymbs (bir_symb_rec_sbir prog) (birs_symb_to_symbst bs, L, IMAGE birs_symb_to_symbst sbs) -Proof - REWRITE_TAC [birs_freesymbs_def, symb_freesymbs_def] >> - REWRITE_TAC [birs_auxTheory.symb_symbols_set_ALT_thm] >> - REWRITE_TAC [pred_setTheory.IMAGE_IMAGE, combinTheory.o_DEF, birs_symb_symbols_EQ_thm] >> - METIS_TAC [] -QED - -Definition birs_freesymbs_SING_def: - birs_freesymbs_SING bs1 bs2 = - ((birs_symb_symbols bs2) DIFF (birs_symb_symbols bs1)) -End - - (* ******************************************************* *) (* SEQ rule *) (* ******************************************************* *) @@ -414,28 +424,70 @@ val betterTheorem = prove(`` METIS_TAC[symb_rulesTheory.symb_rule_SEQ_thm] ); +val IMAGE_DIFF_ASSOC_thm = prove(`` +!f s1 s2. + (!x y. f x = f y <=> x = y) ==> + ((IMAGE f s1) DIFF (IMAGE f s2) = + IMAGE f (s1 DIFF s2)) +``, + fs [IMAGE_DEF, DIFF_DEF, EXTENSION] >> + REPEAT STRIP_TAC >> + EQ_TAC >> ( + METIS_TAC [] + ) +); + +val IMAGE_UNION_ASSOC_thm = prove(`` +!f s1 s2. + (!x y. f x = f y <=> x = y) ==> + ((IMAGE f s1) UNION (IMAGE f s2) = + IMAGE f (s1 UNION s2)) +``, + fs [IMAGE_DEF, UNION_DEF, EXTENSION] >> + REPEAT STRIP_TAC >> + EQ_TAC >> ( + METIS_TAC [] + ) +); + +val bestTheorem = prove(“ + !A B C. + IMAGE birs_symb_to_symbst A DIFF {birs_symb_to_symbst B} UNION IMAGE birs_symb_to_symbst C = + IMAGE birs_symb_to_symbst (A DIFF {B} UNION C) +”, + REWRITE_TAC [GSYM IMAGE_SING] >> + REWRITE_TAC + [MATCH_MP IMAGE_DIFF_ASSOC_thm birs_symb_to_symbst_EQ_thm, + MATCH_MP IMAGE_UNION_ASSOC_thm birs_symb_to_symbst_EQ_thm] +); + Theorem birs_rule_SEQ_gen_thm: !prog bsys_A L_A bPi_A bsys_B L_B bPi_B. - (symb_hl_step_in_L_sound (bir_symb_rec_sbir prog) (birs_symb_to_symbst bsys_A, L_A, IMAGE birs_symb_to_symbst bPi_A)) ==> - (symb_hl_step_in_L_sound (bir_symb_rec_sbir prog) (birs_symb_to_symbst bsys_B, L_B, IMAGE birs_symb_to_symbst bPi_B)) ==> + (birs_symb_exec prog (bsys_A, L_A, bPi_A)) ==> + (birs_symb_exec prog (bsys_B, L_B, bPi_B)) ==> ((birs_symb_symbols bsys_A) INTER (birs_freesymbs bsys_B bPi_B) = EMPTY) ==> - (*(symb_hl_step_in_L_sound (bir_symb_rec_sbir prog) (birs_symb_to_symbst bsys_A, L_A UNION L_B, IMAGE birs_symb_to_symbst ((bPi_A DIFF {bsys_B}) UNION bPi_B))) *) - (symb_hl_step_in_L_sound (bir_symb_rec_sbir prog) (birs_symb_to_symbst bsys_A, L_A UNION L_B, ((IMAGE birs_symb_to_symbst bPi_A) DIFF {birs_symb_to_symbst bsys_B}) UNION (IMAGE birs_symb_to_symbst bPi_B))) + (birs_symb_exec prog (bsys_A, L_A UNION L_B, (bPi_A DIFF {bsys_B}) UNION bPi_B)) Proof + REWRITE_TAC [birs_symb_exec_def] >> REPEAT GEN_TAC >> REWRITE_TAC [ISPECL [``prog: 'a bir_program_t``, ``L_B:bir_programcounter_t -> bool``, ``bsys_B:birs_state_t``, ``bPi_B:birs_state_t -> bool``] birs_freesymbs_EQ_thm] >> REWRITE_TAC [GSYM birs_symb_symbols_EQ_thm] >> REPEAT STRIP_TAC >> ASSUME_TAC (ISPEC ``prog: 'a bir_program_t`` bir_symb_soundTheory.birs_symb_symbols_f_sound_thm) >> - METIS_TAC [betterTheorem] + METIS_TAC [betterTheorem, bestTheorem] QED (* ******************************************************* *) (* NO FREE SYMBS *) (* ******************************************************* *) +Definition birs_freesymbs_SING_def: + birs_freesymbs_SING bs1 bs2 = + ((birs_symb_symbols bs2) DIFF (birs_symb_symbols bs1)) +End + Definition birs_freesymbs_EMPTY_def: birs_freesymbs_EMPTY bs sbs = (birs_freesymbs bs sbs = EMPTY) @@ -836,41 +888,41 @@ QED (* STEP SEQ rule *) (* ******************************************************* *) Theorem birs_rule_STEP_SEQ_gen_thm: - !prog bsys1 L bsys2. + !prog bs1 L bs2. (bir_prog_has_no_halt prog) ==> - (symb_hl_step_in_L_sound (bir_symb_rec_sbir prog) - (birs_symb_to_symbst bsys1, + (birs_symb_exec prog + (bs1, L, - IMAGE birs_symb_to_symbst {bsys2} + {bs2} )) ==> - (symb_hl_step_in_L_sound (bir_symb_rec_sbir prog) - (birs_symb_to_symbst bsys1, - (bsys2.bsst_pc) INSERT L, - IMAGE birs_symb_to_symbst (birs_exec_step prog bsys2) + (birs_symb_exec prog + (bs1, + (bs2.bsst_pc) INSERT L, + (birs_exec_step prog bs2) )) Proof + REWRITE_TAC [birs_symb_exec_def] >> REPEAT STRIP_TAC >> - ASSUME_TAC (Q.SPECL [`prog`, `bsys2`] birs_rule_STEP_gen2_thm) >> - REV_FULL_SIMP_TAC std_ss [] >> - + ASSUME_TAC (Q.SPECL [`prog`, `bs2`] birs_rule_STEP_gen2_thm) >> + REV_FULL_SIMP_TAC std_ss [birs_symb_exec_def] >> ASSUME_TAC (Q.SPEC `prog` bir_symb_soundTheory.birs_symb_symbols_f_sound_thm) >> IMP_RES_TAC (REWRITE_RULE [symb_freesymbs_def] symb_rulesTheory.symb_rule_SEQ_thm) >> - POP_ASSUM (ASSUME_TAC o Q.SPECL [`birs_symb_to_symbst bsys2`, `birs_symb_to_symbst bsys1`, `IMAGE birs_symb_to_symbst (birs_exec_step prog bsys2)`]) >> + POP_ASSUM (ASSUME_TAC o Q.SPECL [`birs_symb_to_symbst bs2`, `birs_symb_to_symbst bs1`, `IMAGE birs_symb_to_symbst (birs_exec_step prog bs2)`]) >> ASSUME_TAC (REWRITE_RULE [birs_freesymbs_EMPTY_def, birs_freesymbs_def] birs_exec_step_NO_FRESH_SYMBS) >> FULL_SIMP_TAC std_ss [INTER_EMPTY, birs_auxTheory.birs_symb_symbols_set_EQ_thm, bir_symb_sound_coreTheory.birs_symb_symbols_EQ_thm] >> - `L UNION {bsys2.bsst_pc} = bsys2.bsst_pc INSERT L` by ( + `L UNION {bs2.bsst_pc} = bs2.bsst_pc INSERT L` by ( METIS_TAC [INSERT_UNION_EQ, UNION_EMPTY, UNION_COMM] ) >> - `(IMAGE birs_symb_to_symbst {bsys2} DIFF {birs_symb_to_symbst bsys2}) UNION - IMAGE birs_symb_to_symbst (birs_exec_step prog bsys2) - = IMAGE birs_symb_to_symbst (birs_exec_step prog bsys2)` by ( + `(IMAGE birs_symb_to_symbst {bs2} DIFF {birs_symb_to_symbst bs2}) UNION + IMAGE birs_symb_to_symbst (birs_exec_step prog bs2) + = IMAGE birs_symb_to_symbst (birs_exec_step prog bs2)` by ( SIMP_TAC std_ss [IMAGE_INSERT, IMAGE_EMPTY, DIFF_EQ_EMPTY, UNION_EMPTY] ) >> diff --git a/src/tools/symbexec/aux_setLib.sml b/src/tools/symbexec/aux_setLib.sml index 60d96f014..556f7c0be 100644 --- a/src/tools/symbexec/aux_setLib.sml +++ b/src/tools/symbexec/aux_setLib.sml @@ -799,52 +799,9 @@ IMAGE birs_symb_to_symbst (BExp_Const (Imm64 0xFFFFFFFFFFFFFF00w)))|>}``; *) -val IMAGE_DIFF_SING_thm = prove(`` -!f s x. - (IMAGE f s) DIFF {f x} = - (IMAGE f s) DIFF (IMAGE f {x}) -``, - SIMP_TAC std_ss [IMAGE_INSERT, IMAGE_EMPTY] -); - - -val IMAGE_DIFF_ASSOC_thm = prove(`` -!f s1 s2. - (!x y. f x = f y <=> x = y) ==> - ((IMAGE f s1) DIFF (IMAGE f s2) = - IMAGE f (s1 DIFF s2)) -``, - REPEAT STRIP_TAC >> - SIMP_TAC std_ss [IMAGE_INSERT, IMAGE_EMPTY, EXTENSION] >> - SIMP_TAC (std_ss++pred_setSimps.PRED_SET_ss) [] >> - REPEAT STRIP_TAC >> - EQ_TAC >> ( - REPEAT STRIP_TAC >> - METIS_TAC [] - ) -); - - -val IMAGE_UNION_ASSOC_thm = prove(`` -!f s1 s2. - (!x y. f x = f y <=> x = y) ==> - ((IMAGE f s1) UNION (IMAGE f s2) = - IMAGE f (s1 UNION s2)) -``, - REPEAT STRIP_TAC >> - SIMP_TAC std_ss [IMAGE_INSERT, IMAGE_EMPTY, EXTENSION] >> - SIMP_TAC (std_ss++pred_setSimps.PRED_SET_ss) [] >> - REPEAT STRIP_TAC >> - EQ_TAC >> ( - REPEAT STRIP_TAC >> - METIS_TAC [] - ) -); - - fun DIFF_UNION_CONV_cheat tm = let - val pat_tm = ``(IMAGE (birs_symb_to_symbst) Pi_a) DIFF {birs_symb_to_symbst sys_b} UNION (IMAGE birs_symb_to_symbst Pi_b)``; + val pat_tm = ``(Pi_a) DIFF {sys_b} UNION (Pi_b)``; val (tm_match, ty_match) = match_term pat_tm tm; val Pi_a = pred_setSyntax.strip_set(subst tm_match (inst ty_match ``Pi_a:birs_state_t->bool``)); @@ -857,13 +814,8 @@ val IMAGE_UNION_ASSOC_thm = prove(`` fun UNION_foldfun (sys,Pi) = if in_f Pi sys then Pi else (sys::Pi); val Pi_c = List.foldr UNION_foldfun Pi_a_minus_b Pi_b; val tm_l_set = if List.null Pi_c then pred_setSyntax.mk_empty (``:birs_state_t``) else pred_setSyntax.mk_set Pi_c; -(* -length Pi_a -length Pi_a_minus_b -length Pi_c -*) in - prove(``^tm = IMAGE birs_symb_to_symbst ^tm_l_set``, cheat) + prove(``^tm = ^tm_l_set``, cheat) end; val speedcheat_diffunion = ref false; @@ -871,29 +823,9 @@ length Pi_c if !speedcheat_diffunion then DIFF_UNION_CONV_cheat else - fn tm => - (REWRITE_CONV [IMAGE_DIFF_SING_thm, MATCH_MP IMAGE_DIFF_ASSOC_thm bir_symbTheory.birs_symb_to_symbst_EQ_thm, GSYM DELETE_DEF] THENC - RATOR_CONV (RAND_CONV (RAND_CONV ( - -fn tm => -( -pred_setLib.DELETE_CONV birs_state_EQ_CONV tm -handle ex => - (print "\n\n\n"; - print_term tm; - print "\n\n\n"; - raise ex - ) -) - - -))) THENC - REWRITE_CONV [MATCH_MP IMAGE_UNION_ASSOC_thm bir_symbTheory.birs_symb_to_symbst_EQ_thm] THENC - RAND_CONV (pred_setLib.UNION_CONV birs_state_EQ_CONV)) - - tm; - - + REWRITE_CONV [GSYM DELETE_DEF] THENC + LAND_CONV (pred_setLib.DELETE_CONV birs_state_EQ_CONV) THENC + pred_setLib.UNION_CONV birs_state_EQ_CONV; end (* local *) diff --git a/src/tools/symbexec/birsSyntax.sml b/src/tools/symbexec/birsSyntax.sml index 611884232..666c462c1 100644 --- a/src/tools/symbexec/birsSyntax.sml +++ b/src/tools/symbexec/birsSyntax.sml @@ -30,12 +30,14 @@ in val (bir_get_current_statement_tm, mk_bir_get_current_statement, dest_bir_get_current_statement, is_bir_get_current_statement) = syntax_fns2 "bir_get_current_statement"; end; +(* local fun syntax_fns n d m = HolKernel.syntax_fns {n = n, dest = d, make = m} "symb_record" val syntax_fns2 = syntax_fns 2 HolKernel.dest_binop HolKernel.mk_binop; in val (symb_hl_step_in_L_sound_tm, mk_symb_hl_step_in_L_sound, dest_symb_hl_step_in_L_sound, is_symb_hl_step_in_L_sound) = syntax_fns2 "symb_hl_step_in_L_sound"; end; +*) local fun syntax_fns n d m = HolKernel.syntax_fns {n = n, dest = d, make = m} "birs_aux" @@ -47,6 +49,17 @@ in val (birs_exps_of_senv_tm, mk_birs_exps_of_senv, dest_birs_exps_of_senv, is_birs_exps_of_senv) = syntax_fns1_set "birs_exps_of_senv"; end; +local + fun syntax_fns n d m = HolKernel.syntax_fns {n = n, dest = d, make = m} "birs_rules" + val syntax_fns2 = syntax_fns 2 HolKernel.dest_binop HolKernel.mk_binop; + val syntax_fns1_set = syntax_fns 2 HolKernel.dest_monop HolKernel.mk_monop; + val syntax_fns2_set = syntax_fns 3 HolKernel.dest_binop HolKernel.mk_binop; +in + val (birs_symb_exec_tm, mk_birs_symb_exec, dest_birs_symb_exec, is_birs_symb_exec) = syntax_fns2 "birs_symb_exec"; + val (birs_symb_symbols_set_tm, mk_birs_symb_symbols_set, dest_birs_symb_symbols_set, is_birs_symb_symbols_set) = syntax_fns1_set "birs_symb_symbols_set"; + val (birs_freesymbs_tm, mk_birs_freesymbs, dest_birs_freesymbs, is_birs_freesymbs) = syntax_fns2_set "birs_freesymbs"; +end; + local fun syntax_fns n d m = HolKernel.syntax_fns {n = n, dest = d, make = m} "bir_symb"; val syntax_fns1 = syntax_fns 1 HolKernel.dest_monop HolKernel.mk_monop; @@ -117,6 +130,7 @@ in val (birs_exp_imp_tm, mk_birs_exp_imp, dest_birs_exp_imp, is_birs_exp_imp) = syntax_fns2 "birs_exp_imp"; end +(* fun is_IMAGE_birs_symb_to_symbst Pi = pred_setSyntax.is_image Pi andalso (identical birs_symb_to_symbst_tm o fst o pred_setSyntax.dest_image) Pi; fun dest_IMAGE_birs_symb_to_symbst Pi = let @@ -126,6 +140,7 @@ fun dest_IMAGE_birs_symb_to_symbst Pi = in im_set_tm end; + *) (* ====================================================================================== *) @@ -194,7 +209,7 @@ fun dest_IMAGE_birs_symb_to_symbst Pi = fun symb_sound_struct_get_sysLPi_fun tm = let val sysLPi_tm = - (snd o dest_symb_hl_step_in_L_sound) tm; + (snd o dest_birs_symb_exec) tm; val res = case pairSyntax.strip_pair sysLPi_tm of [sys_tm, L_tm, Pi_tm] => (sys_tm, L_tm, Pi_tm) @@ -207,24 +222,18 @@ fun symb_sound_struct_get_sysLPi_fun tm = val Pi_tm = Pi_A_tm; *) fun symb_sound_struct_Pi_to_birstatelist_fun Pi_tm = - (pred_setSyntax.strip_set o snd o dest_comb) Pi_tm; + pred_setSyntax.strip_set Pi_tm; (* check if sound structure term is in normalform *) (* ----------------------------------------------- *) fun symb_sound_struct_is_normform tm = let val (sys, L, Pi) = symb_sound_struct_get_sysLPi_fun tm - handle _ => raise ERR "symb_sound_struct_is_normform" "unexpected term, should be a symb_hl_step_in_L_sound with a triple as structure"; - - val sys_ok = - is_birs_symb_to_symbst sys andalso - (birs_state_is_normform o dest_birs_symb_to_symbst) sys; + handle _ => raise ERR "symb_sound_struct_is_normform" "unexpected term, should be a birs_symb_exec with a triple as structure"; + val sys_ok = birs_state_is_normform sys; val L_ok = is_a_normform_set L; - - val Pi_ok = - is_IMAGE_birs_symb_to_symbst Pi andalso - (birs_states_are_normform o dest_IMAGE_birs_symb_to_symbst) Pi; + val Pi_ok = birs_states_are_normform Pi; in sys_ok andalso L_ok andalso Pi_ok end; diff --git a/src/tools/symbexec/birs_composeLib.sml b/src/tools/symbexec/birs_composeLib.sml index 642abd9ff..aa11edcb7 100644 --- a/src/tools/symbexec/birs_composeLib.sml +++ b/src/tools/symbexec/birs_composeLib.sml @@ -44,6 +44,7 @@ fun birs_rule_SEQ_prog_fun bprog_tm = *) (* symbol freedom helper function *) +(* probably should remove the parameter freesymbols_B_thm_o, because obsolete since we have a special STEP_SEQ rule *) fun birs_rule_SEQ_free_symbols_fun freesymbols_tm freesymbols_B_thm_o = let @@ -58,32 +59,12 @@ fun birs_rule_SEQ_free_symbols_fun freesymbols_tm freesymbols_B_thm_o = NONE => ALL_TAC | SOME freesymbols_B_thm => (print_thm freesymbols_B_thm; raise ERR "" ""; REWRITE_TAC [freesymbols_B_thm, pred_setTheory.INTER_EMPTY])) >> - FULL_SIMP_TAC (std_ss) [bir_symb_sound_coreTheory.birs_symb_symbols_EQ_thm, birs_symb_symbols_set_EQ_thm] >> + FULL_SIMP_TAC (std_ss) [birs_rulesTheory.birs_symb_symbols_set_def, birs_rulesTheory.birs_freesymbs_def] >> - (* TODO *) + (* this is to unfold the definitions within the states (env_list_gen) so that the vars_of_symbol function can work *) CONV_TAC (computeLib.RESTR_EVAL_CONV [``birs_symb_symbols``, ``$BIGUNION``]) >> - - CONV_TAC (bir_vars_ofLib.birs_symb_symbols_CONV) >> -(* - CONV_TAC ( - SIMP_CONV (std_ss++birs_state_ss) [birs_symb_symbols_thm] THENC - - - GEN_match_conv is_birs_exps_of_senv birs_exps_of_senv_CONV THENC -(* - REWRITE_CONV [birs_exps_of_senv_thm] THENC -*) - REWRITE_CONV [bir_typing_expTheory.bir_vars_of_exp_def] THENC - - computeLib.RESTR_EVAL_CONV [``$DIFF``, ``$INTER``, ``$UNION``, ``$INSERT``, ``$BIGUNION``] THENC - REWRITE_CONV [pred_setTheory.BIGUNION_INSERT, pred_setTheory.BIGUNION_EMPTY] THENC - REWRITE_CONV [pred_setTheory.UNION_ASSOC, pred_setTheory.INSERT_UNION_EQ, pred_setTheory.UNION_EMPTY] THENC - - REFL -) >> -*) REWRITE_TAC [pred_setTheory.BIGUNION_INSERT, pred_setTheory.BIGUNION_EMPTY] >> REWRITE_TAC [pred_setTheory.UNION_ASSOC, pred_setTheory.INSERT_UNION_EQ, pred_setTheory.UNION_EMPTY] >> @@ -93,105 +74,6 @@ fun birs_rule_SEQ_free_symbols_fun freesymbols_tm freesymbols_B_thm_o = *) (fn (al,g) => (print "starting to proof free symbols\n"; ([(al,g)], fn ([t]) => t))) >> -(* -prove(``{BVar "sy_tmp_countw" (BType_Imm Bit64); - BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); - BVar "sy_tmp_SP_process" (BType_Imm Bit32); - BVar "sy_tmp_SP_main" (BType_Imm Bit32); BVar "sy_tmp_LR" (BType_Imm Bit32); - BVar "sy_tmp_R12" (BType_Imm Bit32); BVar "sy_tmp_R11" (BType_Imm Bit32); - BVar "sy_tmp_R10" (BType_Imm Bit32); BVar "sy_tmp_R9" (BType_Imm Bit32); - BVar "sy_tmp_R8" (BType_Imm Bit32); BVar "sy_tmp_R7" (BType_Imm Bit32); - BVar "sy_tmp_R6" (BType_Imm Bit32); BVar "sy_tmp_R5" (BType_Imm Bit32); - BVar "sy_tmp_R4" (BType_Imm Bit32); BVar "sy_tmp_R3" (BType_Imm Bit32); - BVar "sy_tmp_R2" (BType_Imm Bit32); BVar "sy_tmp_R1" (BType_Imm Bit32); - BVar "sy_tmp_R0" (BType_Imm Bit32); BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); - BVar "sy_tmp_PSR_V" (BType_Imm Bit1); BVar "sy_tmp_PSR_N" (BType_Imm Bit1); - BVar "sy_tmp_PSR_C" (BType_Imm Bit1); - BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); - BVar "sy_tmp_COND" (BType_Imm Bit1); BVar "sy_tmp_PC" (BType_Imm Bit32); - BVar "sy_countw" (BType_Imm Bit64); BVar "sy_ModeHandler" (BType_Imm Bit1); - BVar "sy_SP_process" (BType_Imm Bit32); BVar "sy_SP_main" (BType_Imm Bit32); - BVar "sy_LR" (BType_Imm Bit32); BVar "sy_R12" (BType_Imm Bit32); - BVar "sy_R11" (BType_Imm Bit32); BVar "sy_R10" (BType_Imm Bit32); - BVar "sy_R9" (BType_Imm Bit32); BVar "sy_R8" (BType_Imm Bit32); - BVar "sy_R7" (BType_Imm Bit32); BVar "sy_R6" (BType_Imm Bit32); - BVar "sy_R5" (BType_Imm Bit32); BVar "sy_R4" (BType_Imm Bit32); - BVar "sy_R3" (BType_Imm Bit32); BVar "sy_R2" (BType_Imm Bit32); - BVar "sy_R1" (BType_Imm Bit32); BVar "sy_R0" (BType_Imm Bit32); - BVar "sy_PSR_Z" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1); - BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_C" (BType_Imm Bit1); - BVar "sy_MEM" (BType_Mem Bit32 Bit8)} ∩ -({BVar "sy_countw" (BType_Imm Bit64); BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_tmp_countw" (BType_Imm Bit64); - BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); - BVar "sy_tmp_SP_main" (BType_Imm Bit32); - BVar "sy_tmp_LR" (BType_Imm Bit32); BVar "sy_tmp_R12" (BType_Imm Bit32); - BVar "sy_tmp_R11" (BType_Imm Bit32); BVar "sy_tmp_R10" (BType_Imm Bit32); - BVar "sy_tmp_R9" (BType_Imm Bit32); BVar "sy_tmp_R8" (BType_Imm Bit32); - BVar "sy_tmp_R7" (BType_Imm Bit32); BVar "sy_tmp_R6" (BType_Imm Bit32); - BVar "sy_tmp_R5" (BType_Imm Bit32); BVar "sy_tmp_R4" (BType_Imm Bit32); - BVar "sy_tmp_R3" (BType_Imm Bit32); BVar "sy_tmp_R2" (BType_Imm Bit32); - BVar "sy_tmp_R1" (BType_Imm Bit32); BVar "sy_tmp_R0" (BType_Imm Bit32); - BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); BVar "sy_tmp_PSR_V" (BType_Imm Bit1); - BVar "sy_tmp_PSR_N" (BType_Imm Bit1); BVar "sy_tmp_PSR_C" (BType_Imm Bit1); - BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); - BVar "sy_tmp_COND" (BType_Imm Bit1); BVar "sy_tmp_PC" (BType_Imm Bit32); - BVar "sy_ModeHandler" (BType_Imm Bit1); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_SP_main" (BType_Imm Bit32); BVar "sy_LR" (BType_Imm Bit32); - BVar "sy_R12" (BType_Imm Bit32); BVar "sy_R11" (BType_Imm Bit32); - BVar "sy_R10" (BType_Imm Bit32); BVar "sy_R9" (BType_Imm Bit32); - BVar "sy_R8" (BType_Imm Bit32); BVar "sy_R7" (BType_Imm Bit32); - BVar "sy_R6" (BType_Imm Bit32); BVar "sy_R5" (BType_Imm Bit32); - BVar "sy_R4" (BType_Imm Bit32); BVar "sy_R3" (BType_Imm Bit32); - BVar "sy_R2" (BType_Imm Bit32); BVar "sy_R1" (BType_Imm Bit32); - BVar "sy_R0" (BType_Imm Bit32); BVar "sy_PSR_Z" (BType_Imm Bit1); - BVar "sy_PSR_V" (BType_Imm Bit1); BVar "sy_PSR_N" (BType_Imm Bit1); - BVar "sy_PSR_C" (BType_Imm Bit1); BVar "sy_MEM" (BType_Mem Bit32 Bit8); - BVar "sy_SP_process" (BType_Imm Bit32); BVar "sy_countw" (BType_Imm Bit64)} DIFF - {BVar "sy_countw" (BType_Imm Bit64); BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_tmp_countw" (BType_Imm Bit64); - BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); - BVar "sy_tmp_SP_main" (BType_Imm Bit32); - BVar "sy_tmp_LR" (BType_Imm Bit32); BVar "sy_tmp_R12" (BType_Imm Bit32); - BVar "sy_tmp_R11" (BType_Imm Bit32); BVar "sy_tmp_R10" (BType_Imm Bit32); - BVar "sy_tmp_R9" (BType_Imm Bit32); BVar "sy_tmp_R8" (BType_Imm Bit32); - BVar "sy_tmp_R7" (BType_Imm Bit32); BVar "sy_tmp_R6" (BType_Imm Bit32); - BVar "sy_tmp_R5" (BType_Imm Bit32); BVar "sy_tmp_R4" (BType_Imm Bit32); - BVar "sy_tmp_R3" (BType_Imm Bit32); BVar "sy_tmp_R2" (BType_Imm Bit32); - BVar "sy_tmp_R1" (BType_Imm Bit32); BVar "sy_tmp_R0" (BType_Imm Bit32); - BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); BVar "sy_tmp_PSR_V" (BType_Imm Bit1); - BVar "sy_tmp_PSR_N" (BType_Imm Bit1); BVar "sy_tmp_PSR_C" (BType_Imm Bit1); - BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); - BVar "sy_tmp_COND" (BType_Imm Bit1); BVar "sy_tmp_PC" (BType_Imm Bit32); - BVar "sy_countw" (BType_Imm Bit64); BVar "sy_ModeHandler" (BType_Imm Bit1); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_SP_main" (BType_Imm Bit32); BVar "sy_LR" (BType_Imm Bit32); - BVar "sy_R12" (BType_Imm Bit32); BVar "sy_R11" (BType_Imm Bit32); - BVar "sy_R10" (BType_Imm Bit32); BVar "sy_R9" (BType_Imm Bit32); - BVar "sy_R8" (BType_Imm Bit32); BVar "sy_R7" (BType_Imm Bit32); - BVar "sy_R6" (BType_Imm Bit32); BVar "sy_R5" (BType_Imm Bit32); - BVar "sy_R4" (BType_Imm Bit32); BVar "sy_R3" (BType_Imm Bit32); - BVar "sy_R2" (BType_Imm Bit32); BVar "sy_R1" (BType_Imm Bit32); - BVar "sy_R0" (BType_Imm Bit32); BVar "sy_PSR_Z" (BType_Imm Bit1); - BVar "sy_PSR_V" (BType_Imm Bit1); BVar "sy_PSR_N" (BType_Imm Bit1); - BVar "sy_PSR_C" (BType_Imm Bit1); BVar "sy_MEM" (BType_Mem Bit32 Bit8); - BVar "sy_SP_process" (BType_Imm Bit32)}) ⊆ ∅ -``, -); -*) - - CONV_TAC (RATOR_CONV (RAND_CONV (bir_vars_ofLib.freevarset_CONV))) >> (fn (al,g) => (print "finished to proof free symbols operation\n"; ([(al,g)], fn ([t]) => t))) >> @@ -261,28 +143,18 @@ val freesymbols_B_thm_o = SOME (prove(T, cheat)); *) fun birs_rule_SEQ_fun (birs_rule_SEQ_thm, bprog_tm) step_A_thm step_B_thm freesymbols_B_thm_o = let - val symb_struct_get_bprog_fun = snd o dest_comb o hd o snd o strip_comb; - val bprog_A_tm = (symb_struct_get_bprog_fun o concl) step_A_thm; - val bprog_B_tm = (symb_struct_get_bprog_fun o concl) step_B_thm; + val (bprog_A_tm,_) = (dest_birs_symb_exec o concl) step_A_thm; + val (bprog_B_tm,_) = (dest_birs_symb_exec o concl) step_B_thm; val _ = if identical bprog_tm bprog_A_tm andalso identical bprog_tm bprog_B_tm then () else raise Fail "birs_rule_SEQ_fun:: the programs have to match"; - (* - val (sys_A_tm, _, _) = (symb_sound_struct_get_sysLPi_fun o concl) step_A_thm; - val (sys_B_tm, _, Pi_B_tm) = (symb_sound_struct_get_sysLPi_fun o concl) step_B_thm; - *) - val prep_thm = HO_MATCH_MP (HO_MATCH_MP birs_rule_SEQ_thm step_A_thm) step_B_thm; - (* has to solve this implication ((birs_symb_symbols bsys_A) INTER (birs_freesymbs bsys_B bPi_B) = EMPTY) *) - val freesymbols_tm = (hd o fst o strip_imp o concl) prep_thm; + (* has to solve this ((birs_symb_symbols bsys_A) INTER (birs_freesymbs bsys_B bPi_B) = EMPTY) *) + val freesymbols_tm = (fst o dest_imp o concl) prep_thm; val freesymbols_thm = birs_rule_SEQ_free_symbols_fun freesymbols_tm freesymbols_B_thm_o; val _ = print "finished to proof free symbols altogether\n"; - (* - val bprog_composed_thm = save_thm( - "bprog_composed_thm", - *) val bprog_composed_thm = (MATCH_MP @@ -290,54 +162,20 @@ fun birs_rule_SEQ_fun (birs_rule_SEQ_thm, bprog_tm) step_A_thm step_B_thm freesy freesymbols_thm); val _ = print "composed\n"; - (* TODO: tidy up set operations to not accumulate (in both, post state set and label set) - does this simplification work well enough? *) - (* val bprog_composed_thm_ = SIMP_RULE (std_ss++pred_setLib.PRED_SET_ss) [] bprog_composed_thm; *) - (* val bprog_composed_thm_ = SIMP_RULE (std_ss++pred_setLib.PRED_SET_ss++HolBACoreSimps.holBACore_ss) [pred_setTheory.INSERT_UNION] bprog_composed_thm; *) - -(* -val tm = (snd o dest_comb o snd o dest_comb o snd o dest_comb o concl) bprog_composed_thm; -*) - -(* - val conv = aux_setLib.birs_state_DIFF_UNION_CONV; -*) + (* tidy up set operations to not accumulate (in both, post state set and label set) *) fun Pi_CONV conv tm = RAND_CONV (RAND_CONV (conv handle e => (print "\n\nPi_CONV failed\n\n"; raise e))) tm; - fun L_CONV conv tm = RAND_CONV (LAND_CONV (conv handle e => (print "\n\nL_CONV failed\n\n"; raise e))) tm; val bprog_Pi_fixed_thm = CONV_RULE (RAND_CONV (Pi_CONV aux_setLib.birs_state_DIFF_UNION_CONV)) bprog_composed_thm; val bprog_L_fixed_thm = CONV_RULE (RAND_CONV (L_CONV ( - EVAL (* TODO: this has to be fixed as list of address spaces that can be merged and so on... (can we make this only involve the block label part, not the block index?) *) - (*SIMP_CONV - (std_ss++HolBACoreSimps.holBACore_ss++birs_state_ss++pred_setLib.PRED_SET_ss++wordsLib.WORD_ss) - [bir_symbTheory.birs_symb_to_symbst_EQ_thm, pred_setTheory.INSERT_UNION]*) + EVAL + (* TODO: this has to be fixed as list of address spaces that can be merged and so on... + (can we make this only involve the block label part, not the block index?) *) ))) bprog_Pi_fixed_thm; -(* - val bprog_composed_thm_1 = - (SIMP_RULE - (std_ss++HolBACoreSimps.holBACore_ss++birs_state_ss++pred_setLib.PRED_SET_ss) - [bir_symbTheory.birs_symb_to_symbst_EQ_thm, pred_setTheory.INSERT_UNION] - bprog_composed_thm); - val _ = print "UNION\n"; - - (* reconstruct IMAGE in the post state set *) - val IMAGE_EMPTY_thm = - Q.SPEC `birs_symb_to_symbst` ( - INST_TYPE [beta |-> Type`:(bir_programcounter_t, string, bir_exp_t, bir_status_t) symb_symbst_t`, alpha |-> Type`:birs_state_t`] - pred_setTheory.IMAGE_EMPTY - ); - val _ = print "FIX\n"; - val bprog_composed_thm_2 = - CONV_RULE - (PAT_CONV ``\A. symb_hl_step_in_L_sound B (C, D, A)`` (REWRITE_CONV [GSYM IMAGE_EMPTY_thm, GSYM pred_setTheory.IMAGE_INSERT])) - bprog_composed_thm_1 - val _ = print "IMAGE_INSERT\n"; -*) - val _ = if symb_sound_struct_is_normform (concl bprog_L_fixed_thm) then () else (print_term (concl bprog_L_fixed_thm); raise ERR "birs_rule_SEQ_fun" "something is not right, the produced theorem is not evaluated enough"); diff --git a/src/tools/symbexec/birs_execLib.sml b/src/tools/symbexec/birs_execLib.sml index 77e7e2e4f..6a5a3fe25 100644 --- a/src/tools/symbexec/birs_execLib.sml +++ b/src/tools/symbexec/birs_execLib.sml @@ -72,6 +72,7 @@ fun birs_rule_STEP_fun birs_rule_STEP_thm bstate_tm = val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n>>>>>> STEP in " ^ delta_s ^ "\n")) timer_exec_step_p3; + (*val _ = print_thm single_step_prog_thm;*) val _ = if symb_sound_struct_is_normform (concl single_step_prog_thm) then () else (print_term (concl single_step_prog_thm); raise ERR "birs_rule_STEP_fun" "something is not right, the produced theorem is not evaluated enough"); From f476adc6eced3a486092a168fdfcead59ca44e92 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 30 Sep 2024 21:34:01 +0200 Subject: [PATCH 50/95] Fix transfer from symbexec to contract --- src/tools/symbexec/bir_symbLib.sml | 20 ++++++++------------ 1 file changed, 8 insertions(+), 12 deletions(-) diff --git a/src/tools/symbexec/bir_symbLib.sml b/src/tools/symbexec/bir_symbLib.sml index 033f5d993..ab68f8579 100644 --- a/src/tools/symbexec/bir_symbLib.sml +++ b/src/tools/symbexec/bir_symbLib.sml @@ -188,7 +188,7 @@ fun bir_symb_transfer val analysis_L_NOTIN_thm = prove (``^birs_state_end_lbl_tm NOTIN ^L_s``, EVAL_TAC); val birs_state_init_pre_EQ_thm = - prove (``^((snd o dest_comb) sys_i) = ^birs_state_init_pre_tm``, + prove (``^(sys_i) = ^birs_state_init_pre_tm``, REWRITE_TAC [birs_state_init_pre_GEN_def, mk_bsysprecond_def, bsysprecond_thm] >> CONV_TAC (computeLib.RESTR_EVAL_CONV [``birs_eval_exp``] THENC birs_stepLib.birs_eval_exp_CONV)); @@ -238,8 +238,7 @@ fun bir_symb_transfer POP_ASSUM (fn thm => FULL_SIMP_TAC std_ss [thm])); val sys1 = (snd o dest_eq o concl o REWRITE_CONV [bsysprecond_thm]) birs_state_init_pre_tm; - val (Pi_func, Pi_set) = dest_comb Pi_f; - val sys2s = pred_setSyntax.strip_set Pi_set; + val sys2s = pred_setSyntax.strip_set Pi_f; val strongpostcond_goals = List.map (fn sys2 => `` sys1 = ^sys1 ==> @@ -287,7 +286,7 @@ fun bir_symb_transfer prove (``Pi_overapprox_Q (bir_symb_rec_sbir ^bprog_tm) (P_bircont ^birenvtyl_tm ^bspec_pre_tm) - (birs_symb_to_symbst ^birs_state_init_pre_tm) ^Pi_f + (birs_symb_to_symbst ^birs_state_init_pre_tm) (IMAGE birs_symb_to_symbst ^Pi_f) (Q_bircont ^birs_state_end_lbl_tm (set ^prog_vars_list_tm) ^bspec_post_tm)``, REWRITE_TAC [bir_prop_transferTheory.bir_Pi_overapprox_Q_thm, bsysprecond_thm] >> @@ -306,7 +305,7 @@ fun bir_symb_transfer birs_prop_transfer_thm bprog_P_entails_thm) bprog_Pi_overapprox_Q_thm) - analysis_thm); + (REWRITE_RULE [birs_rulesTheory.birs_symb_exec_def] analysis_thm)); val bir_abstract_jgmt_rel_thm = (MATCH_MP @@ -458,7 +457,7 @@ fun bir_symb_transfer_two val analysis_L_NOTIN_thm_2 = prove (``^birs_state_end_lbl_2_tm NOTIN ^L_s``, EVAL_TAC); val birs_state_init_pre_EQ_thm = - prove (``^((snd o dest_comb) sys_i) = ^birs_state_init_pre_tm``, + prove (``^(sys_i) = ^birs_state_init_pre_tm``, REWRITE_TAC [birs_state_init_pre_GEN_def, mk_bsysprecond_def, bsysprecond_thm] >> CONV_TAC (computeLib.RESTR_EVAL_CONV [``birs_eval_exp``] THENC birs_stepLib.birs_eval_exp_CONV)); @@ -508,10 +507,7 @@ fun bir_symb_transfer_two POP_ASSUM (fn thm => FULL_SIMP_TAC std_ss [thm])); val sys1 = (snd o dest_eq o concl o REWRITE_CONV [bsysprecond_thm]) birs_state_init_pre_tm; - - val (Pi_func, Pi_set) = dest_comb Pi_f; - - val sys2s = pred_setSyntax.strip_set Pi_set; + val sys2s = pred_setSyntax.strip_set Pi_f; val sys2ps = [ (List.nth (sys2s,0), bspec_post_1_tm, birs_state_end_lbl_1_tm), @@ -594,7 +590,7 @@ fun bir_symb_transfer_two prove (``Pi_overapprox_Q (bir_symb_rec_sbir ^bprog_tm) (P_bircont ^birenvtyl_tm ^bspec_pre_tm) - (birs_symb_to_symbst ^birs_state_init_pre_tm) ^Pi_f + (birs_symb_to_symbst ^birs_state_init_pre_tm) (IMAGE birs_symb_to_symbst ^Pi_f) ^bprog_Q_birconts_tm``, REWRITE_TAC [bir_prop_transferTheory.bir_Pi_overapprox_Q_thm, bsysprecond_thm] >> @@ -613,7 +609,7 @@ fun bir_symb_transfer_two birs_prop_transfer_thm bprog_P_entails_thm) bprog_Pi_overapprox_Q_thm) - analysis_thm); + (REWRITE_RULE [birs_rulesTheory.birs_symb_exec_def] analysis_thm)); val bir_abstract_jgmt_rel_thm = (MATCH_MP From 4995462721f36ea525ca317a803bf73effcaf93a Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 30 Sep 2024 22:32:52 +0200 Subject: [PATCH 51/95] Fix CI --- examples/riscv/aes/test-aes.sml | 7 +- src/tools/symbexec/aux_setLib.sml | 750 +++++++++--------- src/tools/symbexec/birsSyntax.sml | 1 + src/tools/symbexec/birs_composeLib.sml | 22 +- .../symbexec/examples/test-birs_transfer.sml | 6 +- 5 files changed, 384 insertions(+), 402 deletions(-) diff --git a/examples/riscv/aes/test-aes.sml b/examples/riscv/aes/test-aes.sml index 4bb6784e4..57cc842ca 100644 --- a/examples/riscv/aes/test-aes.sml +++ b/examples/riscv/aes/test-aes.sml @@ -12,13 +12,12 @@ open aes_symb_execTheory; (* for now we just have a leightweight check; this is to include aes into the test *) val _ = print "checking aes_symb_analysis_thm:\n"; -val _ = if term_size (concl aes_symb_analysis_thm) = 23407 then () else +val _ = if term_size (concl aes_symb_analysis_thm) = 23403 then () else raise Fail "term size of aes symbolic execution theorem is not as expected"; val triple_tm = ((snd o dest_comb o concl) aes_symb_analysis_thm); -val (init_st_tm, pair_tm) = pairSyntax.dest_pair triple_tm; -val (prog_frag_L_tm, final_sts_tm) = pairSyntax.dest_pair pair_tm; -val final_sts_birs_tm = (snd o dest_comb) final_sts_tm; +val [init_st_tm, prog_frag_L_tm, final_sts_tm] = pairSyntax.strip_pair triple_tm; +val final_sts_birs_tm = final_sts_tm; val _ = if (length o pred_setSyntax.strip_set) final_sts_birs_tm = 1 then () else raise Fail "number of final states is not as expected"; diff --git a/src/tools/symbexec/aux_setLib.sml b/src/tools/symbexec/aux_setLib.sml index 556f7c0be..7e4b4fc15 100644 --- a/src/tools/symbexec/aux_setLib.sml +++ b/src/tools/symbexec/aux_setLib.sml @@ -26,240 +26,14 @@ in (* local *) (* ---------------------------------------------------------------------------------- *) (* faster set operations for bir variable sets (for computing freevarset, symbexec composition, merging, etc) *) +(* also for sets of symbolic BIR states *) (* ---------------------------------------------------------------------------------- *) - -(* -EVAL tm - - val birs_exps_of_senv_CONV = ( - debug_conv2 THENC - REPEATC (CHANGED_CONV ( - (fn x => REWRITE_CONV [Once birs_exps_of_senv_COMP_thm] x) THENC - (SIMP_CONV (std_ss) []) THENC - (ONCE_DEPTH_CONV ( (PAT_CONV ``\A. if A then B else (C)`` (REWRITE_CONV [pred_setTheory.COMPONENT] THENC SIMP_CONV std_ss [pred_setTheory.IN_INSERT])))) THENC - SIMP_CONV (std_ss) [] - )) - ); - - val birs_symb_symbols_CONV = ( - SIMP_CONV std_ss [birs_symb_symbols_thm] THENC - SIMP_CONV (std_ss++birs_state_ss) [] THENC - SIMP_CONV (std_ss) [birs_exps_of_senv_thm] - (*(PAT_CONV ``\A. IMAGE bir_vars_of_exp A`` birs_exps_of_senv_CONV)*) - ); - val conv = birs_symb_symbols_CONV (*THENC EVAL*); - val conv_ = computeLib.RESTR_EVAL_CONV [``birs_symb_symbols``] THENC conv; -*) - (* -val tm = `` -{BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1); - BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1); - BVar "sy_PSR_Z" (BType_Imm Bit1); BVar "sy_R0" (BType_Imm Bit32); - BVar "sy_R1" (BType_Imm Bit32); BVar "sy_R2" (BType_Imm Bit32); - BVar "sy_R3" (BType_Imm Bit32); BVar "sy_R4" (BType_Imm Bit32); - BVar "sy_R5" (BType_Imm Bit32); BVar "sy_R6" (BType_Imm Bit32); - BVar "sy_R7" (BType_Imm Bit32); BVar "sy_R8" (BType_Imm Bit32); - BVar "sy_R9" (BType_Imm Bit32); BVar "sy_R10" (BType_Imm Bit32); - BVar "sy_R11" (BType_Imm Bit32); BVar "sy_R12" (BType_Imm Bit32); - BVar "sy_LR" (BType_Imm Bit32); BVar "sy_SP_main" (BType_Imm Bit32); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_ModeHandler" (BType_Imm Bit1); - BVar "sy_countw" (BType_Imm Bit64); BVar "sy_tmp_PC" (BType_Imm Bit32); - BVar "sy_tmp_COND" (BType_Imm Bit1); - BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); - BVar "sy_tmp_PSR_C" (BType_Imm Bit1); - BVar "sy_tmp_PSR_N" (BType_Imm Bit1); - BVar "sy_tmp_PSR_V" (BType_Imm Bit1); - BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); BVar "sy_tmp_R0" (BType_Imm Bit32); - BVar "sy_tmp_R1" (BType_Imm Bit32); BVar "sy_tmp_R2" (BType_Imm Bit32); - BVar "sy_tmp_R3" (BType_Imm Bit32); BVar "sy_tmp_R4" (BType_Imm Bit32); - BVar "sy_tmp_R5" (BType_Imm Bit32); BVar "sy_tmp_R6" (BType_Imm Bit32); - BVar "sy_tmp_R7" (BType_Imm Bit32); BVar "sy_tmp_R8" (BType_Imm Bit32); - BVar "sy_tmp_R9" (BType_Imm Bit32); BVar "sy_tmp_R10" (BType_Imm Bit32); - BVar "sy_tmp_R11" (BType_Imm Bit32); BVar "sy_tmp_R12" (BType_Imm Bit32); - BVar "sy_tmp_LR" (BType_Imm Bit32); - BVar "sy_tmp_SP_main" (BType_Imm Bit32); - BVar "sy_tmp_SP_process" (BType_Imm Bit32); - BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); - BVar "sy_tmp_countw" (BType_Imm Bit64)} ∩ - ({BVar "sy_countw" (BType_Imm Bit64); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1); - BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1); - BVar "sy_PSR_Z" (BType_Imm Bit1); BVar "sy_R0" (BType_Imm Bit32); - BVar "sy_R1" (BType_Imm Bit32); BVar "sy_R2" (BType_Imm Bit32); - BVar "sy_R3" (BType_Imm Bit32); BVar "sy_R4" (BType_Imm Bit32); - BVar "sy_R5" (BType_Imm Bit32); BVar "sy_R6" (BType_Imm Bit32); - BVar "sy_R7" (BType_Imm Bit32); BVar "sy_R8" (BType_Imm Bit32); - BVar "sy_R9" (BType_Imm Bit32); BVar "sy_R10" (BType_Imm Bit32); - BVar "sy_R11" (BType_Imm Bit32); BVar "sy_R12" (BType_Imm Bit32); - BVar "sy_LR" (BType_Imm Bit32); BVar "sy_SP_main" (BType_Imm Bit32); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_ModeHandler" (BType_Imm Bit1); - BVar "sy_countw" (BType_Imm Bit64); BVar "sy_tmp_PC" (BType_Imm Bit32); - BVar "sy_tmp_COND" (BType_Imm Bit1); - BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); - BVar "sy_tmp_PSR_C" (BType_Imm Bit1); - BVar "sy_tmp_PSR_N" (BType_Imm Bit1); - BVar "sy_tmp_PSR_V" (BType_Imm Bit1); - BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); - BVar "sy_tmp_R0" (BType_Imm Bit32); BVar "sy_tmp_R1" (BType_Imm Bit32); - BVar "sy_tmp_R2" (BType_Imm Bit32); BVar "sy_tmp_R3" (BType_Imm Bit32); - BVar "sy_tmp_R4" (BType_Imm Bit32); BVar "sy_tmp_R5" (BType_Imm Bit32); - BVar "sy_tmp_R6" (BType_Imm Bit32); BVar "sy_tmp_R7" (BType_Imm Bit32); - BVar "sy_tmp_R8" (BType_Imm Bit32); BVar "sy_tmp_R9" (BType_Imm Bit32); - BVar "sy_tmp_R10" (BType_Imm Bit32); - BVar "sy_tmp_R11" (BType_Imm Bit32); - BVar "sy_tmp_R12" (BType_Imm Bit32); BVar "sy_tmp_LR" (BType_Imm Bit32); - BVar "sy_tmp_SP_main" (BType_Imm Bit32); - BVar "sy_tmp_SP_process" (BType_Imm Bit32); - BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); - BVar "sy_tmp_countw" (BType_Imm Bit64); - BVar "sy_countw" (BType_Imm Bit64); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1); - BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1); - BVar "sy_PSR_Z" (BType_Imm Bit1); BVar "sy_R0" (BType_Imm Bit32); - BVar "sy_R1" (BType_Imm Bit32); BVar "sy_R2" (BType_Imm Bit32); - BVar "sy_R3" (BType_Imm Bit32); BVar "sy_R4" (BType_Imm Bit32); - BVar "sy_R5" (BType_Imm Bit32); BVar "sy_R6" (BType_Imm Bit32); - BVar "sy_R7" (BType_Imm Bit32); BVar "sy_R8" (BType_Imm Bit32); - BVar "sy_R9" (BType_Imm Bit32); BVar "sy_R10" (BType_Imm Bit32); - BVar "sy_R11" (BType_Imm Bit32); BVar "sy_R12" (BType_Imm Bit32); - BVar "sy_LR" (BType_Imm Bit32); BVar "sy_SP_main" (BType_Imm Bit32); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_ModeHandler" (BType_Imm Bit1); - BVar "sy_countw" (BType_Imm Bit64); BVar "sy_tmp_PC" (BType_Imm Bit32); - BVar "sy_tmp_COND" (BType_Imm Bit1); - BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); - BVar "sy_tmp_PSR_C" (BType_Imm Bit1); - BVar "sy_tmp_PSR_N" (BType_Imm Bit1); - BVar "sy_tmp_PSR_V" (BType_Imm Bit1); - BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); - BVar "sy_tmp_R0" (BType_Imm Bit32); BVar "sy_tmp_R1" (BType_Imm Bit32); - BVar "sy_tmp_R2" (BType_Imm Bit32); BVar "sy_tmp_R3" (BType_Imm Bit32); - BVar "sy_tmp_R4" (BType_Imm Bit32); BVar "sy_tmp_R5" (BType_Imm Bit32); - BVar "sy_tmp_R6" (BType_Imm Bit32); BVar "sy_tmp_R7" (BType_Imm Bit32); - BVar "sy_tmp_R8" (BType_Imm Bit32); BVar "sy_tmp_R9" (BType_Imm Bit32); - BVar "sy_tmp_R10" (BType_Imm Bit32); - BVar "sy_tmp_R11" (BType_Imm Bit32); - BVar "sy_tmp_R12" (BType_Imm Bit32); BVar "sy_tmp_LR" (BType_Imm Bit32); - BVar "sy_tmp_SP_main" (BType_Imm Bit32); - BVar "sy_tmp_SP_process" (BType_Imm Bit32); - BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); - BVar "sy_tmp_countw" (BType_Imm Bit64)} DIFF - {BVar "sy_countw" (BType_Imm Bit64); - BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1); - BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1); - BVar "sy_PSR_Z" (BType_Imm Bit1); BVar "sy_R0" (BType_Imm Bit32); - BVar "sy_R1" (BType_Imm Bit32); BVar "sy_R2" (BType_Imm Bit32); - BVar "sy_R3" (BType_Imm Bit32); BVar "sy_R4" (BType_Imm Bit32); - BVar "sy_R5" (BType_Imm Bit32); BVar "sy_R6" (BType_Imm Bit32); - BVar "sy_R7" (BType_Imm Bit32); BVar "sy_R8" (BType_Imm Bit32); - BVar "sy_R9" (BType_Imm Bit32); BVar "sy_R10" (BType_Imm Bit32); - BVar "sy_R11" (BType_Imm Bit32); BVar "sy_R12" (BType_Imm Bit32); - BVar "sy_LR" (BType_Imm Bit32); BVar "sy_SP_main" (BType_Imm Bit32); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_ModeHandler" (BType_Imm Bit1); - BVar "sy_countw" (BType_Imm Bit64); BVar "sy_tmp_PC" (BType_Imm Bit32); - BVar "sy_tmp_COND" (BType_Imm Bit1); - BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); - BVar "sy_tmp_PSR_C" (BType_Imm Bit1); - BVar "sy_tmp_PSR_N" (BType_Imm Bit1); - BVar "sy_tmp_PSR_V" (BType_Imm Bit1); - BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); - BVar "sy_tmp_R0" (BType_Imm Bit32); BVar "sy_tmp_R1" (BType_Imm Bit32); - BVar "sy_tmp_R2" (BType_Imm Bit32); BVar "sy_tmp_R3" (BType_Imm Bit32); - BVar "sy_tmp_R4" (BType_Imm Bit32); BVar "sy_tmp_R5" (BType_Imm Bit32); - BVar "sy_tmp_R6" (BType_Imm Bit32); BVar "sy_tmp_R7" (BType_Imm Bit32); - BVar "sy_tmp_R8" (BType_Imm Bit32); BVar "sy_tmp_R9" (BType_Imm Bit32); - BVar "sy_tmp_R10" (BType_Imm Bit32); - BVar "sy_tmp_R11" (BType_Imm Bit32); - BVar "sy_tmp_R12" (BType_Imm Bit32); BVar "sy_tmp_LR" (BType_Imm Bit32); - BVar "sy_tmp_SP_main" (BType_Imm Bit32); - BVar "sy_tmp_SP_process" (BType_Imm Bit32); - BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); - BVar "sy_tmp_countw" (BType_Imm Bit64)}) -``; - -val tm = `` -{BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1);BVar "sy_countw" (BType_Imm Bit64); - BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1)} ∩ - ({BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1);BVar "sy_countw" (BType_Imm Bit64); - BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1)} DIFF - { - BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); - BVar "sy_tmp_countw" (BType_Imm Bit64)}) -``; - -val tm = (snd o dest_comb o fst o dest_comb o snd o dest_eq o concl o REWRITE_CONV [REWRITE_RULE [Once pred_setTheory.INTER_COMM] pred_setTheory.DIFF_INTER]) tm; -val tm = (snd o dest_comb o snd o dest_eq o concl o REWRITE_CONV [Once (prove(`` -!s t g. -g INTER (s DIFF t) = -s INTER (g DIFF t) -``, -(*REWRITE_RULE [Once pred_setTheory.INTER_COMM] pred_setTheory.DIFF_INTER*) -METIS_TAC [pred_setTheory.INTER_COMM, pred_setTheory.DIFF_INTER] -))]) tm; - -++pred_setSimps.PRED_SET_ss -val char_ss = rewrites (type_rws ``:char``); - - - -val tm = `` -BVar "sy_countw" (BType_Imm Bit64) ∈ - {BVar "sy_MEM" (BType_Mem Bit32 Bit8); - BVar "sy_PSR_C" (BType_Imm Bit1); BVar "sy_PSR_N" (BType_Imm Bit1); - BVar "sy_PSR_V" (BType_Imm Bit1); BVar "sy_PSR_Z" (BType_Imm Bit1); - BVar "sy_R0" (BType_Imm Bit32); BVar "sy_R1" (BType_Imm Bit32); - BVar "sy_R2" (BType_Imm Bit32); BVar "sy_R3" (BType_Imm Bit32); - BVar "sy_R4" (BType_Imm Bit32); BVar "sy_R5" (BType_Imm Bit32); - BVar "sy_R6" (BType_Imm Bit32); BVar "sy_R7" (BType_Imm Bit32); - BVar "sy_R8" (BType_Imm Bit32); BVar "sy_R9" (BType_Imm Bit32); - BVar "sy_R10" (BType_Imm Bit32); BVar "sy_R11" (BType_Imm Bit32); - BVar "sy_R12" (BType_Imm Bit32); BVar "sy_LR" (BType_Imm Bit32); - BVar "sy_SP_main" (BType_Imm Bit32); - BVar "sy_SP_process" (BType_Imm Bit32); - BVar "sy_ModeHandler" (BType_Imm Bit1); - BVar "sy_countw" (BType_Imm Bit64); - BVar "sy_tmp_PC" (BType_Imm Bit32); - BVar "sy_tmp_COND" (BType_Imm Bit1); - BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); - BVar "sy_tmp_PSR_C" (BType_Imm Bit1); - BVar "sy_tmp_PSR_N" (BType_Imm Bit1); - BVar "sy_tmp_PSR_V" (BType_Imm Bit1); - BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); - BVar "sy_tmp_R0" (BType_Imm Bit32); - BVar "sy_tmp_R1" (BType_Imm Bit32); - BVar "sy_tmp_R2" (BType_Imm Bit32); - BVar "sy_tmp_R3" (BType_Imm Bit32); - BVar "sy_tmp_R4" (BType_Imm Bit32); - BVar "sy_tmp_R5" (BType_Imm Bit32); - BVar "sy_tmp_R6" (BType_Imm Bit32); - BVar "sy_tmp_R7" (BType_Imm Bit32); - BVar "sy_tmp_R8" (BType_Imm Bit32); - BVar "sy_tmp_R9" (BType_Imm Bit32); - BVar "sy_tmp_R10" (BType_Imm Bit32); - BVar "sy_tmp_R11" (BType_Imm Bit32); - BVar "sy_tmp_R12" (BType_Imm Bit32); - BVar "sy_tmp_LR" (BType_Imm Bit32); - BVar "sy_tmp_SP_main" (BType_Imm Bit32); - BVar "sy_tmp_SP_process" (BType_Imm Bit32); - BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); - BVar "sy_tmp_countw" (BType_Imm Bit64)} -``; - - -*) - -(* 65 * 30 * t_IN_VAR = 9-10s -t_IN_VAR = 0.005s *) (* !!!!! try computeLib *) val string_ss = rewrites (type_rws ``:string``); val el_EQ_CONV = SIMP_CONV (std_ss++HolBACoreSimps.holBACore_ss++string_ss) []; +*) val el_EQ_CONV = RAND_CONV EVAL; fun IN_INSERT_CONV el_EQ_CONV tm = @@ -334,6 +108,15 @@ fun INTER_INSERT_CONV_cheat tm = mk_oracle_thm "FISHY_BIRS_FREEVARSET" ([], mk_eq (tm, tm_l_set)) end; + +val speedcheat = ref false; +val INTER_INSERT_CONV = + if !speedcheat then + INTER_INSERT_CONV_cheat + else + INTER_INSERT_CONV_norm el_EQ_CONV; + +(* fun DIFF_INSERT_CONV_cheat tm = let val (s1, s2) = pred_setSyntax.dest_diff tm @@ -347,87 +130,24 @@ fun DIFF_INSERT_CONV_cheat tm = mk_oracle_thm "FISHY_BIRS_FREEVARSET" ([], mk_eq (tm, tm_l_set)) end; - -val speedcheat = ref false; -val INTER_INSERT_CONV = - if !speedcheat then - INTER_INSERT_CONV_cheat - else - INTER_INSERT_CONV_norm el_EQ_CONV; - - val DIFF_INSERT_CONV = if !speedcheat then DIFF_INSERT_CONV_cheat else (*SIMP_CONV (std_ss++HolBACoreSimps.holBACore_ss++string_ss) [pred_setTheory.INSERT_INTER, pred_setTheory.INTER_EMPTY, pred_setTheory.IN_DIFF, pred_setTheory.IN_INSERT]*) EVAL; +*) - - - - - -(* -val tm = `` - EMPTY DIFF - { - BVar "sy_tmp_R0" (BType_Imm Bit32); - BVar "sy_tmp_R1" (BType_Imm Bit32); - BVar "sy_tmp_R2" (BType_Imm Bit32) - } -``; - -val tm = `` - { - BVar "sy_tmp_R0" (BType_Imm Bit32); - BVar "sy_tmp_R1" (BType_Imm Bit32); - BVar "sy_tmp_R2" (BType_Imm Bit32); - BVar "sy_tmp_R3" (BType_Imm Bit32); - BVar "sy_tmp_R4" (BType_Imm Bit32); - BVar "sy_tmp_R5" (BType_Imm Bit32) - } DIFF - EMPTY -``; - -val tm = `` - { - BVar "sy_tmp_R0" (BType_Imm Bit32); - BVar "sy_tmp_R1" (BType_Imm Bit32); - BVar "sy_tmp_R2" (BType_Imm Bit32); - BVar "sy_tmp_R3" (BType_Imm Bit32); - BVar "sy_tmp_R4" (BType_Imm Bit32); - BVar "sy_tmp_R5" (BType_Imm Bit32) - } DIFF - { - BVar "sy_tmp_R0" (BType_Imm Bit32); - BVar "sy_tmp_R1" (BType_Imm Bit32); - BVar "sy_tmp_R2" (BType_Imm Bit32) - } -``; - -val tm = `` -{ - BVar "sy_tmp_R0" (BType_Imm Bit32); - BVar "sy_tmp_R1" (BType_Imm Bit32); - BVar "sy_tmp_R4" (BType_Imm Bit32); - BVar "sy_tmp_R5" (BType_Imm Bit32); - BVar "sy_tmp_R8" (BType_Imm Bit32) -} INTER (^tm) -``; (* R4 and R5 *) -*) - - -fun DIFF_CONV_Once el_EQ_CONV tm = - ( - IFC - (CHANGED_CONV (fn tm => REWRITE_CONV [Once INSERT_DIFF] tm)) - (RATOR_CONV (RATOR_CONV (RAND_CONV (pred_setLib.IN_CONV el_EQ_CONV))) THENC - REWRITE_CONV []) - (REFL) - ) - tm; +fun DIFF_CONV_Once el_EQ_CONV tm = + ( + IFC + (CHANGED_CONV (fn tm => REWRITE_CONV [Once INSERT_DIFF] tm)) + (RATOR_CONV (RATOR_CONV (RAND_CONV (pred_setLib.IN_CONV el_EQ_CONV))) THENC + REWRITE_CONV []) + (REFL) + ) + tm; fun DIFF_CONV el_EQ_CONV tm = if pred_setSyntax.is_empty tm then @@ -455,11 +175,6 @@ DIFF_CONV el_EQ_CONV tm *) -(* ---------------------------------------------------------------------------------- *) -(* ---------------------------------------------------------------------------------- *) -(* ---------------------------------------------------------------------------------- *) -(* ---------------------------------------------------------------------------------- *) -(* ---------------------------------------------------------------------------------- *) (* ---------------------------------------------------------------------------------- *) (* ---------------------------------------------------------------------------------- *) (* ---------------------------------------------------------------------------------- *) @@ -468,43 +183,6 @@ DIFF_CONV el_EQ_CONV tm (* ---------------------------------------------------------------------------------- *) (* state equality checker *) (* ---------------------------------------------------------------------------------- *) - -(* -fun stx_tm addr_tm index_tm symbname_tm = `` - <|bsst_pc := <|bpc_label := BL_Address (Imm32 (^addr_tm)); bpc_index := (^index_tm)|>; - bsst_environ := - birs_gen_env - [("MEM",BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); - ("PSR_C",BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); - ("PSR_N",BExp_Den (BVar "sy_PSR_N" (BType_Imm Bit1))); - ("PSR_V",BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); - ("PSR_Z",BExp_Den (BVar (^symbname_tm) (BType_Imm Bit1)))]; - bsst_status := BST_Running; - bsst_pcond := - (BExp_BinPred BIExp_LessOrEqual - (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) - (BExp_Const (Imm64 0xFFFFFFFFFFFFFF00w)))|> -``; -val st1_tm = stx_tm ``2824w:word32`` ``1:num`` ``"sy_PSR_Z"``; -val st2_tm = stx_tm ``2824w:word32`` ``2:num`` ``"sy_PSR_Z"``; -val st3_tm = stx_tm ``2825w:word32`` ``1:num`` ``"sy_PSR_A"``; -val st4_tm = stx_tm ``2824w:word32`` ``3:num`` ``"sy_PSR_Z"``; - -val st_eq_1_tm = ``^st1_tm = ^st1_tm``; -val st_eq_2_tm = ``^st1_tm = ^st2_tm``; -val st_eq_3_tm = ``^st1_tm = ^st3_tm``; -val st_eq_4_tm = ``^st2_tm = ^st3_tm``; - -val tm = st_eq_2_tm; -val tm = st_eq_3_tm; -val tm = st_eq_4_tm; - -birs_state_EQ_CONV st_eq_1_tm -birs_state_EQ_CONV st_eq_2_tm -birs_state_EQ_CONV st_eq_3_tm -birs_state_EQ_CONV st_eq_4_tm -*) - val birs_state_NEQ_pc_thm = prove(`` !bsys1 bsys2. (bsys1.bsst_pc <> bsys2.bsst_pc) ==> @@ -587,16 +265,50 @@ fun birs_state_EQ_CONV tm = (* set operation for composition, using the state equality checker above *) (* ---------------------------------------------------------------------------------- *) + fun DIFF_UNION_CONV_cheat tm = + let + val pat_tm = ``(Pi_a) DIFF {sys_b} UNION (Pi_b)``; + val (tm_match, ty_match) = match_term pat_tm tm; + + val Pi_a = pred_setSyntax.strip_set(subst tm_match (inst ty_match ``Pi_a:birs_state_t->bool``)); + val sys_b = subst tm_match (inst ty_match ``sys_b:birs_state_t``); + val Pi_b = pred_setSyntax.strip_set(subst tm_match (inst ty_match ``Pi_b:birs_state_t->bool``)); + + fun eq_fun sys1 sys2 = identical sys1 sys2; (* TODO: birs_state_eq_fun*) + fun in_f l x = List.foldr (fn (y, b) => b orelse eq_fun x y) false l; + val Pi_a_minus_b = List.filter (not o eq_fun sys_b) Pi_a; + fun UNION_foldfun (sys,Pi) = if in_f Pi sys then Pi else (sys::Pi); + val Pi_c = List.foldr UNION_foldfun Pi_a_minus_b Pi_b; + val tm_l_set = if List.null Pi_c then pred_setSyntax.mk_empty (``:birs_state_t``) else pred_setSyntax.mk_set Pi_c; + in + prove(``^tm = ^tm_l_set``, cheat) + end; + + val speedcheat_diffunion = ref false; + val birs_state_DIFF_UNION_CONV = + if !speedcheat_diffunion then + DIFF_UNION_CONV_cheat + else + REWRITE_CONV [GSYM DELETE_DEF] THENC + LAND_CONV (pred_setLib.DELETE_CONV birs_state_EQ_CONV) THENC + pred_setLib.UNION_CONV birs_state_EQ_CONV; + +end (* local *) + +end (* struct *) + +(* ---------------------------------------------------------------------------------- *) +(* TEST CASE FOR: set operation for composition *) +(* ---------------------------------------------------------------------------------- *) (* val tm = `` - (IMAGE birs_symb_to_symbst {^st1_tm; ^st2_tm} DIFF - {birs_symb_to_symbst ^st1_tm}) + ({^st1_tm; ^st2_tm} DIFF + {^st1_tm}) UNION - IMAGE birs_symb_to_symbst {^st4_tm} + {^st4_tm} ``; val tm = `` -IMAGE birs_symb_to_symbst {<|bsst_pc := <|bpc_label := BL_Address (Imm32 2824w); bpc_index := 1|>; bsst_environ := birs_gen_env @@ -663,8 +375,7 @@ IMAGE birs_symb_to_symbst (BExp_BinPred BIExp_LessOrEqual (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) (BExp_Const (Imm64 0xFFFFFFFFFFFFFF00w)))|>} DIFF -{birs_symb_to_symbst - <|bsst_pc := <|bpc_label := BL_Address (Imm32 2824w); bpc_index := 1|>; +{ <|bsst_pc := <|bpc_label := BL_Address (Imm32 2824w); bpc_index := 1|>; bsst_environ := birs_gen_env [("MEM",BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); @@ -730,7 +441,6 @@ IMAGE birs_symb_to_symbst (BExp_BinPred BIExp_LessOrEqual (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) (BExp_Const (Imm64 0xFFFFFFFFFFFFFF00w)))|>} ∪ -IMAGE birs_symb_to_symbst {<|bsst_pc := <|bpc_label := BL_Address (Imm32 2824w); bpc_index := 2|>; bsst_environ := birs_gen_env @@ -797,36 +507,324 @@ IMAGE birs_symb_to_symbst (BExp_BinPred BIExp_LessOrEqual (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) (BExp_Const (Imm64 0xFFFFFFFFFFFFFF00w)))|>}``; + +birs_state_DIFF_UNION_CONV tm; *) - fun DIFF_UNION_CONV_cheat tm = - let - val pat_tm = ``(Pi_a) DIFF {sys_b} UNION (Pi_b)``; - val (tm_match, ty_match) = match_term pat_tm tm; +(* ---------------------------------------------------------------------------------- *) +(* TEST CASE FOR: state equality checker *) +(* ---------------------------------------------------------------------------------- *) +(* +fun stx_tm addr_tm index_tm symbname_tm = `` + <|bsst_pc := <|bpc_label := BL_Address (Imm32 (^addr_tm)); bpc_index := (^index_tm)|>; + bsst_environ := + birs_gen_env + [("MEM",BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); + ("PSR_C",BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); + ("PSR_N",BExp_Den (BVar "sy_PSR_N" (BType_Imm Bit1))); + ("PSR_V",BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); + ("PSR_Z",BExp_Den (BVar (^symbname_tm) (BType_Imm Bit1)))]; + bsst_status := BST_Running; + bsst_pcond := + (BExp_BinPred BIExp_LessOrEqual + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 0xFFFFFFFFFFFFFF00w)))|> +``; +val st1_tm = stx_tm ``2824w:word32`` ``1:num`` ``"sy_PSR_Z"``; +val st2_tm = stx_tm ``2824w:word32`` ``2:num`` ``"sy_PSR_Z"``; +val st3_tm = stx_tm ``2825w:word32`` ``1:num`` ``"sy_PSR_A"``; +val st4_tm = stx_tm ``2824w:word32`` ``3:num`` ``"sy_PSR_Z"``; - val Pi_a = pred_setSyntax.strip_set(subst tm_match (inst ty_match ``Pi_a:birs_state_t->bool``)); - val sys_b = subst tm_match (inst ty_match ``sys_b:birs_state_t``); - val Pi_b = pred_setSyntax.strip_set(subst tm_match (inst ty_match ``Pi_b:birs_state_t->bool``)); +val st_eq_1_tm = ``^st1_tm = ^st1_tm``; +val st_eq_2_tm = ``^st1_tm = ^st2_tm``; +val st_eq_3_tm = ``^st1_tm = ^st3_tm``; +val st_eq_4_tm = ``^st2_tm = ^st3_tm``; - fun eq_fun sys1 sys2 = identical sys1 sys2; (* TODO: birs_state_eq_fun*) - fun in_f l x = List.foldr (fn (y, b) => b orelse eq_fun x y) false l; - val Pi_a_minus_b = List.filter (not o eq_fun sys_b) Pi_a; - fun UNION_foldfun (sys,Pi) = if in_f Pi sys then Pi else (sys::Pi); - val Pi_c = List.foldr UNION_foldfun Pi_a_minus_b Pi_b; - val tm_l_set = if List.null Pi_c then pred_setSyntax.mk_empty (``:birs_state_t``) else pred_setSyntax.mk_set Pi_c; - in - prove(``^tm = ^tm_l_set``, cheat) - end; +val tm = st_eq_2_tm; +val tm = st_eq_3_tm; +val tm = st_eq_4_tm; - val speedcheat_diffunion = ref false; - val birs_state_DIFF_UNION_CONV = - if !speedcheat_diffunion then - DIFF_UNION_CONV_cheat - else - REWRITE_CONV [GSYM DELETE_DEF] THENC - LAND_CONV (pred_setLib.DELETE_CONV birs_state_EQ_CONV) THENC - pred_setLib.UNION_CONV birs_state_EQ_CONV; +birs_state_EQ_CONV st_eq_1_tm +birs_state_EQ_CONV st_eq_2_tm +birs_state_EQ_CONV st_eq_3_tm +birs_state_EQ_CONV st_eq_4_tm +*) -end (* local *) +(* ---------------------------------------------------------------------------------- *) +(* TEST CASE FOR: *) +(* faster set operations for bir variable sets (for computing freevarset, symbexec composition, merging, etc) *) +(* also for sets of symbolic BIR states *) +(* ---------------------------------------------------------------------------------- *) +(* +EVAL tm -end (* struct *) + val birs_exps_of_senv_CONV = ( + debug_conv2 THENC + REPEATC (CHANGED_CONV ( + (fn x => REWRITE_CONV [Once birs_exps_of_senv_COMP_thm] x) THENC + (SIMP_CONV (std_ss) []) THENC + (ONCE_DEPTH_CONV ( (PAT_CONV ``\A. if A then B else (C)`` (REWRITE_CONV [pred_setTheory.COMPONENT] THENC SIMP_CONV std_ss [pred_setTheory.IN_INSERT])))) THENC + SIMP_CONV (std_ss) [] + )) + ); + + val birs_symb_symbols_CONV = ( + SIMP_CONV std_ss [birs_symb_symbols_thm] THENC + SIMP_CONV (std_ss++birs_state_ss) [] THENC + SIMP_CONV (std_ss) [birs_exps_of_senv_thm] + (*(PAT_CONV ``\A. IMAGE bir_vars_of_exp A`` birs_exps_of_senv_CONV)*) + ); + val conv = birs_symb_symbols_CONV (*THENC EVAL*); + val conv_ = computeLib.RESTR_EVAL_CONV [``birs_symb_symbols``] THENC conv; +*) + +(* +val tm = `` +{BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1); + BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1); + BVar "sy_PSR_Z" (BType_Imm Bit1); BVar "sy_R0" (BType_Imm Bit32); + BVar "sy_R1" (BType_Imm Bit32); BVar "sy_R2" (BType_Imm Bit32); + BVar "sy_R3" (BType_Imm Bit32); BVar "sy_R4" (BType_Imm Bit32); + BVar "sy_R5" (BType_Imm Bit32); BVar "sy_R6" (BType_Imm Bit32); + BVar "sy_R7" (BType_Imm Bit32); BVar "sy_R8" (BType_Imm Bit32); + BVar "sy_R9" (BType_Imm Bit32); BVar "sy_R10" (BType_Imm Bit32); + BVar "sy_R11" (BType_Imm Bit32); BVar "sy_R12" (BType_Imm Bit32); + BVar "sy_LR" (BType_Imm Bit32); BVar "sy_SP_main" (BType_Imm Bit32); + BVar "sy_SP_process" (BType_Imm Bit32); + BVar "sy_ModeHandler" (BType_Imm Bit1); + BVar "sy_countw" (BType_Imm Bit64); BVar "sy_tmp_PC" (BType_Imm Bit32); + BVar "sy_tmp_COND" (BType_Imm Bit1); + BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); + BVar "sy_tmp_PSR_C" (BType_Imm Bit1); + BVar "sy_tmp_PSR_N" (BType_Imm Bit1); + BVar "sy_tmp_PSR_V" (BType_Imm Bit1); + BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); BVar "sy_tmp_R0" (BType_Imm Bit32); + BVar "sy_tmp_R1" (BType_Imm Bit32); BVar "sy_tmp_R2" (BType_Imm Bit32); + BVar "sy_tmp_R3" (BType_Imm Bit32); BVar "sy_tmp_R4" (BType_Imm Bit32); + BVar "sy_tmp_R5" (BType_Imm Bit32); BVar "sy_tmp_R6" (BType_Imm Bit32); + BVar "sy_tmp_R7" (BType_Imm Bit32); BVar "sy_tmp_R8" (BType_Imm Bit32); + BVar "sy_tmp_R9" (BType_Imm Bit32); BVar "sy_tmp_R10" (BType_Imm Bit32); + BVar "sy_tmp_R11" (BType_Imm Bit32); BVar "sy_tmp_R12" (BType_Imm Bit32); + BVar "sy_tmp_LR" (BType_Imm Bit32); + BVar "sy_tmp_SP_main" (BType_Imm Bit32); + BVar "sy_tmp_SP_process" (BType_Imm Bit32); + BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); + BVar "sy_tmp_countw" (BType_Imm Bit64)} ∩ + ({BVar "sy_countw" (BType_Imm Bit64); + BVar "sy_SP_process" (BType_Imm Bit32); + BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1); + BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1); + BVar "sy_PSR_Z" (BType_Imm Bit1); BVar "sy_R0" (BType_Imm Bit32); + BVar "sy_R1" (BType_Imm Bit32); BVar "sy_R2" (BType_Imm Bit32); + BVar "sy_R3" (BType_Imm Bit32); BVar "sy_R4" (BType_Imm Bit32); + BVar "sy_R5" (BType_Imm Bit32); BVar "sy_R6" (BType_Imm Bit32); + BVar "sy_R7" (BType_Imm Bit32); BVar "sy_R8" (BType_Imm Bit32); + BVar "sy_R9" (BType_Imm Bit32); BVar "sy_R10" (BType_Imm Bit32); + BVar "sy_R11" (BType_Imm Bit32); BVar "sy_R12" (BType_Imm Bit32); + BVar "sy_LR" (BType_Imm Bit32); BVar "sy_SP_main" (BType_Imm Bit32); + BVar "sy_SP_process" (BType_Imm Bit32); + BVar "sy_ModeHandler" (BType_Imm Bit1); + BVar "sy_countw" (BType_Imm Bit64); BVar "sy_tmp_PC" (BType_Imm Bit32); + BVar "sy_tmp_COND" (BType_Imm Bit1); + BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); + BVar "sy_tmp_PSR_C" (BType_Imm Bit1); + BVar "sy_tmp_PSR_N" (BType_Imm Bit1); + BVar "sy_tmp_PSR_V" (BType_Imm Bit1); + BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); + BVar "sy_tmp_R0" (BType_Imm Bit32); BVar "sy_tmp_R1" (BType_Imm Bit32); + BVar "sy_tmp_R2" (BType_Imm Bit32); BVar "sy_tmp_R3" (BType_Imm Bit32); + BVar "sy_tmp_R4" (BType_Imm Bit32); BVar "sy_tmp_R5" (BType_Imm Bit32); + BVar "sy_tmp_R6" (BType_Imm Bit32); BVar "sy_tmp_R7" (BType_Imm Bit32); + BVar "sy_tmp_R8" (BType_Imm Bit32); BVar "sy_tmp_R9" (BType_Imm Bit32); + BVar "sy_tmp_R10" (BType_Imm Bit32); + BVar "sy_tmp_R11" (BType_Imm Bit32); + BVar "sy_tmp_R12" (BType_Imm Bit32); BVar "sy_tmp_LR" (BType_Imm Bit32); + BVar "sy_tmp_SP_main" (BType_Imm Bit32); + BVar "sy_tmp_SP_process" (BType_Imm Bit32); + BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); + BVar "sy_tmp_countw" (BType_Imm Bit64); + BVar "sy_countw" (BType_Imm Bit64); + BVar "sy_SP_process" (BType_Imm Bit32); + BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1); + BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1); + BVar "sy_PSR_Z" (BType_Imm Bit1); BVar "sy_R0" (BType_Imm Bit32); + BVar "sy_R1" (BType_Imm Bit32); BVar "sy_R2" (BType_Imm Bit32); + BVar "sy_R3" (BType_Imm Bit32); BVar "sy_R4" (BType_Imm Bit32); + BVar "sy_R5" (BType_Imm Bit32); BVar "sy_R6" (BType_Imm Bit32); + BVar "sy_R7" (BType_Imm Bit32); BVar "sy_R8" (BType_Imm Bit32); + BVar "sy_R9" (BType_Imm Bit32); BVar "sy_R10" (BType_Imm Bit32); + BVar "sy_R11" (BType_Imm Bit32); BVar "sy_R12" (BType_Imm Bit32); + BVar "sy_LR" (BType_Imm Bit32); BVar "sy_SP_main" (BType_Imm Bit32); + BVar "sy_SP_process" (BType_Imm Bit32); + BVar "sy_ModeHandler" (BType_Imm Bit1); + BVar "sy_countw" (BType_Imm Bit64); BVar "sy_tmp_PC" (BType_Imm Bit32); + BVar "sy_tmp_COND" (BType_Imm Bit1); + BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); + BVar "sy_tmp_PSR_C" (BType_Imm Bit1); + BVar "sy_tmp_PSR_N" (BType_Imm Bit1); + BVar "sy_tmp_PSR_V" (BType_Imm Bit1); + BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); + BVar "sy_tmp_R0" (BType_Imm Bit32); BVar "sy_tmp_R1" (BType_Imm Bit32); + BVar "sy_tmp_R2" (BType_Imm Bit32); BVar "sy_tmp_R3" (BType_Imm Bit32); + BVar "sy_tmp_R4" (BType_Imm Bit32); BVar "sy_tmp_R5" (BType_Imm Bit32); + BVar "sy_tmp_R6" (BType_Imm Bit32); BVar "sy_tmp_R7" (BType_Imm Bit32); + BVar "sy_tmp_R8" (BType_Imm Bit32); BVar "sy_tmp_R9" (BType_Imm Bit32); + BVar "sy_tmp_R10" (BType_Imm Bit32); + BVar "sy_tmp_R11" (BType_Imm Bit32); + BVar "sy_tmp_R12" (BType_Imm Bit32); BVar "sy_tmp_LR" (BType_Imm Bit32); + BVar "sy_tmp_SP_main" (BType_Imm Bit32); + BVar "sy_tmp_SP_process" (BType_Imm Bit32); + BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); + BVar "sy_tmp_countw" (BType_Imm Bit64)} DIFF + {BVar "sy_countw" (BType_Imm Bit64); + BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1); + BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1); + BVar "sy_PSR_Z" (BType_Imm Bit1); BVar "sy_R0" (BType_Imm Bit32); + BVar "sy_R1" (BType_Imm Bit32); BVar "sy_R2" (BType_Imm Bit32); + BVar "sy_R3" (BType_Imm Bit32); BVar "sy_R4" (BType_Imm Bit32); + BVar "sy_R5" (BType_Imm Bit32); BVar "sy_R6" (BType_Imm Bit32); + BVar "sy_R7" (BType_Imm Bit32); BVar "sy_R8" (BType_Imm Bit32); + BVar "sy_R9" (BType_Imm Bit32); BVar "sy_R10" (BType_Imm Bit32); + BVar "sy_R11" (BType_Imm Bit32); BVar "sy_R12" (BType_Imm Bit32); + BVar "sy_LR" (BType_Imm Bit32); BVar "sy_SP_main" (BType_Imm Bit32); + BVar "sy_SP_process" (BType_Imm Bit32); + BVar "sy_ModeHandler" (BType_Imm Bit1); + BVar "sy_countw" (BType_Imm Bit64); BVar "sy_tmp_PC" (BType_Imm Bit32); + BVar "sy_tmp_COND" (BType_Imm Bit1); + BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); + BVar "sy_tmp_PSR_C" (BType_Imm Bit1); + BVar "sy_tmp_PSR_N" (BType_Imm Bit1); + BVar "sy_tmp_PSR_V" (BType_Imm Bit1); + BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); + BVar "sy_tmp_R0" (BType_Imm Bit32); BVar "sy_tmp_R1" (BType_Imm Bit32); + BVar "sy_tmp_R2" (BType_Imm Bit32); BVar "sy_tmp_R3" (BType_Imm Bit32); + BVar "sy_tmp_R4" (BType_Imm Bit32); BVar "sy_tmp_R5" (BType_Imm Bit32); + BVar "sy_tmp_R6" (BType_Imm Bit32); BVar "sy_tmp_R7" (BType_Imm Bit32); + BVar "sy_tmp_R8" (BType_Imm Bit32); BVar "sy_tmp_R9" (BType_Imm Bit32); + BVar "sy_tmp_R10" (BType_Imm Bit32); + BVar "sy_tmp_R11" (BType_Imm Bit32); + BVar "sy_tmp_R12" (BType_Imm Bit32); BVar "sy_tmp_LR" (BType_Imm Bit32); + BVar "sy_tmp_SP_main" (BType_Imm Bit32); + BVar "sy_tmp_SP_process" (BType_Imm Bit32); + BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); + BVar "sy_tmp_countw" (BType_Imm Bit64)}) +``; + +val tm = `` +{BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1);BVar "sy_countw" (BType_Imm Bit64); + BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1)} ∩ + ({BVar "sy_MEM" (BType_Mem Bit32 Bit8); BVar "sy_PSR_C" (BType_Imm Bit1);BVar "sy_countw" (BType_Imm Bit64); + BVar "sy_PSR_N" (BType_Imm Bit1); BVar "sy_PSR_V" (BType_Imm Bit1)} DIFF + { + BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); + BVar "sy_tmp_countw" (BType_Imm Bit64)}) +``; + +val tm = (snd o dest_comb o fst o dest_comb o snd o dest_eq o concl o REWRITE_CONV [REWRITE_RULE [Once pred_setTheory.INTER_COMM] pred_setTheory.DIFF_INTER]) tm; +val tm = (snd o dest_comb o snd o dest_eq o concl o REWRITE_CONV [Once (prove(`` +!s t g. +g INTER (s DIFF t) = +s INTER (g DIFF t) +``, +(*REWRITE_RULE [Once pred_setTheory.INTER_COMM] pred_setTheory.DIFF_INTER*) +METIS_TAC [pred_setTheory.INTER_COMM, pred_setTheory.DIFF_INTER] +))]) tm; + +++pred_setSimps.PRED_SET_ss +val char_ss = rewrites (type_rws ``:char``); + + + +val tm = `` +BVar "sy_countw" (BType_Imm Bit64) ∈ + {BVar "sy_MEM" (BType_Mem Bit32 Bit8); + BVar "sy_PSR_C" (BType_Imm Bit1); BVar "sy_PSR_N" (BType_Imm Bit1); + BVar "sy_PSR_V" (BType_Imm Bit1); BVar "sy_PSR_Z" (BType_Imm Bit1); + BVar "sy_R0" (BType_Imm Bit32); BVar "sy_R1" (BType_Imm Bit32); + BVar "sy_R2" (BType_Imm Bit32); BVar "sy_R3" (BType_Imm Bit32); + BVar "sy_R4" (BType_Imm Bit32); BVar "sy_R5" (BType_Imm Bit32); + BVar "sy_R6" (BType_Imm Bit32); BVar "sy_R7" (BType_Imm Bit32); + BVar "sy_R8" (BType_Imm Bit32); BVar "sy_R9" (BType_Imm Bit32); + BVar "sy_R10" (BType_Imm Bit32); BVar "sy_R11" (BType_Imm Bit32); + BVar "sy_R12" (BType_Imm Bit32); BVar "sy_LR" (BType_Imm Bit32); + BVar "sy_SP_main" (BType_Imm Bit32); + BVar "sy_SP_process" (BType_Imm Bit32); + BVar "sy_ModeHandler" (BType_Imm Bit1); + BVar "sy_countw" (BType_Imm Bit64); + BVar "sy_tmp_PC" (BType_Imm Bit32); + BVar "sy_tmp_COND" (BType_Imm Bit1); + BVar "sy_tmp_MEM" (BType_Mem Bit32 Bit8); + BVar "sy_tmp_PSR_C" (BType_Imm Bit1); + BVar "sy_tmp_PSR_N" (BType_Imm Bit1); + BVar "sy_tmp_PSR_V" (BType_Imm Bit1); + BVar "sy_tmp_PSR_Z" (BType_Imm Bit1); + BVar "sy_tmp_R0" (BType_Imm Bit32); + BVar "sy_tmp_R1" (BType_Imm Bit32); + BVar "sy_tmp_R2" (BType_Imm Bit32); + BVar "sy_tmp_R3" (BType_Imm Bit32); + BVar "sy_tmp_R4" (BType_Imm Bit32); + BVar "sy_tmp_R5" (BType_Imm Bit32); + BVar "sy_tmp_R6" (BType_Imm Bit32); + BVar "sy_tmp_R7" (BType_Imm Bit32); + BVar "sy_tmp_R8" (BType_Imm Bit32); + BVar "sy_tmp_R9" (BType_Imm Bit32); + BVar "sy_tmp_R10" (BType_Imm Bit32); + BVar "sy_tmp_R11" (BType_Imm Bit32); + BVar "sy_tmp_R12" (BType_Imm Bit32); + BVar "sy_tmp_LR" (BType_Imm Bit32); + BVar "sy_tmp_SP_main" (BType_Imm Bit32); + BVar "sy_tmp_SP_process" (BType_Imm Bit32); + BVar "sy_tmp_ModeHandler" (BType_Imm Bit1); + BVar "sy_tmp_countw" (BType_Imm Bit64)} +``; + + +*) +(* +val tm = `` + EMPTY DIFF + { + BVar "sy_tmp_R0" (BType_Imm Bit32); + BVar "sy_tmp_R1" (BType_Imm Bit32); + BVar "sy_tmp_R2" (BType_Imm Bit32) + } +``; + +val tm = `` + { + BVar "sy_tmp_R0" (BType_Imm Bit32); + BVar "sy_tmp_R1" (BType_Imm Bit32); + BVar "sy_tmp_R2" (BType_Imm Bit32); + BVar "sy_tmp_R3" (BType_Imm Bit32); + BVar "sy_tmp_R4" (BType_Imm Bit32); + BVar "sy_tmp_R5" (BType_Imm Bit32) + } DIFF + EMPTY +``; + +val tm = `` + { + BVar "sy_tmp_R0" (BType_Imm Bit32); + BVar "sy_tmp_R1" (BType_Imm Bit32); + BVar "sy_tmp_R2" (BType_Imm Bit32); + BVar "sy_tmp_R3" (BType_Imm Bit32); + BVar "sy_tmp_R4" (BType_Imm Bit32); + BVar "sy_tmp_R5" (BType_Imm Bit32) + } DIFF + { + BVar "sy_tmp_R0" (BType_Imm Bit32); + BVar "sy_tmp_R1" (BType_Imm Bit32); + BVar "sy_tmp_R2" (BType_Imm Bit32) + } +``; + +val tm = `` +{ + BVar "sy_tmp_R0" (BType_Imm Bit32); + BVar "sy_tmp_R1" (BType_Imm Bit32); + BVar "sy_tmp_R4" (BType_Imm Bit32); + BVar "sy_tmp_R5" (BType_Imm Bit32); + BVar "sy_tmp_R8" (BType_Imm Bit32) +} INTER (^tm) +``; (* R4 and R5 *) +*) diff --git a/src/tools/symbexec/birsSyntax.sml b/src/tools/symbexec/birsSyntax.sml index 666c462c1..feeffd442 100644 --- a/src/tools/symbexec/birsSyntax.sml +++ b/src/tools/symbexec/birsSyntax.sml @@ -50,6 +50,7 @@ in end; local + open birs_rulesTheory; fun syntax_fns n d m = HolKernel.syntax_fns {n = n, dest = d, make = m} "birs_rules" val syntax_fns2 = syntax_fns 2 HolKernel.dest_binop HolKernel.mk_binop; val syntax_fns1_set = syntax_fns 2 HolKernel.dest_monop HolKernel.mk_monop; diff --git a/src/tools/symbexec/birs_composeLib.sml b/src/tools/symbexec/birs_composeLib.sml index aa11edcb7..ee26d221a 100644 --- a/src/tools/symbexec/birs_composeLib.sml +++ b/src/tools/symbexec/birs_composeLib.sml @@ -30,29 +30,14 @@ in (* first prepare the SEQ rule for prog *) fun birs_rule_SEQ_prog_fun bprog_tm = (ISPEC (bprog_tm) birs_rulesTheory.birs_rule_SEQ_gen_thm, bprog_tm); - (* - let - val prog_type = (hd o snd o dest_type o type_of) bprog_tm; - val symbols_f_sound_thm = INST_TYPE [Type.alpha |-> prog_type] bir_symb_soundTheory.birs_symb_symbols_f_sound_thm; - val birs_symb_symbols_f_sound_prog_thm = - (SPEC (bprog_tm) symbols_f_sound_thm); - in - print_thm (MATCH_MP birs_rule_SEQ_gen_thm birs_symb_symbols_f_sound_prog_thm); - raise ERR "" ""; - (MATCH_MP birs_rule_SEQ_gen_thm birs_symb_symbols_f_sound_prog_thm) - end; - *) (* symbol freedom helper function *) -(* probably should remove the parameter freesymbols_B_thm_o, because obsolete since we have a special STEP_SEQ rule *) +(* has to solve this ((birs_symb_symbols bsys_A) INTER (birs_freesymbs bsys_B bPi_B) = EMPTY) *) +(* TODO: probably should remove the parameter freesymbols_B_thm_o, because obsolete since we have a special STEP_SEQ rule *) +val speedcheat = ref false; fun birs_rule_SEQ_free_symbols_fun freesymbols_tm freesymbols_B_thm_o = let -(* ------------------------------------------------------------------------ *) -(* ------------------------------------------------------------------------ *) - - val speedcheat = ref false; - val freesymbols_thm = prove(freesymbols_tm, (if !speedcheat then cheat else ALL_TAC) >> (case freesymbols_B_thm_o of @@ -151,7 +136,6 @@ fun birs_rule_SEQ_fun (birs_rule_SEQ_thm, bprog_tm) step_A_thm step_B_thm freesy val prep_thm = HO_MATCH_MP (HO_MATCH_MP birs_rule_SEQ_thm step_A_thm) step_B_thm; - (* has to solve this ((birs_symb_symbols bsys_A) INTER (birs_freesymbs bsys_B bPi_B) = EMPTY) *) val freesymbols_tm = (fst o dest_imp o concl) prep_thm; val freesymbols_thm = birs_rule_SEQ_free_symbols_fun freesymbols_tm freesymbols_B_thm_o; val _ = print "finished to proof free symbols altogether\n"; diff --git a/src/tools/symbexec/examples/test-birs_transfer.sml b/src/tools/symbexec/examples/test-birs_transfer.sml index d0aaaef94..0dc98f61b 100644 --- a/src/tools/symbexec/examples/test-birs_transfer.sml +++ b/src/tools/symbexec/examples/test-birs_transfer.sml @@ -203,7 +203,7 @@ val bprog_Q_thm = store_thm( val bprog_P_entails_thm = store_thm( "bprog_P_entails_thm", `` -P_entails_an_interpret (bir_symb_rec_sbir ^bprog) bprog_P ^sys_tm +P_entails_an_interpret (bir_symb_rec_sbir ^bprog) bprog_P (birs_symb_to_symbst ^sys_tm) ``, REWRITE_TAC [GSYM bsysprecond_thm] >> FULL_SIMP_TAC (std_ss++birs_state_ss) [P_entails_an_interpret_def] >> @@ -232,7 +232,7 @@ P_entails_an_interpret (bir_symb_rec_sbir ^bprog) bprog_P ^sys_tm (* Q is implied by sys and Pi *) val bprog_Pi_overapprox_Q_thm = store_thm( "bprog_Pi_overapprox_Q_thm", `` -Pi_overapprox_Q (bir_symb_rec_sbir ^bprog) bprog_P ^sys_tm ^Pi_tm bprog_Q +Pi_overapprox_Q (bir_symb_rec_sbir ^bprog) bprog_P (birs_symb_to_symbst ^sys_tm) (IMAGE birs_symb_to_symbst ^Pi_tm) bprog_Q ``, SIMP_TAC std_ss [(REWRITE_RULE [EVAL ``birenvtyl``] o EVAL) ``bir_senv_GEN_list birenvtyl``, bsysprecond_thm] >> FULL_SIMP_TAC (std_ss++birs_state_ss) [Pi_overapprox_Q_def] >> @@ -419,7 +419,7 @@ val bprog_prop_holds_thm = birs_prop_transfer_thm bprog_P_entails_thm) bprog_Pi_overapprox_Q_thm) - exec_thm; + (REWRITE_RULE [birs_rulesTheory.birs_symb_exec_def] exec_thm); (* lift to concrete state property *) val bprog_concst_prop_thm = From d6cf066374d7fabff7e60da47370cc8f74798202 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 30 Sep 2024 23:44:22 +0200 Subject: [PATCH 52/95] Refactor for better structure and division among composeLib, vars_ofLib and aux_setLib --- .../tools/symbexec/birs_rulesScript.sml | 19 ++-- src/tools/symbexec/aux_setLib.sml | 2 +- src/tools/symbexec/bir_vars_ofLib.sml | 92 +++++++------------ src/tools/symbexec/birs_composeLib.sml | 74 +++++++++++++-- 4 files changed, 111 insertions(+), 76 deletions(-) diff --git a/src/theory/tools/symbexec/birs_rulesScript.sml b/src/theory/tools/symbexec/birs_rulesScript.sml index 9a23af8f4..74af91f24 100644 --- a/src/theory/tools/symbexec/birs_rulesScript.sml +++ b/src/theory/tools/symbexec/birs_rulesScript.sml @@ -83,14 +83,21 @@ QED Definition birs_freesymbs_def: birs_freesymbs bs sbs = - ((BIGUNION (IMAGE birs_symb_symbols sbs)) DIFF (birs_symb_symbols bs)) + ((birs_symb_symbols_set sbs) DIFF (birs_symb_symbols bs)) End +Theorem birs_freesymbs_thm: + birs_freesymbs bs sbs = + ((BIGUNION (IMAGE birs_symb_symbols sbs)) DIFF (birs_symb_symbols bs)) +Proof + fs [birs_freesymbs_def, birs_symb_symbols_set_def] +QED + Theorem birs_freesymbs_EQ_thm: !prog L bs sbs. birs_freesymbs bs sbs = symb_freesymbs (bir_symb_rec_sbir prog) (birs_symb_to_symbst bs, L, IMAGE birs_symb_to_symbst sbs) Proof - REWRITE_TAC [birs_freesymbs_def, symb_freesymbs_def] >> + REWRITE_TAC [birs_freesymbs_thm, symb_freesymbs_def] >> REWRITE_TAC [birs_auxTheory.symb_symbols_set_ALT_thm] >> REWRITE_TAC [pred_setTheory.IMAGE_IMAGE, combinTheory.o_DEF, birs_symb_symbols_EQ_thm] >> METIS_TAC [] @@ -549,11 +556,11 @@ SIMP_TAC (std_ss) [EXTENSION, IN_BIGUNION_IMAGE, IN_DIFF] >> METIS_TAC [] QED -Theorem birs_freesymbs_thm: +Theorem birs_freesymbs_thm2: !bs sbs. (birs_freesymbs bs sbs = BIGUNION (IMAGE (\bs2. birs_freesymbs_SING bs bs2) sbs)) Proof -SIMP_TAC std_ss [birs_freesymbs_def, birs_freesymbs_SING_def, BIGUNION_IMAGE_DIFF_EQ_thm] +SIMP_TAC std_ss [birs_freesymbs_thm, birs_freesymbs_SING_def, BIGUNION_IMAGE_DIFF_EQ_thm] QED Theorem birs_freesymbs_EMPTY_thm: @@ -561,7 +568,7 @@ Theorem birs_freesymbs_EMPTY_thm: (birs_freesymbs_EMPTY bs sbs = !bs2. bs2 IN sbs ==> (birs_freesymbs_SING_EMPTY bs bs2)) Proof -SIMP_TAC std_ss [birs_freesymbs_EMPTY_def, birs_freesymbs_thm, birs_freesymbs_SING_EMPTY_def] >> +SIMP_TAC std_ss [birs_freesymbs_EMPTY_def, birs_freesymbs_thm2, birs_freesymbs_SING_EMPTY_def] >> SIMP_TAC (std_ss) [EXTENSION, IN_BIGUNION_IMAGE, NOT_IN_EMPTY] >> METIS_TAC [] QED @@ -912,7 +919,7 @@ Proof ASSUME_TAC (Q.SPEC `prog` bir_symb_soundTheory.birs_symb_symbols_f_sound_thm) >> IMP_RES_TAC (REWRITE_RULE [symb_freesymbs_def] symb_rulesTheory.symb_rule_SEQ_thm) >> POP_ASSUM (ASSUME_TAC o Q.SPECL [`birs_symb_to_symbst bs2`, `birs_symb_to_symbst bs1`, `IMAGE birs_symb_to_symbst (birs_exec_step prog bs2)`]) >> - ASSUME_TAC (REWRITE_RULE [birs_freesymbs_EMPTY_def, birs_freesymbs_def] birs_exec_step_NO_FRESH_SYMBS) >> + ASSUME_TAC (REWRITE_RULE [birs_freesymbs_EMPTY_def, birs_freesymbs_thm] birs_exec_step_NO_FRESH_SYMBS) >> FULL_SIMP_TAC std_ss [INTER_EMPTY, birs_auxTheory.birs_symb_symbols_set_EQ_thm, bir_symb_sound_coreTheory.birs_symb_symbols_EQ_thm] >> diff --git a/src/tools/symbexec/aux_setLib.sml b/src/tools/symbexec/aux_setLib.sml index 7e4b4fc15..e22f2b705 100644 --- a/src/tools/symbexec/aux_setLib.sml +++ b/src/tools/symbexec/aux_setLib.sml @@ -88,7 +88,7 @@ fun INTER_INSERT_CONV_norm el_EQ_CONV tm = else (REFL))) tm)) (* the following causes trouble as "normal exit" if there is nothing to be done at the first call *) - (fn tm => (print_term tm; raise Fail "unexpected here")) + (fn tm => (print_term tm; raise Fail "unexpected here: INTER_INSERT_CONV_norm")) ) tm; diff --git a/src/tools/symbexec/bir_vars_ofLib.sml b/src/tools/symbexec/bir_vars_ofLib.sml index 2676b8e2a..d3b6b0ec6 100644 --- a/src/tools/symbexec/bir_vars_ofLib.sml +++ b/src/tools/symbexec/bir_vars_ofLib.sml @@ -427,7 +427,7 @@ fun birs_exps_of_senv_COMP_CONV_norm tm = else birs_exps_of_senv_COMP_CONV_norm ) tm)) - (fn tm => (print_term tm; raise Fail "unexpected here")) + (fn tm => (print_term tm; raise Fail "unexpected here: birs_exps_of_senv_COMP_CONV_norm")) ) tm; val speedcheat = ref false; @@ -452,6 +452,7 @@ fun birs_symb_symbols_DIRECT_CONV tm = raise ERR "birs_symb_symbols_DIRECT_CONV" "cannot handle term" else ( + SIMP_CONV std_ss [birs_gen_env_thm, birs_gen_env_NULL_thm] THENC SIMP_CONV (std_ss++birs_state_ss) [birs_symb_symbols_thm] THENC debug_conv2 THENC birs_auxLib.GEN_match_conv is_birs_exps_of_senv birs_exps_of_senv_CONV THENC @@ -467,75 +468,48 @@ fun birs_symb_symbols_DIRECT_CONV tm = ) tm; val birs_symb_symbols_DIRECT_CONV = aux_moveawayLib.wrap_cache_result Term.compare birs_symb_symbols_DIRECT_CONV; -fun birs_symb_symbols_CONV tm = - birs_auxLib.GEN_match_conv is_birs_symb_symbols birs_symb_symbols_DIRECT_CONV tm; +val birs_symb_symbols_CONV = + birs_auxLib.GEN_match_conv is_birs_symb_symbols birs_symb_symbols_DIRECT_CONV; (* ---------------------------------------------------------------------------------- *) (* symbols of set of symbolic bir states *) (* ---------------------------------------------------------------------------------- *) +fun birs_symb_symbols_set_DIRECT_CONV tm = + if not (is_birs_symb_symbols_set tm) then + raise ERR "birs_symb_symbols_set_DIRECT_CONV" "cannot handle term" + else + ( + SIMP_CONV (std_ss) [birs_rulesTheory.birs_symb_symbols_set_def] THENC + computeLib.RESTR_EVAL_CONV [``birs_symb_symbols``, ``$BIGUNION``] THENC + birs_symb_symbols_CONV THENC + + REWRITE_CONV [pred_setTheory.BIGUNION_INSERT, pred_setTheory.BIGUNION_EMPTY] THENC + REWRITE_CONV [pred_setTheory.UNION_ASSOC, pred_setTheory.INSERT_UNION_EQ, pred_setTheory.UNION_EMPTY] + ) tm; +val birs_symb_symbols_set_DIRECT_CONV = aux_moveawayLib.wrap_cache_result Term.compare birs_symb_symbols_set_DIRECT_CONV; + +val birs_symb_symbols_set_CONV = + birs_auxLib.GEN_match_conv is_birs_symb_symbols_set birs_symb_symbols_set_DIRECT_CONV; (* ---------------------------------------------------------------------------------- *) (* free symbols of execution structure (sys, L, Pi) *) (* ---------------------------------------------------------------------------------- *) -(* TODO: this should go to auxTheory *) -val simplerewrite_thm = prove(`` -!s t g. -g INTER (s DIFF t) = -s INTER (g DIFF t) -``, -(*REWRITE_RULE [Once pred_setTheory.INTER_COMM] pred_setTheory.DIFF_INTER*) -METIS_TAC [pred_setTheory.INTER_COMM, pred_setTheory.DIFF_INTER] -); - -fun freevarset_CONV tm = -( - (*REWRITE_CONV [Once (simplerewrite_thm)] THENC*) (* TODO: was this a good thing for composition when there are many unused/unchanged symbols around? *) - - (RAND_CONV ( - aux_setLib.DIFF_CONV EVAL - )) THENC - - (* then INTER *) - aux_setLib.INTER_INSERT_CONV -) tm; - -(* -fun freevarset_CONV tm = -( - REWRITE_CONV [Once (prove(`` -!s t g. -g INTER (s DIFF t) = -s INTER (g DIFF t) -``, -(*REWRITE_RULE [Once pred_setTheory.INTER_COMM] pred_setTheory.DIFF_INTER*) -METIS_TAC [pred_setTheory.INTER_COMM, pred_setTheory.DIFF_INTER] -))] THENC - - (* DIFF first *) -(* - RATOR_CONV (RAND_CONV (SIMP_CONV (std_ss++HolBACoreSimps.holBACore_ss++string_ss) [pred_setTheory.INSERT_INTER, pred_setTheory.INTER_EMPTY])) THENC -*) - (* RATOR_CONV (RAND_CONV (INTER_INSERT_CONV)) THENC*) - (RAND_CONV ( -(* - (fn tm => prove (``^tm = EMPTY``, cheat)) -*) - aux_setLib.DIFF_INSERT_CONV -)) THENC -(* -(fn tm => (if false then print ".\n" else print_term tm; print "aa\n\n"; REFL tm)) THENC -*) - - - - (* then INTER *) - aux_setLib.INTER_INSERT_CONV -) tm; +fun birs_freesymbs_DIRECT_CONV tm = + if not (is_birs_freesymbs tm) then + raise ERR "birs_freesymbs_DIRECT_CONV" "cannot handle term" + else + ( + SIMP_CONV (std_ss) [birs_rulesTheory.birs_freesymbs_def] THENC + LAND_CONV (birs_symb_symbols_set_DIRECT_CONV) THENC + RAND_CONV (birs_symb_symbols_DIRECT_CONV) + (* TODO: EVAL (* var set DIFF *) *) + ) tm; +val birs_freesymbs_DIRECT_CONV = aux_moveawayLib.wrap_cache_result Term.compare birs_freesymbs_DIRECT_CONV; -(* EVAL tm *) -*) +val birs_freesymbs_CONV = + birs_auxLib.GEN_match_conv is_birs_freesymbs birs_freesymbs_DIRECT_CONV; end (* local *) diff --git a/src/tools/symbexec/birs_composeLib.sml b/src/tools/symbexec/birs_composeLib.sml index ee26d221a..cddd7d333 100644 --- a/src/tools/symbexec/birs_composeLib.sml +++ b/src/tools/symbexec/birs_composeLib.sml @@ -21,12 +21,72 @@ open HolBACoreSimps; open symb_interpretTheory; open pred_setTheory; *) + open bir_vars_ofLib; + open birsSyntax; open birs_auxTheory; val birs_state_ss = rewrites (type_rws ``:birs_state_t``); in +(* TODO: this should go to auxTheory *) +val simplerewrite_thm = prove(`` +!s t g. +g INTER (s DIFF t) = +s INTER (g DIFF t) +``, +(*REWRITE_RULE [Once pred_setTheory.INTER_COMM] pred_setTheory.DIFF_INTER*) +METIS_TAC [pred_setTheory.INTER_COMM, pred_setTheory.DIFF_INTER] +); + +fun freevarset_CONV tm = +( + (*REWRITE_CONV [Once (simplerewrite_thm)] THENC*) (* TODO: was this a good thing for composition when there are many unused/unchanged symbols around? *) + + (RAND_CONV ( + aux_setLib.DIFF_CONV EVAL + )) THENC + + (* then INTER *) + aux_setLib.INTER_INSERT_CONV +) tm; + +(* +fun freevarset_CONV tm = +( + REWRITE_CONV [Once (prove(`` +!s t g. +g INTER (s DIFF t) = +s INTER (g DIFF t) +``, +(*REWRITE_RULE [Once pred_setTheory.INTER_COMM] pred_setTheory.DIFF_INTER*) +METIS_TAC [pred_setTheory.INTER_COMM, pred_setTheory.DIFF_INTER] +))] THENC + + (* DIFF first *) +(* + RATOR_CONV (RAND_CONV (SIMP_CONV (std_ss++HolBACoreSimps.holBACore_ss++string_ss) [pred_setTheory.INSERT_INTER, pred_setTheory.INTER_EMPTY])) THENC +*) + (* RATOR_CONV (RAND_CONV (INTER_INSERT_CONV)) THENC*) + (RAND_CONV ( +(* + (fn tm => prove (``^tm = EMPTY``, cheat)) +*) + aux_setLib.DIFF_INSERT_CONV +)) THENC +(* +(fn tm => (if false then print ".\n" else print_term tm; print "aa\n\n"; REFL tm)) THENC +*) + + + + (* then INTER *) + aux_setLib.INTER_INSERT_CONV +) tm; + +(* EVAL tm *) +*) + (* first prepare the SEQ rule for prog *) fun birs_rule_SEQ_prog_fun bprog_tm = (ISPEC (bprog_tm) birs_rulesTheory.birs_rule_SEQ_gen_thm, bprog_tm); @@ -44,22 +104,16 @@ fun birs_rule_SEQ_free_symbols_fun freesymbols_tm freesymbols_B_thm_o = NONE => ALL_TAC | SOME freesymbols_B_thm => (print_thm freesymbols_B_thm; raise ERR "" ""; REWRITE_TAC [freesymbols_B_thm, pred_setTheory.INTER_EMPTY])) >> - FULL_SIMP_TAC (std_ss) [birs_rulesTheory.birs_symb_symbols_set_def, birs_rulesTheory.birs_freesymbs_def] >> - - (* this is to unfold the definitions within the states (env_list_gen) so that the vars_of_symbol function can work *) - CONV_TAC (computeLib.RESTR_EVAL_CONV [``birs_symb_symbols``, ``$BIGUNION``]) >> - - CONV_TAC (bir_vars_ofLib.birs_symb_symbols_CONV) >> - - REWRITE_TAC [pred_setTheory.BIGUNION_INSERT, pred_setTheory.BIGUNION_EMPTY] >> - REWRITE_TAC [pred_setTheory.UNION_ASSOC, pred_setTheory.INSERT_UNION_EQ, pred_setTheory.UNION_EMPTY] >> + CONV_TAC (LAND_CONV (LAND_CONV (birs_symb_symbols_DIRECT_CONV))) >> + CONV_TAC (LAND_CONV (RAND_CONV (birs_freesymbs_DIRECT_CONV))) >> + (* now have A INTER (B DIFF C) = EMPTY*) (* (fn (al,g) => (print_term g; ([(al,g)], fn ([t]) => t))) >> *) (fn (al,g) => (print "starting to proof free symbols\n"; ([(al,g)], fn ([t]) => t))) >> - CONV_TAC (RATOR_CONV (RAND_CONV (bir_vars_ofLib.freevarset_CONV))) >> + CONV_TAC (RATOR_CONV (RAND_CONV (freevarset_CONV))) >> (fn (al,g) => (print "finished to proof free symbols operation\n"; ([(al,g)], fn ([t]) => t))) >> REWRITE_TAC [pred_setTheory.EMPTY_SUBSET] From 6ca624ce14004b5d92cdc7489fae7e8d3cce1810 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Tue, 1 Oct 2024 16:28:48 +0200 Subject: [PATCH 53/95] Refactor for cleaner and simpler code --- src/tools/symbexec/aux_setLib.sml | 481 +++++++++++++------------ src/tools/symbexec/bir_vars_ofLib.sml | 366 +++++++++---------- src/tools/symbexec/birs_composeLib.sml | 258 ++++--------- src/tools/symbexec/birs_driveLib.sml | 34 +- 4 files changed, 517 insertions(+), 622 deletions(-) diff --git a/src/tools/symbexec/aux_setLib.sml b/src/tools/symbexec/aux_setLib.sml index e22f2b705..b81b49af3 100644 --- a/src/tools/symbexec/aux_setLib.sml +++ b/src/tools/symbexec/aux_setLib.sml @@ -25,185 +25,180 @@ val birs_state_ss = rewrites (type_rws ``:birs_state_t``); in (* local *) (* ---------------------------------------------------------------------------------- *) -(* faster set operations for bir variable sets (for computing freevarset, symbexec composition, merging, etc) *) -(* also for sets of symbolic BIR states *) +(* generic fast set operations (conversions) *) (* ---------------------------------------------------------------------------------- *) -(* -(* !!!!! try computeLib *) -val string_ss = rewrites (type_rws ``:string``); + (* + val el_EQ_CONV = EVAL; + *) + fun IN_INSERT_CONV el_EQ_CONV tm = + ( + REWRITE_CONV [pred_setTheory.NOT_IN_EMPTY] THENC + REPEATC (CHANGED_CONV ( + (fn xyz => REWRITE_CONV [Once pred_setTheory.IN_INSERT] xyz) THENC + (*(fn tm => (if false then print ".\n" else print_term tm; print "aa\n\n"; REFL tm)) THENC*) + IFC + (RATOR_CONV el_EQ_CONV) + (REWRITE_CONV [pred_setTheory.NOT_IN_EMPTY]) + REFL)) + ) tm; + + fun INTER_INSERT_ONCE_CONV el_EQ_CONV tm = + ( + (QCHANGED_CONV (CHANGED_CONV (fn x => REWRITE_CONV [Once pred_setTheory.INSERT_INTER, pred_setTheory.INTER_EMPTY] x))) THENC + IFC + (RATOR_CONV (RATOR_CONV (RAND_CONV ( + (* + fn tm => (print_term (concl (prove (mk_eq (tm, F), cheat))); prove (mk_eq (tm, F), cheat)) + *) + (*fn tm => (prove (mk_eq (tm, F), cheat))*) + (*(fn tm => (if false then print ".\n" else print_term tm; print "aa\n\n"; REFL tm)) THENC*) + IN_INSERT_CONV el_EQ_CONV + )))) + (REWRITE_CONV []) + (REFL) + ) tm; -val el_EQ_CONV = SIMP_CONV (std_ss++HolBACoreSimps.holBACore_ss++string_ss) []; -*) -val el_EQ_CONV = RAND_CONV EVAL; - -fun IN_INSERT_CONV el_EQ_CONV tm = -( - REWRITE_CONV [pred_setTheory.NOT_IN_EMPTY] THENC - REPEATC (CHANGED_CONV ( - (fn xyz => REWRITE_CONV [Once pred_setTheory.IN_INSERT] xyz) THENC - (*(fn tm => (if false then print ".\n" else print_term tm; print "aa\n\n"; REFL tm)) THENC*) - IFC - (RATOR_CONV el_EQ_CONV) - (REWRITE_CONV [pred_setTheory.NOT_IN_EMPTY]) - REFL)) -) tm; - -fun INTER_INSERT_ONCE_CONV el_EQ_CONV tm = -( - (QCHANGED_CONV (CHANGED_CONV (fn x => REWRITE_CONV [Once pred_setTheory.INSERT_INTER, pred_setTheory.INTER_EMPTY] x))) THENC - IFC - (RATOR_CONV (RATOR_CONV (RAND_CONV ( -(* -fn tm => (print_term (concl (prove (mk_eq (tm, F), cheat))); prove (mk_eq (tm, F), cheat)) -*) -(*fn tm => (prove (mk_eq (tm, F), cheat))*) -(*(fn tm => (if false then print ".\n" else print_term tm; print "aa\n\n"; REFL tm)) THENC*) -IN_INSERT_CONV el_EQ_CONV -)))) - (REWRITE_CONV []) - (REFL) -) tm; - -fun INTER_INSERT_CONV_norm el_EQ_CONV tm = -( - if pred_setSyntax.is_empty tm then - REFL - else - (fn tm => (if true then print ".\n" else (print_term tm; print "\n\n"); REFL tm)) THENC - IFC - (INTER_INSERT_ONCE_CONV el_EQ_CONV) - ( -(* -(fn tm => (if false then print ".\n" else print_term tm; print "bb\n\n"; REFL tm)) THENC -*) -(fn tm => + fun INTER_INSERT_CONV_norm el_EQ_CONV tm = + ( + if pred_setSyntax.is_empty tm then + REFL + else + (*(fn tm => (if true then print ".\n" else (print_term tm; print "\n\n"); REFL tm)) THENC*) + IFC + (INTER_INSERT_ONCE_CONV el_EQ_CONV) ( - (*(fn tm => (if false then print ".\n" else print_term tm; print "bb\n\n"; REFL tm)) THENC *) - (if pred_setSyntax.is_empty tm then - (REFL) - else if pred_setSyntax.is_inter tm then - (INTER_INSERT_CONV_norm el_EQ_CONV) - else if pred_setSyntax.is_insert tm then - (RAND_CONV (INTER_INSERT_CONV_norm el_EQ_CONV)) - else - (REFL))) tm)) -(* the following causes trouble as "normal exit" if there is nothing to be done at the first call *) - (fn tm => (print_term tm; raise Fail "unexpected here: INTER_INSERT_CONV_norm")) -) tm; - - -(* TODO: fix this *) -fun bvar_eq_fun_cheat tm1 tm2 = identical tm1 tm2; - -fun INTER_INSERT_CONV_cheat tm = - let - val (s1, s2) = pred_setSyntax.dest_inter tm - val s1_l = pred_setSyntax.strip_set s1; - val s2_l = pred_setSyntax.strip_set s2; - val eq_fun = bvar_eq_fun_cheat; - fun in_f l x = List.foldr (fn (y, b) => b orelse eq_fun x y) false l; - val l = List.foldr (fn (x, l) => if in_f s2_l x then x::l else l) [] s1_l; - val tm_l_set = if List.null l then pred_setSyntax.mk_empty(pred_setSyntax.eltype tm) else pred_setSyntax.mk_set l; - in - mk_oracle_thm "FISHY_BIRS_FREEVARSET" ([], mk_eq (tm, tm_l_set)) - end; - - -val speedcheat = ref false; -val INTER_INSERT_CONV = - if !speedcheat then - INTER_INSERT_CONV_cheat - else - INTER_INSERT_CONV_norm el_EQ_CONV; - -(* -fun DIFF_INSERT_CONV_cheat tm = - let - val (s1, s2) = pred_setSyntax.dest_diff tm - val s1_l = pred_setSyntax.strip_set s1; - val s2_l = pred_setSyntax.strip_set s2; - val eq_fun = bvar_eq_fun_cheat; - fun in_f l x = List.foldr (fn (y, b) => b orelse eq_fun x y) false l; - val l = List.foldr (fn (x, l) => if not (in_f s2_l x) then x::l else l) [] s1_l; - val tm_l_set = if List.null l then pred_setSyntax.mk_empty(pred_setSyntax.eltype tm) else pred_setSyntax.mk_set l; - in - mk_oracle_thm "FISHY_BIRS_FREEVARSET" ([], mk_eq (tm, tm_l_set)) - end; - -val DIFF_INSERT_CONV = - if !speedcheat then - DIFF_INSERT_CONV_cheat - else - (*SIMP_CONV (std_ss++HolBACoreSimps.holBACore_ss++string_ss) [pred_setTheory.INSERT_INTER, pred_setTheory.INTER_EMPTY, pred_setTheory.IN_DIFF, pred_setTheory.IN_INSERT]*) - EVAL; -*) + (* + (fn tm => (if false then print ".\n" else print_term tm; print "bb\n\n"; REFL tm)) THENC + *) + (fn tm => + ( + (*(fn tm => (if false then print ".\n" else print_term tm; print "bb\n\n"; REFL tm)) THENC *) + (if pred_setSyntax.is_empty tm then + (REFL) + else if pred_setSyntax.is_inter tm then + (INTER_INSERT_CONV_norm el_EQ_CONV) + else if pred_setSyntax.is_insert tm then + (RAND_CONV (INTER_INSERT_CONV_norm el_EQ_CONV)) + else + (REFL))) tm)) + (* the following causes trouble as "normal exit" if there is nothing to be done at the first call *) + (fn tm => (print_term tm; raise Fail "unexpected here: INTER_INSERT_CONV_norm")) + ) tm; + + + (* TODO: fix this *) + fun bvar_eq_fun_cheat tm1 tm2 = identical tm1 tm2; + + fun INTER_INSERT_CONV_cheat tm = + let + val (s1, s2) = pred_setSyntax.dest_inter tm + val s1_l = pred_setSyntax.strip_set s1; + val s2_l = pred_setSyntax.strip_set s2; + val eq_fun = bvar_eq_fun_cheat; + fun in_f l x = List.foldr (fn (y, b) => b orelse eq_fun x y) false l; + val l = List.foldr (fn (x, l) => if in_f s2_l x then x::l else l) [] s1_l; + val tm_l_set = if List.null l then pred_setSyntax.mk_empty(pred_setSyntax.eltype tm) else pred_setSyntax.mk_set l; + in + mk_oracle_thm "FISHY_BIRS_FREEVARSET" ([], mk_eq (tm, tm_l_set)) + end; + + val speedcheat_INTER_INSERT_CONV = ref false; + fun INTER_INSERT_CONV el_EQ_CONV = + if !speedcheat_INTER_INSERT_CONV then + INTER_INSERT_CONV_cheat + else + INTER_INSERT_CONV_norm el_EQ_CONV; + + (* + fun DIFF_INSERT_CONV_cheat tm = + let + val (s1, s2) = pred_setSyntax.dest_diff tm + val s1_l = pred_setSyntax.strip_set s1; + val s2_l = pred_setSyntax.strip_set s2; + val eq_fun = bvar_eq_fun_cheat; + fun in_f l x = List.foldr (fn (y, b) => b orelse eq_fun x y) false l; + val l = List.foldr (fn (x, l) => if not (in_f s2_l x) then x::l else l) [] s1_l; + val tm_l_set = if List.null l then pred_setSyntax.mk_empty(pred_setSyntax.eltype tm) else pred_setSyntax.mk_set l; + in + mk_oracle_thm "FISHY_BIRS_FREEVARSET" ([], mk_eq (tm, tm_l_set)) + end; + + val DIFF_INSERT_CONV = + if !speedcheat then + DIFF_INSERT_CONV_cheat + else + (*SIMP_CONV (std_ss++HolBACoreSimps.holBACore_ss++string_ss) [pred_setTheory.INSERT_INTER, pred_setTheory.INTER_EMPTY, pred_setTheory.IN_DIFF, pred_setTheory.IN_INSERT]*) + EVAL; + *) -fun DIFF_CONV_Once el_EQ_CONV tm = - ( - IFC - (CHANGED_CONV (fn tm => REWRITE_CONV [Once INSERT_DIFF] tm)) - (RATOR_CONV (RATOR_CONV (RAND_CONV (pred_setLib.IN_CONV el_EQ_CONV))) THENC - REWRITE_CONV []) - (REFL) - ) - tm; - -fun DIFF_CONV el_EQ_CONV tm = - if pred_setSyntax.is_empty tm then - REFL tm - else if pred_setSyntax.is_diff tm then - if (pred_setSyntax.is_empty o fst o pred_setSyntax.dest_diff) tm then - (print_term tm; - REWRITE_CONV [EMPTY_DIFF] tm) - else if (pred_setSyntax.is_insert o fst o pred_setSyntax.dest_diff) tm then - (DIFF_CONV_Once el_EQ_CONV THENC - DIFF_CONV el_EQ_CONV) tm + fun DIFF_CONV_Once el_EQ_CONV tm = + ( + IFC + (CHANGED_CONV (fn tm => REWRITE_CONV [Once INSERT_DIFF] tm)) + (RATOR_CONV (RATOR_CONV (RAND_CONV (pred_setLib.IN_CONV el_EQ_CONV))) THENC + REWRITE_CONV []) + (REFL) + ) + tm; + + fun DIFF_CONV el_EQ_CONV tm = + if pred_setSyntax.is_empty tm then + REFL tm + else if pred_setSyntax.is_diff tm then + if (pred_setSyntax.is_empty o fst o pred_setSyntax.dest_diff) tm then + (print_term tm; + REWRITE_CONV [EMPTY_DIFF] tm) + else if (pred_setSyntax.is_insert o fst o pred_setSyntax.dest_diff) tm then + (DIFF_CONV_Once el_EQ_CONV THENC + DIFF_CONV el_EQ_CONV) tm + else + raise ERR "DIFF_CONV" "unexpected1" + else if pred_setSyntax.is_insert tm then + RAND_CONV + (DIFF_CONV el_EQ_CONV) + tm else - raise ERR "DIFF_CONV" "unexpected1" - else if pred_setSyntax.is_insert tm then - RAND_CONV - (DIFF_CONV el_EQ_CONV) - tm - else - (print_term tm; - raise ERR "DIFF_CONV" "unexpected2"); + (print_term tm; + raise ERR "DIFF_CONV" "unexpected2"); -(* -val el_EQ_CONV = EVAL; -DIFF_CONV el_EQ_CONV tm -*) +(* ================================================================================== *) +(* ================================================================================== *) (* ---------------------------------------------------------------------------------- *) +(* bir var set equality checker *) (* ---------------------------------------------------------------------------------- *) -(* ---------------------------------------------------------------------------------- *) -(* ---------------------------------------------------------------------------------- *) + (* + val string_ss = rewrites (type_rws ``:string``); + val varset_EQ_CONV = SIMP_CONV (std_ss++HolBACoreSimps.holBACore_ss++string_ss) []; + *) + val varset_EQ_CONV = EVAL; (* ---------------------------------------------------------------------------------- *) -(* state equality checker *) +(* birs state equality checker *) (* ---------------------------------------------------------------------------------- *) -val birs_state_NEQ_pc_thm = prove(`` -!bsys1 bsys2. - (bsys1.bsst_pc <> bsys2.bsst_pc) ==> - (bsys1 <> bsys2) -``, - SIMP_TAC (std_ss++birs_state_ss) [] -); -val birs_state_NEQ_pcond_thm = prove(`` -!bsys1 bsys2. - (bsys1.bsst_pcond <> bsys2.bsst_pcond) ==> - (bsys1 <> bsys2) -``, - SIMP_TAC (std_ss++birs_state_ss) [] -); -val birs_state_NEQ_status_thm = prove(`` -!bsys1 bsys2. - (bsys1.bsst_status <> bsys2.bsst_status) ==> - (bsys1 <> bsys2) -``, - SIMP_TAC (std_ss++birs_state_ss) [] -); + val birs_state_NEQ_pc_thm = prove(`` + !bsys1 bsys2. + (bsys1.bsst_pc <> bsys2.bsst_pc) ==> + (bsys1 <> bsys2) + ``, + SIMP_TAC (std_ss++birs_state_ss) [] + ); + val birs_state_NEQ_pcond_thm = prove(`` + !bsys1 bsys2. + (bsys1.bsst_pcond <> bsys2.bsst_pcond) ==> + (bsys1 <> bsys2) + ``, + SIMP_TAC (std_ss++birs_state_ss) [] + ); + val birs_state_NEQ_status_thm = prove(`` + !bsys1 bsys2. + (bsys1.bsst_status <> bsys2.bsst_status) ==> + (bsys1 <> bsys2) + ``, + SIMP_TAC (std_ss++birs_state_ss) [] + ); fun try_prove_birs_state_try_justify_assumptions t = if (is_neg o concl) t orelse @@ -227,71 +222,111 @@ val birs_state_NEQ_status_thm = prove(`` (REWRITE_RULE [assmpt_thm] t) end; -fun try_prove_birs_state_NEQ bsys1_tm bsys2_tm = - let - val thms = [birs_state_NEQ_pc_thm, birs_state_NEQ_pcond_thm, birs_state_NEQ_status_thm]; - val t = hd thms; - fun foldfun (t, r_o) = - if isSome r_o then - r_o + fun try_prove_birs_state_NEQ bsys1_tm bsys2_tm = + let + val thms = [birs_state_NEQ_pc_thm, birs_state_NEQ_pcond_thm, birs_state_NEQ_status_thm]; + val t = hd thms; + fun foldfun (t, r_o) = + if isSome r_o then + r_o + else + (*val t = (SPECL [bsys1_tm, bsys2_tm] t);*) + SOME (try_prove_birs_state_try_justify_assumptions (SPECL [bsys1_tm, bsys2_tm] t)) + handle _ => NONE; + val neq_t_o = List.foldl foldfun NONE thms; + in + if isSome neq_t_o then + valOf neq_t_o else - (*val t = (SPECL [bsys1_tm, bsys2_tm] t);*) - SOME (try_prove_birs_state_try_justify_assumptions (SPECL [bsys1_tm, bsys2_tm] t)) - handle _ => NONE; - val neq_t_o = List.foldl foldfun NONE thms; - in - if isSome neq_t_o then - valOf neq_t_o - else - (print "\ncould not show inequality of the states, would need to check the environments\n"; - raise ERR "try_prove_birs_state_NEQ" "could not show inequality of the states, would need to check the environments") - end; - -fun birs_state_EQ_CONV tm = - IFC - (CHANGED_CONV (REWRITE_CONV [])) - (fn tm => (print "syntactically equal, done!\n"; REFL tm)) - (fn tm => - let - val (bsys1_tm, bsys2_tm) = dest_eq tm; - val neq_t = try_prove_birs_state_NEQ bsys1_tm bsys2_tm; - in - REWRITE_CONV [neq_t] tm - end) - tm; + (print "\ncould not show inequality of the states, would need to check the environments\n"; + raise ERR "try_prove_birs_state_NEQ" "could not show inequality of the states, would need to check the environments") + end; + fun birs_state_EQ_CONV tm = + IFC + (CHANGED_CONV (REWRITE_CONV [])) + (fn tm => (print "syntactically equal, done!\n"; REFL tm)) + (fn tm => + let + val (bsys1_tm, bsys2_tm) = dest_eq tm; + val neq_t = try_prove_birs_state_NEQ bsys1_tm bsys2_tm; + in + REWRITE_CONV [neq_t] tm + end) + tm; (* ---------------------------------------------------------------------------------- *) -(* set operation for composition, using the state equality checker above *) +(* labelset operations *) (* ---------------------------------------------------------------------------------- *) + val labelset_UNION_CONV = + (* TODO: this has to be fixed as list of address spaces that can be merged and so on... + (can we make this only involve the block label part, not the block index?) *) + EVAL; - fun DIFF_UNION_CONV_cheat tm = - let - val pat_tm = ``(Pi_a) DIFF {sys_b} UNION (Pi_b)``; - val (tm_match, ty_match) = match_term pat_tm tm; - - val Pi_a = pred_setSyntax.strip_set(subst tm_match (inst ty_match ``Pi_a:birs_state_t->bool``)); - val sys_b = subst tm_match (inst ty_match ``sys_b:birs_state_t``); - val Pi_b = pred_setSyntax.strip_set(subst tm_match (inst ty_match ``Pi_b:birs_state_t->bool``)); - - fun eq_fun sys1 sys2 = identical sys1 sys2; (* TODO: birs_state_eq_fun*) - fun in_f l x = List.foldr (fn (y, b) => b orelse eq_fun x y) false l; - val Pi_a_minus_b = List.filter (not o eq_fun sys_b) Pi_a; - fun UNION_foldfun (sys,Pi) = if in_f Pi sys then Pi else (sys::Pi); - val Pi_c = List.foldr UNION_foldfun Pi_a_minus_b Pi_b; - val tm_l_set = if List.null Pi_c then pred_setSyntax.mk_empty (``:birs_state_t``) else pred_setSyntax.mk_set Pi_c; - in - prove(``^tm = ^tm_l_set``, cheat) - end; +(* ---------------------------------------------------------------------------------- *) +(* faster set operations for bir variable sets (for example for: computing freevarset, symbexec composition, merging, etc) *) +(* ---------------------------------------------------------------------------------- *) + (* TODO: this should go to auxTheory *) + val simplerewrite_thm = prove(`` + !s t g. + g INTER (s DIFF t) = + s INTER (g DIFF t) + ``, + METIS_TAC [pred_setTheory.INTER_COMM, pred_setTheory.DIFF_INTER] + ); - val speedcheat_diffunion = ref false; - val birs_state_DIFF_UNION_CONV = - if !speedcheat_diffunion then - DIFF_UNION_CONV_cheat - else - REWRITE_CONV [GSYM DELETE_DEF] THENC - LAND_CONV (pred_setLib.DELETE_CONV birs_state_EQ_CONV) THENC - pred_setLib.UNION_CONV birs_state_EQ_CONV; + (* A INTER (B DIFF C) *) + fun varset_INTER_DIFF_CONV tm = + ( + (* TODO: was this a good thing for composition when there are many unused/unchanged symbols around? *) + (*REWRITE_CONV [Once (simplerewrite_thm)] THENC*) + + (* first DIFF *) (* DIFF_INSERT_CONV??? *) + (RAND_CONV + (DIFF_CONV varset_EQ_CONV)) THENC + + (* then INTER *) (* TODO: RAND_CONV should not be needed here. something is wrong *) + INTER_INSERT_CONV (RAND_CONV varset_EQ_CONV) + + (* + THENC (fn tm => (if false then print ".\n" else print_term tm; print "aa\n\n"; REFL tm)) + *) + ) tm; + + + +(* ---------------------------------------------------------------------------------- *) +(* set operation for composition, using the state equality checker above *) +(* ---------------------------------------------------------------------------------- *) + (* TODO: fix this *) + fun birs_state_eq_fun_cheat sys1 sys2 = identical sys1 sys2; + + fun DIFF_UNION_CONV_cheat tm = + let + val pat_tm = ``(Pi_a) DIFF {sys_b} UNION (Pi_b)``; + val (tm_match, ty_match) = match_term pat_tm tm; + + val Pi_a = pred_setSyntax.strip_set(subst tm_match (inst ty_match ``Pi_a:birs_state_t->bool``)); + val sys_b = subst tm_match (inst ty_match ``sys_b:birs_state_t``); + val Pi_b = pred_setSyntax.strip_set(subst tm_match (inst ty_match ``Pi_b:birs_state_t->bool``)); + + fun in_f l x = List.foldr (fn (y, b) => b orelse birs_state_eq_fun_cheat x y) false l; + val Pi_a_minus_b = List.filter (not o birs_state_eq_fun_cheat sys_b) Pi_a; + fun UNION_foldfun (sys,Pi) = if in_f Pi sys then Pi else (sys::Pi); + val Pi_c = List.foldr UNION_foldfun Pi_a_minus_b Pi_b; + val tm_l_set = if List.null Pi_c then pred_setSyntax.mk_empty (``:birs_state_t``) else pred_setSyntax.mk_set Pi_c; + in + prove(``^tm = ^tm_l_set``, cheat) + end; + + val speedcheat_stateset_diffunion = ref false; + val birs_state_DIFF_UNION_CONV = + if !speedcheat_stateset_diffunion then + DIFF_UNION_CONV_cheat + else + REWRITE_CONV [GSYM DELETE_DEF] THENC + LAND_CONV (pred_setLib.DELETE_CONV birs_state_EQ_CONV) THENC + pred_setLib.UNION_CONV birs_state_EQ_CONV; end (* local *) diff --git a/src/tools/symbexec/bir_vars_ofLib.sml b/src/tools/symbexec/bir_vars_ofLib.sml index d3b6b0ec6..ea10731d9 100644 --- a/src/tools/symbexec/bir_vars_ofLib.sml +++ b/src/tools/symbexec/bir_vars_ofLib.sml @@ -41,7 +41,191 @@ in (* local *) (* ---------------------------------------------------------------------------------- *) (* symbols of set of symbolic states *) (* ---------------------------------------------------------------------------------- *) + val debug_conv = (fn tm => (print_term tm; raise Fail "abcdE!!!")); + val debug_conv2 = (fn tm => (if true then print ".\n" else print_term tm; REFL tm)); + (* + REPEATC + (SIMP_CONV (std_ss) []) THENC + (ONCE_DEPTH_CONV ( (PAT_CONV ``\A. if A then B else (C)`` (REWRITE_CONV [pred_setTheory.COMPONENT] THENC SIMP_CONV std_ss [pred_setTheory.IN_INSERT])))) THENC + SIMP_CONV (std_ss) [] + *) + + (* ................................................ *) + + fun string_in_set_CONV tm = + ( + REWRITE_CONV [pred_setTheory.NOT_IN_EMPTY] THENC + REPEATC (CHANGED_CONV ((fn xyz => REWRITE_CONV [Once pred_setTheory.IN_INSERT] xyz) THENC + IFC + (RATOR_CONV EVAL) + (BETA_CONV THENC REWRITE_CONV [pred_setTheory.NOT_IN_EMPTY]) + REFL)) + ) tm; + + fun birs_exps_of_senv_COMP_ONCE_CONV tm = + ( + (QCHANGED_CONV (CHANGED_CONV (fn x => REWRITE_CONV [Once birs_exps_of_senv_COMP_thm] x))) THENC + IFC + (RATOR_CONV (RATOR_CONV (RAND_CONV (string_in_set_CONV)))) + (REWRITE_CONV []) + (REFL) + ) tm; + + (* TODO: add proper exceptions/exception messages if the unexpected happens... *) + fun birs_exps_of_senv_COMP_CONV_cheat tm = + let + val (s1, s2_l) = strip_comb tm; + val _ = if ((fst o dest_const) s1) = "birs_exps_of_senv_COMP" then () else + raise ERR "birs_exps_of_senv_COMP_CONV_cheat" "constant not found"; + val _ = if length s2_l = 2 then () else + raise ERR "birs_exps_of_senv_COMP_CONV_cheat" "application not right"; + val initvarset = List.nth(s2_l, 0); + val _ = if pred_setSyntax.is_empty initvarset then () else + raise ERR "birs_exps_of_senv_COMP_CONV_cheat" "must start with empty set"; + + val tm_map = List.nth(s2_l, 1); + + fun eq_fun tm1 tm2 = tm1 = tm2; + fun in_f l x = List.foldr (fn (y, b) => b orelse eq_fun x y) false l; + + val base_term = ``(K NONE):string -> bir_exp_t option``; + fun collectfun excl acc tm_map = + if identical tm_map base_term then acc else + if not (combinSyntax.is_update_comb tm_map) then raise ERR "birs_exps_of_senv_COMP_CONV_cheat" "should not happen" else + let + val ((mem_upd_k, mem_upd_v), tm_map_sub) = combinSyntax.dest_update_comb tm_map; + val mem_upd_v_v = optionSyntax.dest_some mem_upd_v; + val mem_upd_k_s = stringSyntax.fromHOLstring mem_upd_k; + val k_s_is_excl = in_f excl mem_upd_k_s; + val new_acc = if k_s_is_excl then (acc) else ([mem_upd_v_v]@acc); + val new_excl = if k_s_is_excl then (excl) else ([mem_upd_k_s]@excl); + in + collectfun new_excl new_acc tm_map_sub + end; + + (* + val s1_l = pred_setSyntax.strip_set s1; + val s2_l = pred_setSyntax.strip_set s2; + List.foldr (fn (x, l) => if not (in_f s2_l x) then x::l else l) [] s1_l; + *) + + val l = collectfun [] [] tm_map; + val tm_l_set = if List.null l then pred_setSyntax.mk_empty(``:bir_exp_t``) else pred_setSyntax.mk_set l; + in + mk_oracle_thm "FISHY_BIRS_BIR_SENV_VARSET" ([], mk_eq (tm, tm_l_set)) + end; + + fun birs_exps_of_senv_COMP_CONV_norm tm = + ( + (*(fn tm => (if false then print ".\n" else print_term tm; REFL tm)) THENC*) + (* (fn tm => (if true then print ".\n" else print_term tm; REFL tm)) THENC *) + (* + if pred_setSyntax.is_empty tm then + REFL + else + *) + IFC + (birs_exps_of_senv_COMP_ONCE_CONV) + (TRY_CONV (fn tm => ( + if pred_setSyntax.is_empty tm then + REFL + else if pred_setSyntax.is_insert tm then + RAND_CONV birs_exps_of_senv_COMP_CONV_norm + else + birs_exps_of_senv_COMP_CONV_norm + ) tm)) + (fn tm => (print_term tm; raise Fail "unexpected here: birs_exps_of_senv_COMP_CONV_norm")) + ) tm; + + val speedcheat_expsofenv = ref false; + val birs_exps_of_senv_COMP_CONV = + if !speedcheat_expsofenv then + birs_exps_of_senv_COMP_CONV_cheat + else + birs_exps_of_senv_COMP_CONV_norm; + + + fun birs_exps_of_senv_CONV tm = + ( + (* + (fn tm => (if false then print ".\n" else print_term tm; REFL tm)) THENC + *) + REWRITE_CONV [birs_exps_of_senv_thm] THENC + ((*TRY_CONV*) birs_exps_of_senv_COMP_CONV) + ) tm; + + fun birs_symb_symbols_DIRECT_CONV tm = + if not (is_birs_symb_symbols tm) then + raise ERR "birs_symb_symbols_DIRECT_CONV" "cannot handle term" + else + ( + SIMP_CONV std_ss [birs_gen_env_thm, birs_gen_env_NULL_thm] THENC + SIMP_CONV (std_ss++birs_state_ss) [birs_symb_symbols_thm] THENC + debug_conv2 THENC + birs_auxLib.GEN_match_conv is_birs_exps_of_senv birs_exps_of_senv_CONV THENC + debug_conv2 THENC + REWRITE_CONV [pred_setTheory.IMAGE_INSERT, pred_setTheory.IMAGE_EMPTY] THENC + bir_vars_of_exp_CONV THENC + + debug_conv2 THENC + RATOR_CONV (RAND_CONV (REWRITE_CONV [pred_setTheory.BIGUNION_INSERT, pred_setTheory.BIGUNION_EMPTY])) THENC + + REWRITE_CONV [Once pred_setTheory.UNION_COMM] THENC + REWRITE_CONV [pred_setTheory.UNION_ASSOC, pred_setTheory.INSERT_UNION_EQ, pred_setTheory.UNION_EMPTY] + ) tm; + val birs_symb_symbols_DIRECT_CONV = aux_moveawayLib.wrap_cache_result Term.compare birs_symb_symbols_DIRECT_CONV; + + val birs_symb_symbols_CONV = + birs_auxLib.GEN_match_conv is_birs_symb_symbols birs_symb_symbols_DIRECT_CONV; + + +(* ---------------------------------------------------------------------------------- *) +(* symbols of set of symbolic bir states *) +(* ---------------------------------------------------------------------------------- *) + fun birs_symb_symbols_set_DIRECT_CONV tm = + if not (is_birs_symb_symbols_set tm) then + raise ERR "birs_symb_symbols_set_DIRECT_CONV" "cannot handle term" + else + ( + SIMP_CONV (std_ss) [birs_rulesTheory.birs_symb_symbols_set_def] THENC + computeLib.RESTR_EVAL_CONV [``birs_symb_symbols``, ``$BIGUNION``] THENC + birs_symb_symbols_CONV THENC + + REWRITE_CONV [pred_setTheory.BIGUNION_INSERT, pred_setTheory.BIGUNION_EMPTY] THENC + REWRITE_CONV [pred_setTheory.UNION_ASSOC, pred_setTheory.INSERT_UNION_EQ, pred_setTheory.UNION_EMPTY] + ) tm; + val birs_symb_symbols_set_DIRECT_CONV = aux_moveawayLib.wrap_cache_result Term.compare birs_symb_symbols_set_DIRECT_CONV; + + val birs_symb_symbols_set_CONV = + birs_auxLib.GEN_match_conv is_birs_symb_symbols_set birs_symb_symbols_set_DIRECT_CONV; + + +(* ---------------------------------------------------------------------------------- *) +(* free symbols of execution structure (sys, L, Pi) *) +(* ---------------------------------------------------------------------------------- *) + fun birs_freesymbs_DIRECT_CONV tm = + if not (is_birs_freesymbs tm) then + raise ERR "birs_freesymbs_DIRECT_CONV" "cannot handle term" + else + ( + SIMP_CONV (std_ss) [birs_rulesTheory.birs_freesymbs_def] THENC + LAND_CONV (birs_symb_symbols_set_DIRECT_CONV) THENC + RAND_CONV (birs_symb_symbols_DIRECT_CONV) + (* TODO: EVAL (* var set DIFF *) *) + ) tm; + val birs_freesymbs_DIRECT_CONV = aux_moveawayLib.wrap_cache_result Term.compare birs_freesymbs_DIRECT_CONV; + + val birs_freesymbs_CONV = + birs_auxLib.GEN_match_conv is_birs_freesymbs birs_freesymbs_DIRECT_CONV; + +end (* local *) + +end (* struct *) + +(* ---------------------------------------------------------------------------------- *) +(* TEST CASE FOR: symbols of set of symbolic states *) +(* ---------------------------------------------------------------------------------- *) (* COPIED FROM TRANSFER-TEST (and modified) *) (* val tm = `` @@ -332,185 +516,3 @@ birs_exps_of_senv_COMP {"tmp_SP_process"} ``; *) - -val debug_conv = (fn tm => (print_term tm; raise Fail "abcdE!!!")); -val debug_conv2 = (fn tm => (if true then print ".\n" else print_term tm; REFL tm)); - -(* -REPEATC - (SIMP_CONV (std_ss) []) THENC - (ONCE_DEPTH_CONV ( (PAT_CONV ``\A. if A then B else (C)`` (REWRITE_CONV [pred_setTheory.COMPONENT] THENC SIMP_CONV std_ss [pred_setTheory.IN_INSERT])))) THENC - SIMP_CONV (std_ss) [] -*) - -(* ................................................ *) - -fun string_in_set_CONV tm = -( - REWRITE_CONV [pred_setTheory.NOT_IN_EMPTY] THENC - REPEATC (CHANGED_CONV ((fn xyz => REWRITE_CONV [Once pred_setTheory.IN_INSERT] xyz) THENC - IFC - (RATOR_CONV EVAL) - (BETA_CONV THENC REWRITE_CONV [pred_setTheory.NOT_IN_EMPTY]) - REFL)) -) tm; - -fun birs_exps_of_senv_COMP_ONCE_CONV tm = -( - (QCHANGED_CONV (CHANGED_CONV (fn x => REWRITE_CONV [Once birs_exps_of_senv_COMP_thm] x))) THENC - IFC - (RATOR_CONV (RATOR_CONV (RAND_CONV (string_in_set_CONV)))) - (REWRITE_CONV []) - (REFL) -) tm; - -(* TODO: add proper exceptions/exception messages if the unexpected happens... *) -fun birs_exps_of_senv_COMP_CONV_cheat tm = - let - val (s1, s2_l) = strip_comb tm; - val _ = if ((fst o dest_const) s1) = "birs_exps_of_senv_COMP" then () else - raise ERR "birs_exps_of_senv_COMP_CONV_cheat" "constant not found"; - val _ = if length s2_l = 2 then () else - raise ERR "birs_exps_of_senv_COMP_CONV_cheat" "application not right"; - val initvarset = List.nth(s2_l, 0); - val _ = if pred_setSyntax.is_empty initvarset then () else - raise ERR "birs_exps_of_senv_COMP_CONV_cheat" "must start with empty set"; - - val tm_map = List.nth(s2_l, 1); - - fun eq_fun tm1 tm2 = tm1 = tm2; - fun in_f l x = List.foldr (fn (y, b) => b orelse eq_fun x y) false l; - - val base_term = ``(K NONE):string -> bir_exp_t option``; - fun collectfun excl acc tm_map = - if identical tm_map base_term then acc else - if not (combinSyntax.is_update_comb tm_map) then raise ERR "birs_exps_of_senv_COMP_CONV_cheat" "should not happen" else - let - val ((mem_upd_k, mem_upd_v), tm_map_sub) = combinSyntax.dest_update_comb tm_map; - val mem_upd_v_v = optionSyntax.dest_some mem_upd_v; - val mem_upd_k_s = stringSyntax.fromHOLstring mem_upd_k; - val k_s_is_excl = in_f excl mem_upd_k_s; - val new_acc = if k_s_is_excl then (acc) else ([mem_upd_v_v]@acc); - val new_excl = if k_s_is_excl then (excl) else ([mem_upd_k_s]@excl); - in - collectfun new_excl new_acc tm_map_sub - end; - -(* - val s1_l = pred_setSyntax.strip_set s1; - val s2_l = pred_setSyntax.strip_set s2; -List.foldr (fn (x, l) => if not (in_f s2_l x) then x::l else l) [] s1_l; -*) - - val l = collectfun [] [] tm_map; - val tm_l_set = if List.null l then pred_setSyntax.mk_empty(``:bir_exp_t``) else pred_setSyntax.mk_set l; - in - mk_oracle_thm "FISHY_BIRS_BIR_SENV_VARSET" ([], mk_eq (tm, tm_l_set)) - end; - -fun birs_exps_of_senv_COMP_CONV_norm tm = -( -(*(fn tm => (if false then print ".\n" else print_term tm; REFL tm)) THENC*) -(* (fn tm => (if true then print ".\n" else print_term tm; REFL tm)) THENC *) -(* - if pred_setSyntax.is_empty tm then - REFL - else -*) - IFC - (birs_exps_of_senv_COMP_ONCE_CONV) - (TRY_CONV (fn tm => ( - if pred_setSyntax.is_empty tm then - REFL - else if pred_setSyntax.is_insert tm then - RAND_CONV birs_exps_of_senv_COMP_CONV_norm - else - birs_exps_of_senv_COMP_CONV_norm - ) tm)) - (fn tm => (print_term tm; raise Fail "unexpected here: birs_exps_of_senv_COMP_CONV_norm")) -) tm; - -val speedcheat = ref false; -val birs_exps_of_senv_COMP_CONV = - if !speedcheat then - birs_exps_of_senv_COMP_CONV_cheat - else - birs_exps_of_senv_COMP_CONV_norm; - - -fun birs_exps_of_senv_CONV tm = -( -(* -(fn tm => (if false then print ".\n" else print_term tm; REFL tm)) THENC -*) - REWRITE_CONV [birs_exps_of_senv_thm] THENC - ((*TRY_CONV*) birs_exps_of_senv_COMP_CONV) -) tm; - -fun birs_symb_symbols_DIRECT_CONV tm = - if not (is_birs_symb_symbols tm) then - raise ERR "birs_symb_symbols_DIRECT_CONV" "cannot handle term" - else - ( - SIMP_CONV std_ss [birs_gen_env_thm, birs_gen_env_NULL_thm] THENC - SIMP_CONV (std_ss++birs_state_ss) [birs_symb_symbols_thm] THENC - debug_conv2 THENC - birs_auxLib.GEN_match_conv is_birs_exps_of_senv birs_exps_of_senv_CONV THENC - debug_conv2 THENC - REWRITE_CONV [pred_setTheory.IMAGE_INSERT, pred_setTheory.IMAGE_EMPTY] THENC - bir_vars_of_exp_CONV THENC - - debug_conv2 THENC - RATOR_CONV (RAND_CONV (REWRITE_CONV [pred_setTheory.BIGUNION_INSERT, pred_setTheory.BIGUNION_EMPTY])) THENC - - REWRITE_CONV [Once pred_setTheory.UNION_COMM] THENC - REWRITE_CONV [pred_setTheory.UNION_ASSOC, pred_setTheory.INSERT_UNION_EQ, pred_setTheory.UNION_EMPTY] - ) tm; -val birs_symb_symbols_DIRECT_CONV = aux_moveawayLib.wrap_cache_result Term.compare birs_symb_symbols_DIRECT_CONV; - -val birs_symb_symbols_CONV = - birs_auxLib.GEN_match_conv is_birs_symb_symbols birs_symb_symbols_DIRECT_CONV; - - -(* ---------------------------------------------------------------------------------- *) -(* symbols of set of symbolic bir states *) -(* ---------------------------------------------------------------------------------- *) -fun birs_symb_symbols_set_DIRECT_CONV tm = - if not (is_birs_symb_symbols_set tm) then - raise ERR "birs_symb_symbols_set_DIRECT_CONV" "cannot handle term" - else - ( - SIMP_CONV (std_ss) [birs_rulesTheory.birs_symb_symbols_set_def] THENC - computeLib.RESTR_EVAL_CONV [``birs_symb_symbols``, ``$BIGUNION``] THENC - birs_symb_symbols_CONV THENC - - REWRITE_CONV [pred_setTheory.BIGUNION_INSERT, pred_setTheory.BIGUNION_EMPTY] THENC - REWRITE_CONV [pred_setTheory.UNION_ASSOC, pred_setTheory.INSERT_UNION_EQ, pred_setTheory.UNION_EMPTY] - ) tm; -val birs_symb_symbols_set_DIRECT_CONV = aux_moveawayLib.wrap_cache_result Term.compare birs_symb_symbols_set_DIRECT_CONV; - -val birs_symb_symbols_set_CONV = - birs_auxLib.GEN_match_conv is_birs_symb_symbols_set birs_symb_symbols_set_DIRECT_CONV; - - -(* ---------------------------------------------------------------------------------- *) -(* free symbols of execution structure (sys, L, Pi) *) -(* ---------------------------------------------------------------------------------- *) -fun birs_freesymbs_DIRECT_CONV tm = - if not (is_birs_freesymbs tm) then - raise ERR "birs_freesymbs_DIRECT_CONV" "cannot handle term" - else - ( - SIMP_CONV (std_ss) [birs_rulesTheory.birs_freesymbs_def] THENC - LAND_CONV (birs_symb_symbols_set_DIRECT_CONV) THENC - RAND_CONV (birs_symb_symbols_DIRECT_CONV) - (* TODO: EVAL (* var set DIFF *) *) - ) tm; -val birs_freesymbs_DIRECT_CONV = aux_moveawayLib.wrap_cache_result Term.compare birs_freesymbs_DIRECT_CONV; - -val birs_freesymbs_CONV = - birs_auxLib.GEN_match_conv is_birs_freesymbs birs_freesymbs_DIRECT_CONV; - -end (* local *) - -end (* struct *) diff --git a/src/tools/symbexec/birs_composeLib.sml b/src/tools/symbexec/birs_composeLib.sml index cddd7d333..9b1b2a2a1 100644 --- a/src/tools/symbexec/birs_composeLib.sml +++ b/src/tools/symbexec/birs_composeLib.sml @@ -5,221 +5,91 @@ local open HolKernel Parse boolLib bossLib; - - (* error handling *) - val libname = "bir_symb_composeLib" - val ERR = Feedback.mk_HOL_ERR libname - val wrap_exn = Feedback.wrap_exn libname - -(* -open symb_recordTheory; -open symb_prop_transferTheory; -open bir_symbTheory; - -open bir_symb_sound_coreTheory; -open HolBACoreSimps; -open symb_interpretTheory; -open pred_setTheory; -*) open bir_vars_ofLib; open birsSyntax; open birs_auxTheory; val birs_state_ss = rewrites (type_rws ``:birs_state_t``); + (* error handling *) + val libname = "bir_symb_composeLib" + val ERR = Feedback.mk_HOL_ERR libname + val wrap_exn = Feedback.wrap_exn libname + in -(* TODO: this should go to auxTheory *) -val simplerewrite_thm = prove(`` -!s t g. -g INTER (s DIFF t) = -s INTER (g DIFF t) -``, -(*REWRITE_RULE [Once pred_setTheory.INTER_COMM] pred_setTheory.DIFF_INTER*) -METIS_TAC [pred_setTheory.INTER_COMM, pred_setTheory.DIFF_INTER] -); - -fun freevarset_CONV tm = -( - (*REWRITE_CONV [Once (simplerewrite_thm)] THENC*) (* TODO: was this a good thing for composition when there are many unused/unchanged symbols around? *) - - (RAND_CONV ( - aux_setLib.DIFF_CONV EVAL - )) THENC - - (* then INTER *) - aux_setLib.INTER_INSERT_CONV -) tm; - -(* -fun freevarset_CONV tm = -( - REWRITE_CONV [Once (prove(`` -!s t g. -g INTER (s DIFF t) = -s INTER (g DIFF t) -``, -(*REWRITE_RULE [Once pred_setTheory.INTER_COMM] pred_setTheory.DIFF_INTER*) -METIS_TAC [pred_setTheory.INTER_COMM, pred_setTheory.DIFF_INTER] -))] THENC - - (* DIFF first *) -(* - RATOR_CONV (RAND_CONV (SIMP_CONV (std_ss++HolBACoreSimps.holBACore_ss++string_ss) [pred_setTheory.INSERT_INTER, pred_setTheory.INTER_EMPTY])) THENC -*) - (* RATOR_CONV (RAND_CONV (INTER_INSERT_CONV)) THENC*) - (RAND_CONV ( -(* - (fn tm => prove (``^tm = EMPTY``, cheat)) -*) - aux_setLib.DIFF_INSERT_CONV -)) THENC -(* -(fn tm => (if false then print ".\n" else print_term tm; print "aa\n\n"; REFL tm)) THENC -*) - - - - (* then INTER *) - aux_setLib.INTER_INSERT_CONV -) tm; - -(* EVAL tm *) -*) - -(* first prepare the SEQ rule for prog *) -fun birs_rule_SEQ_prog_fun bprog_tm = + (* first prepare the SEQ rule for prog *) + fun birs_rule_SEQ_prog_fun bprog_tm = (ISPEC (bprog_tm) birs_rulesTheory.birs_rule_SEQ_gen_thm, bprog_tm); -(* symbol freedom helper function *) -(* has to solve this ((birs_symb_symbols bsys_A) INTER (birs_freesymbs bsys_B bPi_B) = EMPTY) *) -(* TODO: probably should remove the parameter freesymbols_B_thm_o, because obsolete since we have a special STEP_SEQ rule *) -val speedcheat = ref false; -fun birs_rule_SEQ_free_symbols_fun freesymbols_tm freesymbols_B_thm_o = - let - + (* symbol freedom helper function *) + (* has to solve this ((birs_symb_symbols bsys_A) INTER (birs_freesymbs bsys_B bPi_B) = EMPTY) *) + val speedcheat_SEQ_freesymbcheck = ref false; + fun birs_rule_SEQ_INTER_freesymbs_fun freesymbols_tm = + let val freesymbols_thm = prove(freesymbols_tm, - (if !speedcheat then cheat else ALL_TAC) >> - (case freesymbols_B_thm_o of - NONE => ALL_TAC - | SOME freesymbols_B_thm => (print_thm freesymbols_B_thm; raise ERR "" ""; REWRITE_TAC [freesymbols_B_thm, pred_setTheory.INTER_EMPTY])) >> + (if !speedcheat_SEQ_freesymbcheck then cheat else ALL_TAC) >> CONV_TAC (LAND_CONV (LAND_CONV (birs_symb_symbols_DIRECT_CONV))) >> CONV_TAC (LAND_CONV (RAND_CONV (birs_freesymbs_DIRECT_CONV))) >> (* now have A INTER (B DIFF C) = EMPTY*) -(* + (* (fn (al,g) => (print_term g; ([(al,g)], fn ([t]) => t))) >> -*) - (fn (al,g) => (print "starting to proof free symbols\n"; ([(al,g)], fn ([t]) => t))) >> - - CONV_TAC (RATOR_CONV (RAND_CONV (freevarset_CONV))) >> - (fn (al,g) => (print "finished to proof free symbols operation\n"; ([(al,g)], fn ([t]) => t))) >> + (fn x => (print "starting to compute concrete set of free symbols\n"; ALL_TAC x)) >> + *) + CONV_TAC (LAND_CONV (aux_setLib.varset_INTER_DIFF_CONV)) >> REWRITE_TAC [pred_setTheory.EMPTY_SUBSET] - >> (fn (al,g) => (print "finished to proof free symbols\n"; ([(al,g)], fn ([t]) => t))) - -(* - EVAL_TAC (* TODO: speed this up... *) -*) - -(* - FULL_SIMP_TAC (std_ss) [pred_setTheory.IMAGE_INSERT, pred_setTheory.IMAGE_EMPTY] >> - FULL_SIMP_TAC (std_ss++birs_state_ss) [birs_symb_symbols_thm] >> - - CONV_TAC (conv) >> - REPEAT ( - CHANGED_TAC ( fn xyz => - REWRITE_TAC [Once (prove(``!x. (IMAGE bir_vars_of_exp x) = I (IMAGE bir_vars_of_exp x)``, REWRITE_TAC [combinTheory.I_THM]))] - xyz - ) >> - CONV_TAC (GEN_match_conv combinSyntax.is_I (RAND_CONV birs_exps_of_senv_CONV)) - ) >> - - EVAL_TAC -*) -(* - CONV_TAC (conv) - CONV_TAC (fn tm => (print_term tm; REFL tm)) - CONV_TAC (DEPTH_CONV (PAT_CONV ``\A. (I:((bir_var_t->bool)->bool)->((bir_var_t->bool)->bool)) A`` (fn tm => (print_term tm; raise Fail "abcdE!!!")))) - - - -(combinSyntax.is_I o snd o dest_comb) tm - - - - - - CONV_TAC (ONCE_DEPTH_CONV (PAT_CONV ``\A. IMAGE bir_vars_of_exp A`` (birs_exps_of_senv_CONV))) - - -FULL_SIMP_TAC (std_ss++pred_setLib.PRED_SET_ss) [] - EVAL_TAC - - CONV_TAC (PAT_CONV ``\A. (A DIFF C)`` (conv)) - - - - - - FULL_SIMP_TAC (std_ss++birs_state_ss) [birs_exps_of_senv_thm, birs_exps_of_senv_COMP_thm] >> - - EVAL_TAC - (* - FULL_SIMP_TAC (std_ss++pred_setLib.PRED_SET_ss) [pred_setTheory.GSPECIFICATION] - *) -*) ); - in + in freesymbols_thm - end; - -(* -val step_A_thm = single_step_A_thm; -val step_B_thm = single_step_B_thm; -val freesymbols_B_thm_o = SOME (prove(T, cheat)); -*) -fun birs_rule_SEQ_fun (birs_rule_SEQ_thm, bprog_tm) step_A_thm step_B_thm freesymbols_B_thm_o = - let - val (bprog_A_tm,_) = (dest_birs_symb_exec o concl) step_A_thm; - val (bprog_B_tm,_) = (dest_birs_symb_exec o concl) step_B_thm; - val _ = if identical bprog_tm bprog_A_tm andalso identical bprog_tm bprog_B_tm then () else - raise Fail "birs_rule_SEQ_fun:: the programs have to match"; - - val prep_thm = - HO_MATCH_MP (HO_MATCH_MP birs_rule_SEQ_thm step_A_thm) step_B_thm; - - val freesymbols_tm = (fst o dest_imp o concl) prep_thm; - val freesymbols_thm = birs_rule_SEQ_free_symbols_fun freesymbols_tm freesymbols_B_thm_o; - val _ = print "finished to proof free symbols altogether\n"; - - val bprog_composed_thm = - (MATCH_MP - prep_thm - freesymbols_thm); - val _ = print "composed\n"; - - (* tidy up set operations to not accumulate (in both, post state set and label set) *) - fun Pi_CONV conv tm = - RAND_CONV (RAND_CONV (conv handle e => (print "\n\nPi_CONV failed\n\n"; raise e))) tm; - fun L_CONV conv tm = - RAND_CONV (LAND_CONV (conv handle e => (print "\n\nL_CONV failed\n\n"; raise e))) tm; - - val bprog_Pi_fixed_thm = CONV_RULE (RAND_CONV (Pi_CONV aux_setLib.birs_state_DIFF_UNION_CONV)) bprog_composed_thm; - - val bprog_L_fixed_thm = CONV_RULE (RAND_CONV (L_CONV ( - EVAL - (* TODO: this has to be fixed as list of address spaces that can be merged and so on... - (can we make this only involve the block label part, not the block index?) *) - ))) bprog_Pi_fixed_thm; - - val _ = if symb_sound_struct_is_normform (concl bprog_L_fixed_thm) then () else - (print_term (concl bprog_L_fixed_thm); - raise ERR "birs_rule_SEQ_fun" "something is not right, the produced theorem is not evaluated enough"); - in - bprog_L_fixed_thm - end; + end; + + fun tidyup_birs_symb_exec_CONV stateset_conv labelset_conv = + let + val struct_CONV = + RAND_CONV; + fun Pi_CONV conv = + RAND_CONV (RAND_CONV conv); + fun L_CONV conv = + RAND_CONV (LAND_CONV conv); + in + struct_CONV (Pi_CONV stateset_conv) THENC + struct_CONV (L_CONV labelset_conv) + end; + + (* + val step_A_thm = single_step_A_thm; + val step_B_thm = single_step_B_thm; + *) + fun birs_rule_SEQ_fun (birs_rule_SEQ_thm, bprog_tm) step_A_thm step_B_thm = + let + val (bprog_A_tm,_) = (dest_birs_symb_exec o concl) step_A_thm; + val (bprog_B_tm,_) = (dest_birs_symb_exec o concl) step_B_thm; + val _ = if identical bprog_tm bprog_A_tm andalso identical bprog_tm bprog_B_tm then () else + raise Fail "birs_rule_SEQ_fun:: the programs have to match"; + + val prep_thm = + HO_MATCH_MP (HO_MATCH_MP birs_rule_SEQ_thm step_A_thm) step_B_thm; + + val freesymbols_tm = (fst o dest_imp o concl) prep_thm; + val freesymbols_thm = birs_rule_SEQ_INTER_freesymbs_fun freesymbols_tm; + val _ = print "finished to proof free symbols altogether\n"; + + val bprog_composed_thm = + (MP prep_thm freesymbols_thm); + val _ = print "composed\n"; + + (* tidy up set operations to not accumulate (in both, post state set and label set) *) + val bprog_L_fixed_thm = CONV_RULE (tidyup_birs_symb_exec_CONV aux_setLib.birs_state_DIFF_UNION_CONV aux_setLib.labelset_UNION_CONV) bprog_composed_thm; + + val _ = if symb_sound_struct_is_normform (concl bprog_L_fixed_thm) then () else + (print_term (concl bprog_L_fixed_thm); + raise ERR "birs_rule_SEQ_fun" "something is not right, the produced theorem is not evaluated enough"); + in + bprog_L_fixed_thm + end; end (* local *) diff --git a/src/tools/symbexec/birs_driveLib.sml b/src/tools/symbexec/birs_driveLib.sml index 5e29e61f3..62fc3791c 100644 --- a/src/tools/symbexec/birs_driveLib.sml +++ b/src/tools/symbexec/birs_driveLib.sml @@ -47,7 +47,7 @@ fun reduce_tree SEQ_fun_spec (Symb_Node (symbex_A_thm, [])) = symbex_A_thm | reduce_tree SEQ_fun_spec (Symb_Node (symbex_A_thm, (symbex_B_subtree::symbex_B_subtrees))) = let val symbex_B_thm = reduce_tree SEQ_fun_spec symbex_B_subtree; - val symbex_A_thm_new = SEQ_fun_spec symbex_A_thm symbex_B_thm NONE + val symbex_A_thm_new = SEQ_fun_spec symbex_A_thm symbex_B_thm handle ex => (print "\n=========================\n\n"; (print_term o concl) symbex_A_thm; @@ -105,15 +105,15 @@ fun build_tree (STEP_fun_spec, SEQ_fun_spec, STEP_SEQ_fun_spec) symbex_A_thm sto birs_is_running st andalso (not (List.exists (identical (birs_get_pc st)) stop_lbls)); val birs_states_mid = symb_sound_struct_Pi_to_birstatelist_fun Pi_A_tm; -(* + (* val birs_states_mid_running = List.filter birs_is_running birs_states_mid; -*) + *) val birs_states_mid_executable = List.filter is_executable birs_states_mid; -(* + (* val _ = print ("- have " ^ (Int.toString (length birs_states_mid)) ^ " states\n"); val _ = print (" (" ^ (Int.toString (length birs_states_mid_running)) ^ " running)\n"); val _ = print (" (" ^ (Int.toString (length birs_states_mid_executable)) ^ " executable)\n"); -*) + *) fun take_step birs_state_mid = let @@ -138,27 +138,15 @@ fun build_tree (STEP_fun_spec, SEQ_fun_spec, STEP_SEQ_fun_spec) symbex_A_thm sto val _ = print ("START sequential composition with singleton mid_state set\n"); -(* + (* val birs_state_mid = hd birs_states_mid; - val timer_exec_step_P1 = holba_miscLib.timer_start 0; + val timer_exec_step_P1 = holba_miscLib.timer_start 0; val single_step_B_thm = take_step birs_state_mid; - val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n>>> executed a whole step in " ^ delta_s ^ "\n")) timer_exec_step_P1; -*) - val timer_exec_step_P2 = holba_miscLib.timer_start 0; -(* - (* TODO: derive freesymbols EMPTY from birs *) - val (sys_B_tm, _, Pi_B_tm) = (symb_sound_struct_get_sysLPi_fun o concl) single_step_B_thm; - val freesymbols_B_thm = prove (T, cheat); - (*val freesymbols_B_thm = prove ( - ``(symb_symbols_set (bir_symb_rec_sbir ^bprog_tm) ^Pi_B_tm DIFF - symb_symbols (bir_symb_rec_sbir ^bprog_tm) ^sys_B_tm) - = EMPTY - ``, cheat);*) - (* compose together *) - val bprog_composed_thm = SEQ_fun_spec symbex_A_thm single_step_B_thm (SOME freesymbols_B_thm); -*) + val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n>>> executed a whole step in " ^ delta_s ^ "\n")) timer_exec_step_P1; + *) + val timer_exec_step_P2 = holba_miscLib.timer_start 0; val bprog_composed_thm = STEP_SEQ_fun_spec symbex_A_thm; - val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n>>> FINISH took and sequentially composed a step in " ^ delta_s ^ "\n")) timer_exec_step_P2; + val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n>>> FINISH took and sequentially composed a step in " ^ delta_s ^ "\n")) timer_exec_step_P2; in build_tree (STEP_fun_spec, SEQ_fun_spec, STEP_SEQ_fun_spec) bprog_composed_thm stop_lbls From 741b41b74c4b0a115bc5d5a43b15903736998bdd Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Tue, 1 Oct 2024 17:53:29 +0200 Subject: [PATCH 54/95] Refactor and fix more --- src/tools/symbexec/aux_setLib.sml | 81 ++++++++++++-------------- src/tools/symbexec/bir_vars_ofLib.sml | 23 ++++---- src/tools/symbexec/birs_composeLib.sml | 8 ++- 3 files changed, 56 insertions(+), 56 deletions(-) diff --git a/src/tools/symbexec/aux_setLib.sml b/src/tools/symbexec/aux_setLib.sml index b81b49af3..6b59812b6 100644 --- a/src/tools/symbexec/aux_setLib.sml +++ b/src/tools/symbexec/aux_setLib.sml @@ -35,9 +35,8 @@ in (* local *) REWRITE_CONV [pred_setTheory.NOT_IN_EMPTY] THENC REPEATC (CHANGED_CONV ( (fn xyz => REWRITE_CONV [Once pred_setTheory.IN_INSERT] xyz) THENC - (*(fn tm => (if false then print ".\n" else print_term tm; print "aa\n\n"; REFL tm)) THENC*) IFC - (RATOR_CONV el_EQ_CONV) + (LAND_CONV el_EQ_CONV) (* comparison of IN_INSERT (first conjunct) *) (REWRITE_CONV [pred_setTheory.NOT_IN_EMPTY]) REFL)) ) tm; @@ -46,14 +45,7 @@ in (* local *) ( (QCHANGED_CONV (CHANGED_CONV (fn x => REWRITE_CONV [Once pred_setTheory.INSERT_INTER, pred_setTheory.INTER_EMPTY] x))) THENC IFC - (RATOR_CONV (RATOR_CONV (RAND_CONV ( - (* - fn tm => (print_term (concl (prove (mk_eq (tm, F), cheat))); prove (mk_eq (tm, F), cheat)) - *) - (*fn tm => (prove (mk_eq (tm, F), cheat))*) - (*(fn tm => (if false then print ".\n" else print_term tm; print "aa\n\n"; REFL tm)) THENC*) - IN_INSERT_CONV el_EQ_CONV - )))) + (RATOR_CONV (RATOR_CONV (RAND_CONV (IN_INSERT_CONV el_EQ_CONV)))) (REWRITE_CONV []) (REFL) ) tm; @@ -63,16 +55,10 @@ in (* local *) if pred_setSyntax.is_empty tm then REFL else - (*(fn tm => (if true then print ".\n" else (print_term tm; print "\n\n"); REFL tm)) THENC*) IFC (INTER_INSERT_ONCE_CONV el_EQ_CONV) - ( - (* - (fn tm => (if false then print ".\n" else print_term tm; print "bb\n\n"; REFL tm)) THENC - *) - (fn tm => + (fn tm => ( - (*(fn tm => (if false then print ".\n" else print_term tm; print "bb\n\n"; REFL tm)) THENC *) (if pred_setSyntax.is_empty tm then (REFL) else if pred_setSyntax.is_inter tm then @@ -80,8 +66,8 @@ in (* local *) else if pred_setSyntax.is_insert tm then (RAND_CONV (INTER_INSERT_CONV_norm el_EQ_CONV)) else - (REFL))) tm)) - (* the following causes trouble as "normal exit" if there is nothing to be done at the first call *) + (REFL))) tm) + (* the following causes trouble as "normal exit" if there is nothing to be done at the first call *) (fn tm => (print_term tm; raise Fail "unexpected here: INTER_INSERT_CONV_norm")) ) tm; @@ -162,10 +148,29 @@ in (* local *) (print_term tm; raise ERR "DIFF_CONV" "unexpected2"); + fun UNIONs_LEFT_CONV eq_EQ_CONV tm = + (if not (pred_setSyntax.is_union tm) then + REFL + else + LAND_CONV (UNIONs_LEFT_CONV eq_EQ_CONV) THENC + pred_setLib.UNION_CONV eq_EQ_CONV) tm; + + fun BIGUNION_CONV eq_EQ_CONV = + REWRITE_CONV [ + BIGUNION_INSERT, + BIGUNION_EMPTY, + UNION_ASSOC, + UNION_EMPTY] THENC + (UNIONs_LEFT_CONV eq_EQ_CONV); (* ================================================================================== *) (* ================================================================================== *) +(* ---------------------------------------------------------------------------------- *) +(* label set equality checker *) +(* ---------------------------------------------------------------------------------- *) + val labelset_EQ_CONV = EVAL; + (* ---------------------------------------------------------------------------------- *) (* bir var set equality checker *) (* ---------------------------------------------------------------------------------- *) @@ -261,38 +266,26 @@ in (* local *) val labelset_UNION_CONV = (* TODO: this has to be fixed as list of address spaces that can be merged and so on... (can we make this only involve the block label part, not the block index?) *) - EVAL; + pred_setLib.UNION_CONV labelset_EQ_CONV; (* ---------------------------------------------------------------------------------- *) (* faster set operations for bir variable sets (for example for: computing freevarset, symbexec composition, merging, etc) *) (* ---------------------------------------------------------------------------------- *) - (* TODO: this should go to auxTheory *) - val simplerewrite_thm = prove(`` - !s t g. - g INTER (s DIFF t) = - s INTER (g DIFF t) - ``, - METIS_TAC [pred_setTheory.INTER_COMM, pred_setTheory.DIFF_INTER] - ); + val varset_BIGUNION_CONV = + BIGUNION_CONV varset_EQ_CONV; - (* A INTER (B DIFF C) *) - fun varset_INTER_DIFF_CONV tm = - ( - (* TODO: was this a good thing for composition when there are many unused/unchanged symbols around? *) - (*REWRITE_CONV [Once (simplerewrite_thm)] THENC*) + val varset_INTER_CONV = + INTER_INSERT_CONV varset_EQ_CONV; - (* first DIFF *) (* DIFF_INSERT_CONV??? *) - (RAND_CONV - (DIFF_CONV varset_EQ_CONV)) THENC - - (* then INTER *) (* TODO: RAND_CONV should not be needed here. something is wrong *) - INTER_INSERT_CONV (RAND_CONV varset_EQ_CONV) - - (* - THENC (fn tm => (if false then print ".\n" else print_term tm; print "aa\n\n"; REFL tm)) - *) - ) tm; + val varset_DIFF_CONV = + DIFF_CONV varset_EQ_CONV; (* DIFF_INSERT_CONV??? *) + (* A INTER (B DIFF C) *) + val varset_INTER_DIFF_CONV = + (* first DIFF *) + (RAND_CONV varset_DIFF_CONV) THENC + (* then INTER *) + varset_INTER_CONV; (* ---------------------------------------------------------------------------------- *) diff --git a/src/tools/symbexec/bir_vars_ofLib.sml b/src/tools/symbexec/bir_vars_ofLib.sml index ea10731d9..056070aa8 100644 --- a/src/tools/symbexec/bir_vars_ofLib.sml +++ b/src/tools/symbexec/bir_vars_ofLib.sml @@ -41,8 +41,10 @@ in (* local *) (* ---------------------------------------------------------------------------------- *) (* symbols of set of symbolic states *) (* ---------------------------------------------------------------------------------- *) + (* val debug_conv = (fn tm => (print_term tm; raise Fail "abcdE!!!")); val debug_conv2 = (fn tm => (if true then print ".\n" else print_term tm; REFL tm)); + *) (* REPEATC @@ -162,13 +164,12 @@ in (* local *) ( SIMP_CONV std_ss [birs_gen_env_thm, birs_gen_env_NULL_thm] THENC SIMP_CONV (std_ss++birs_state_ss) [birs_symb_symbols_thm] THENC - debug_conv2 THENC + birs_auxLib.GEN_match_conv is_birs_exps_of_senv birs_exps_of_senv_CONV THENC - debug_conv2 THENC + REWRITE_CONV [pred_setTheory.IMAGE_INSERT, pred_setTheory.IMAGE_EMPTY] THENC bir_vars_of_exp_CONV THENC - debug_conv2 THENC RATOR_CONV (RAND_CONV (REWRITE_CONV [pred_setTheory.BIGUNION_INSERT, pred_setTheory.BIGUNION_EMPTY])) THENC REWRITE_CONV [Once pred_setTheory.UNION_COMM] THENC @@ -188,12 +189,14 @@ in (* local *) raise ERR "birs_symb_symbols_set_DIRECT_CONV" "cannot handle term" else ( - SIMP_CONV (std_ss) [birs_rulesTheory.birs_symb_symbols_set_def] THENC - computeLib.RESTR_EVAL_CONV [``birs_symb_symbols``, ``$BIGUNION``] THENC + REWRITE_CONV [ + birs_rulesTheory.birs_symb_symbols_set_def, + pred_setTheory.IMAGE_INSERT, + pred_setTheory.IMAGE_EMPTY] THENC birs_symb_symbols_CONV THENC + (* now have A UNION B UNION C UNION ... *) - REWRITE_CONV [pred_setTheory.BIGUNION_INSERT, pred_setTheory.BIGUNION_EMPTY] THENC - REWRITE_CONV [pred_setTheory.UNION_ASSOC, pred_setTheory.INSERT_UNION_EQ, pred_setTheory.UNION_EMPTY] + aux_setLib.varset_BIGUNION_CONV ) tm; val birs_symb_symbols_set_DIRECT_CONV = aux_moveawayLib.wrap_cache_result Term.compare birs_symb_symbols_set_DIRECT_CONV; @@ -209,10 +212,10 @@ in (* local *) raise ERR "birs_freesymbs_DIRECT_CONV" "cannot handle term" else ( - SIMP_CONV (std_ss) [birs_rulesTheory.birs_freesymbs_def] THENC + REWRITE_CONV [birs_rulesTheory.birs_freesymbs_def] THENC LAND_CONV (birs_symb_symbols_set_DIRECT_CONV) THENC - RAND_CONV (birs_symb_symbols_DIRECT_CONV) - (* TODO: EVAL (* var set DIFF *) *) + RAND_CONV (birs_symb_symbols_DIRECT_CONV) THENC + aux_setLib.varset_DIFF_CONV ) tm; val birs_freesymbs_DIRECT_CONV = aux_moveawayLib.wrap_cache_result Term.compare birs_freesymbs_DIRECT_CONV; diff --git a/src/tools/symbexec/birs_composeLib.sml b/src/tools/symbexec/birs_composeLib.sml index 9b1b2a2a1..a36588f63 100644 --- a/src/tools/symbexec/birs_composeLib.sml +++ b/src/tools/symbexec/birs_composeLib.sml @@ -30,15 +30,19 @@ in val freesymbols_thm = prove(freesymbols_tm, (if !speedcheat_SEQ_freesymbcheck then cheat else ALL_TAC) >> + (* REMARK: I have seen slightly faster computation when + - reducing the formula to operations over ground variable sets in this shape: A INTER (B DIFF C) + - then turning around the set operations like this: g INTER (s DIFF t) = s INTER (g DIFF t) + - then applying the variable set operations *) CONV_TAC (LAND_CONV (LAND_CONV (birs_symb_symbols_DIRECT_CONV))) >> CONV_TAC (LAND_CONV (RAND_CONV (birs_freesymbs_DIRECT_CONV))) >> - (* now have A INTER (B DIFF C) = EMPTY*) + (* now have A INTER B = EMPTY*) (* (fn (al,g) => (print_term g; ([(al,g)], fn ([t]) => t))) >> (fn x => (print "starting to compute concrete set of free symbols\n"; ALL_TAC x)) >> *) - CONV_TAC (LAND_CONV (aux_setLib.varset_INTER_DIFF_CONV)) >> + CONV_TAC (LAND_CONV (aux_setLib.varset_INTER_CONV)) >> REWRITE_TAC [pred_setTheory.EMPTY_SUBSET] ); From 498386409b08b3d9cf0c41973c169a94b0ab9b8a Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Wed, 2 Oct 2024 09:21:25 +0200 Subject: [PATCH 55/95] Fix CI --- src/tools/symbexec/examples/test-birs_compose.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tools/symbexec/examples/test-birs_compose.sml b/src/tools/symbexec/examples/test-birs_compose.sml index 12fe17559..3a302d655 100644 --- a/src/tools/symbexec/examples/test-birs_compose.sml +++ b/src/tools/symbexec/examples/test-birs_compose.sml @@ -119,7 +119,7 @@ fun execute_two_steps bprog_tm birs_state_init_tm = (* compose together *) val birs_rule_SEQ_fun_spec = birs_rule_SEQ_fun birs_rule_SEQ_thm; - val bprog_composed_thm = birs_rule_SEQ_fun_spec single_step_A_thm single_step_B_thm NONE; + val bprog_composed_thm = birs_rule_SEQ_fun_spec single_step_A_thm single_step_B_thm; (* val birs_state_ss = rewrites (type_rws ``:birs_state_t``); From 45d3a43b38287b804be68b6ca08e2b1ad9662cd2 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Thu, 3 Oct 2024 22:51:30 +0200 Subject: [PATCH 56/95] Add functions for state merging --- src/tools/symbexec/birsSyntax.sml | 51 ++- src/tools/symbexec/birs_composeLib.sml | 18 +- src/tools/symbexec/birs_mergeLib.sml | 576 +++++++++++++++++++++++++ 3 files changed, 625 insertions(+), 20 deletions(-) create mode 100644 src/tools/symbexec/birs_mergeLib.sml diff --git a/src/tools/symbexec/birsSyntax.sml b/src/tools/symbexec/birsSyntax.sml index feeffd442..ab15c3240 100644 --- a/src/tools/symbexec/birsSyntax.sml +++ b/src/tools/symbexec/birsSyntax.sml @@ -46,6 +46,7 @@ local val syntax_fns1_set = syntax_fns 2 HolKernel.dest_monop HolKernel.mk_monop; in val (birs_gen_env_tm, mk_birs_gen_env, dest_birs_gen_env, is_birs_gen_env) = syntax_fns1_env "birs_gen_env"; + val (bir_senv_GEN_list_tm, mk_bir_senv_GEN_list, dest_bir_senv_GEN_list, is_bir_senv_GEN_list) = syntax_fns1_env "bir_senv_GEN_list"; val (birs_exps_of_senv_tm, mk_birs_exps_of_senv, dest_birs_exps_of_senv, is_birs_exps_of_senv) = syntax_fns1_set "birs_exps_of_senv"; end; @@ -171,20 +172,31 @@ fun dest_IMAGE_birs_symb_to_symbst Pi = (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) (BExp_Const (Imm64 0xFFFFFFFFFFFFFF00w)))|>``; *) - fun birs_state_is_normform tm = + fun birs_state_is_normform_gen is_start tm = is_birs_state tm andalso let + fun is_normform_birs_gen_env env = + is_birs_gen_env env andalso + (can listSyntax.dest_list o dest_birs_gen_env) env; + fun is_normform_bir_senv_GEN_list env = + is_bir_senv_GEN_list env; + val (_, env, _, _) = dest_birs_state tm; in - is_birs_gen_env env + is_normform_birs_gen_env env orelse + if not is_start then false else + is_normform_bir_senv_GEN_list env end; + + val birs_state_is_normform = birs_state_is_normform_gen false; fun is_a_normform_set tm = can pred_setSyntax.strip_set tm; fun birs_states_are_normform tm = is_a_normform_set tm andalso - (List.all birs_state_is_normform o pred_setSyntax.strip_set) tm; + ((List.all birs_state_is_normform o pred_setSyntax.strip_set) tm + handle _ => false); fun birs_state_is_normform_CONV sfun bstate_tm = @@ -207,16 +219,20 @@ fun dest_IMAGE_birs_symb_to_symbst Pi = (* extract information from a sound structure *) (* ----------------------------------------------- *) +fun mk_sysLPi (sys_tm, L_tm, Pi_tm) = + pairSyntax.list_mk_pair [sys_tm, L_tm, Pi_tm]; +fun dest_sysLPi tm = + case pairSyntax.strip_pair tm of + [sys_tm, L_tm, Pi_tm] => (sys_tm, L_tm, Pi_tm) + | _ => raise ERR "dest_sysLPi" "unexpected structure triple"; fun symb_sound_struct_get_sysLPi_fun tm = let + val _ = if is_birs_symb_exec tm then () else + raise ERR "symb_sound_struct_get_sysLPi_fun" "term must be a birs_symb_exec"; val sysLPi_tm = (snd o dest_birs_symb_exec) tm; - val res = - case pairSyntax.strip_pair sysLPi_tm of - [sys_tm, L_tm, Pi_tm] => (sys_tm, L_tm, Pi_tm) - | _ => raise ERR "symb_sound_struct_get_sysLPi_fun" "unexpected structure triple"; in - res + dest_sysLPi sysLPi_tm end; (* @@ -232,15 +248,28 @@ fun symb_sound_struct_is_normform tm = val (sys, L, Pi) = symb_sound_struct_get_sysLPi_fun tm handle _ => raise ERR "symb_sound_struct_is_normform" "unexpected term, should be a birs_symb_exec with a triple as structure"; - val sys_ok = birs_state_is_normform sys; + val sys_ok = birs_state_is_normform_gen true sys; val L_ok = is_a_normform_set L; val Pi_ok = birs_states_are_normform Pi; in sys_ok andalso L_ok andalso Pi_ok end; - - +(* check if two structures are in normform and use the same program *) +fun birs_symb_exec_check_compatible A_thm B_thm = + let + val _ = if (symb_sound_struct_is_normform o concl) A_thm then () else + raise ERR "birs_symb_exec_compatible" "theorem A is not a standard birs_symb_exec"; + val _ = if (symb_sound_struct_is_normform o concl) B_thm then () else + raise ERR "birs_symb_exec_compatible" "theorem B is not a standard birs_symb_exec"; + + val (bprog_A_tm,_) = (dest_birs_symb_exec o concl) A_thm; + val (bprog_B_tm,_) = (dest_birs_symb_exec o concl) B_thm; + val _ = if identical bprog_A_tm bprog_B_tm then () else + raise ERR "birs_symb_exec_compatible" "the programs of A and B have to match"; + in + () + end; end (* local *) diff --git a/src/tools/symbexec/birs_composeLib.sml b/src/tools/symbexec/birs_composeLib.sml index a36588f63..65ca1ce3f 100644 --- a/src/tools/symbexec/birs_composeLib.sml +++ b/src/tools/symbexec/birs_composeLib.sml @@ -20,7 +20,7 @@ in (* first prepare the SEQ rule for prog *) fun birs_rule_SEQ_prog_fun bprog_tm = - (ISPEC (bprog_tm) birs_rulesTheory.birs_rule_SEQ_gen_thm, bprog_tm); + ISPEC (bprog_tm) birs_rulesTheory.birs_rule_SEQ_gen_thm; (* symbol freedom helper function *) (* has to solve this ((birs_symb_symbols bsys_A) INTER (birs_freesymbs bsys_B bPi_B) = EMPTY) *) @@ -50,8 +50,11 @@ in freesymbols_thm end; - fun tidyup_birs_symb_exec_CONV stateset_conv labelset_conv = + fun tidyup_birs_symb_exec_CONV stateset_conv labelset_conv tm = let + val _ = if is_birs_symb_exec tm then () else + raise ERR "tidyup_birs_symb_exec_CONV" "cannot handle term"; + val struct_CONV = RAND_CONV; fun Pi_CONV conv = @@ -59,20 +62,17 @@ in fun L_CONV conv = RAND_CONV (LAND_CONV conv); in - struct_CONV (Pi_CONV stateset_conv) THENC - struct_CONV (L_CONV labelset_conv) + (struct_CONV (Pi_CONV stateset_conv) THENC + struct_CONV (L_CONV labelset_conv)) tm end; (* val step_A_thm = single_step_A_thm; val step_B_thm = single_step_B_thm; *) - fun birs_rule_SEQ_fun (birs_rule_SEQ_thm, bprog_tm) step_A_thm step_B_thm = + fun birs_rule_SEQ_fun birs_rule_SEQ_thm step_A_thm step_B_thm = let - val (bprog_A_tm,_) = (dest_birs_symb_exec o concl) step_A_thm; - val (bprog_B_tm,_) = (dest_birs_symb_exec o concl) step_B_thm; - val _ = if identical bprog_tm bprog_A_tm andalso identical bprog_tm bprog_B_tm then () else - raise Fail "birs_rule_SEQ_fun:: the programs have to match"; + val _ = birs_symb_exec_check_compatible step_A_thm step_B_thm; val prep_thm = HO_MATCH_MP (HO_MATCH_MP birs_rule_SEQ_thm step_A_thm) step_B_thm; diff --git a/src/tools/symbexec/birs_mergeLib.sml b/src/tools/symbexec/birs_mergeLib.sml new file mode 100644 index 000000000..6166293c0 --- /dev/null +++ b/src/tools/symbexec/birs_mergeLib.sml @@ -0,0 +1,576 @@ +structure birs_mergeLib = +struct + +local + + open HolKernel Parse boolLib bossLib; + + open birsSyntax; + + (* error handling *) + val libname = "birs_mergeLib" + val ERR = Feedback.mk_HOL_ERR libname + val wrap_exn = Feedback.wrap_exn libname + +in (* local *) + + (* general path condition weakening with z3 (to throw away path condition conjuncts (to remove branch path condition conjuncts)) *) + fun birs_Pi_first_pcond_RULE pcond_new thm = + let + val _ = if (symb_sound_struct_is_normform o concl) thm then () else + raise ERR "birs_Pi_first_pcond_RULE" "theorem is not a standard birs_symb_exec"; + + val (p_tm, tri_tm) = (dest_birs_symb_exec o concl) thm; + val (sys_tm,L_tm,Pi_old_tm) = dest_sysLPi tri_tm; + val (Pi_sys_old_tm, Pi_rest_tm) = pred_setSyntax.dest_insert Pi_old_tm; + + val (pc, env, status, pcond_old) = dest_birs_state Pi_sys_old_tm; + val Pi_sys_new_tm = mk_birs_state (pc, env, status, pcond_new); + val Pi_new_tm = pred_setSyntax.mk_insert (Pi_sys_new_tm, Pi_rest_tm); + + val imp_tm = mk_birs_exp_imp (pcond_old, pcond_new); + val pcond_imp_ok = isSome (birs_simpLib.check_imp_tm imp_tm); + val _ = if pcond_imp_ok then () else + (print "widening failed, path condition is not weaker\n"; + raise ERR "birs_Pi_first_pcond_RULE" "the supplied path condition is not weaker"); + (* TODO: use the bir implication theorem to justify the new theorem *) + in + mk_oracle_thm "BIRS_WIDEN_PCOND" ([], mk_birs_symb_exec (p_tm, mk_sysLPi (sys_tm,L_tm,Pi_new_tm))) + end; + + (* TODO later (instantiate): general path condition strengthening with z3 *) + fun birs_sys_pcond_RULE pcond_new thm = + let + val _ = if (symb_sound_struct_is_normform o concl) thm then () else + raise ERR "birs_sys_pcond_RULE" "theorem is not a standard birs_symb_exec"; + + val (p_tm, tri_tm) = (dest_birs_symb_exec o concl) thm; + val (sys_old_tm,L_tm,Pi_tm) = dest_sysLPi tri_tm; + + val (pc, env, status, pcond_old) = dest_birs_state sys_old_tm; + val sys_new_tm = mk_birs_state (pc, env, status, pcond_new); + + val imp_tm = mk_birs_exp_imp (pcond_new, pcond_old); + val pcond_imp_ok = isSome (birs_simpLib.check_imp_tm imp_tm); + val _ = if pcond_imp_ok then () else + (print "narrowing failed, path condition is not stronger\n"; + raise ERR "birs_sys_pcond_RULE" "the supplied path condition is not stronger"); + (* TODO: use the bir implication theorem to justify the new theorem *) + in + mk_oracle_thm "BIRS_NARROW_PCOND" ([], mk_birs_symb_exec (p_tm, mk_sysLPi (sys_new_tm,L_tm,Pi_tm))) + end; + +(* ---------------------------------------------------------------------------------------- *) + + fun list_distinct _ [] = true + | list_distinct eq_fun (x::xs) = + if all (fn y => (not o eq_fun) (x, y)) xs then list_distinct eq_fun xs else false; + + local + (* the following two functions are from test-z3-wrapper.sml *) + fun list_inclusion eq_fun l1 l2 = + foldl (fn (x, acc) => acc andalso (exists (fn y => eq_fun (x, y)) l2)) true l1; + + (* better than Portable.list_eq, because not order sensitive *) + fun mutual_list_inclusion eq_fun l1 l2 = + list_inclusion eq_fun l1 l2 andalso + length l1 = length l2; + in + val list_eq_contents = + mutual_list_inclusion; + end + + fun list_in eq_fun x l = + List.exists (fn y => eq_fun (x,y)) l; + + (* find the common elements of two lists *) + fun list_commons eq_fun l1 l2 = + List.foldl (fn (x,acc) => if list_in eq_fun x l2 then x::acc else acc) [] l1; + + val gen_eq = (fn (x,y) => x = y); + val term_id_eq = (fn (x,y) => identical x y); + +(* ---------------------------------------------------------------------------------------- *) + + (* get all mapped variable names *) + fun birs_env_varnames birs_tm = + let + val _ = if birs_state_is_normform birs_tm then () else + raise ERR "birs_env_varnames" "symbolic bir state is not in standard form"; + + val (_, env, _, _) = dest_birs_state birs_tm; + val mappings = (fst o listSyntax.dest_list o dest_birs_gen_env) env; + val varname_tms = List.map (fst o pairSyntax.dest_pair) mappings; + val varnames = List.map stringSyntax.fromHOLstring varname_tms; + (* make sure that varnames is distinct *) + val _ = if list_distinct gen_eq varnames then () else + raise ERR "birs_env_varnames" "state has one variable mapped twice"; + in + varnames + end; + + (* modify the environment *) + fun birs_env_CONV is_start conv birs_tm = + let + val _ = if birs_state_is_normform_gen is_start birs_tm then () else + raise ERR "birs_env_CONV" "symbolic bir state is not in standard form"; + + val (pc, env, status, pcond) = dest_birs_state birs_tm; + val env_new_thm = conv env; + in + REWRITE_CONV [env_new_thm] birs_tm + end + + (* move a certain mapping to the top *) + fun birs_env_var_top_CONV varname birs_tm = + (* TODO: should use birs_env_CONV false *) + let + val _ = if birs_state_is_normform birs_tm then () else + raise ERR "birs_env_var_top_CONV" "symbolic bir state is not in standard form"; + + val (pc, env, status, pcond) = dest_birs_state birs_tm; + val (mappings, mappings_ty) = (listSyntax.dest_list o dest_birs_gen_env) env; + val is_m_for_varname = (fn x => x = varname) o stringSyntax.fromHOLstring o fst o pairSyntax.dest_pair; + fun get_exp_if m = + if is_m_for_varname m then SOME m else NONE; + val m_o = List.foldl (fn (m, acc) => case acc of SOME x => SOME x | NONE => get_exp_if m) NONE mappings; + val m = valOf m_o handle _ => raise ERR "birs_env_var_top_CONV" "variable name not mapped in bir state"; + val mappings_new = m::(List.filter (not o is_m_for_varname) mappings); + + val env_new = (mk_birs_gen_env o listSyntax.mk_list) (mappings_new, mappings_ty); + val birs_new_tm = mk_birs_state (pc, env_new, status, pcond); + in + mk_oracle_thm "BIRS_ENVVARTOP" ([], mk_eq (birs_tm, birs_new_tm)) + end + handle _ => raise ERR "birs_env_var_top_CONV" "something uncaught"; + + local + val struct_CONV = + RAND_CONV; + fun Pi_CONV conv = + RAND_CONV (RAND_CONV conv); + val first_CONV = + LAND_CONV; + + val rotate_first_INSERTs_thm = prove(`` + !x1 x2 xs. + (x1 INSERT x2 INSERT xs) = (x2 INSERT x1 INSERT xs) + ``, + cheat + ); + in + (* apply state transformer to Pi *) + fun birs_Pi_CONV conv tm = + let + val _ = if symb_sound_struct_is_normform tm then () else + raise ERR "birs_Pi_CONV" "term is not a standard birs_symb_exec"; + in + (struct_CONV (Pi_CONV conv)) tm + end; + + (* apply state transformer to first state in Pi *) + fun birs_Pi_first_CONV conv = + birs_Pi_CONV (first_CONV conv); + + (* swap the first two states in Pi *) + fun birs_Pi_rotate_RULE thm = + let + (*val _ = print "rotating first two in Pi\n";*) + val _ = if (symb_sound_struct_is_normform o concl) thm then () else + raise ERR "birs_Pi_rotate_RULE" "theorem is not a standard birs_symb_exec"; + val (_,_,Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) thm; + val num_Pi_el = (length o pred_setSyntax.strip_set) Pi_tm; + val _ = if num_Pi_el > 1 then () else + raise ERR "birs_Pi_rotate_RULE" "Pi has to have at least two states"; + + val (_,_,Pi_tm) = (dest_sysLPi o snd o dest_birs_symb_exec o concl) thm; + val (x1_tm, x2xs_tm) = pred_setSyntax.dest_insert Pi_tm; + val (x2_tm, xs_tm) = pred_setSyntax.dest_insert x2xs_tm; + val inst_thm = ISPECL [x1_tm, x2_tm, xs_tm] rotate_first_INSERTs_thm; + in + CONV_RULE (struct_CONV (Pi_CONV (REWRITE_CONV [inst_thm]))) thm + end; + end + +(* ---------------------------------------------------------------------------------------- *) + + (* function to get the initial state *) + fun get_birs_sys tm = + let + val (_, tri_tm) = dest_birs_symb_exec tm; + val (sys_tm,_,_) = dest_sysLPi tri_tm; + in + sys_tm + end; + + (* function to get the first Pi state *) + fun get_birs_Pi_first tm = + let + val (_, tri_tm) = dest_birs_symb_exec tm; + val (_,_,Pi_tm) = dest_sysLPi tri_tm; + val (Pi_sys_tm, _) = pred_setSyntax.dest_insert Pi_tm; + in + Pi_sys_tm + end; + + (* get top env mapping *) + fun get_env_top_mapping env = + let + val (env_mappings, _) = (listSyntax.dest_list o dest_birs_gen_env) env; + val _ = if not (List.null env_mappings) then () else + raise ERR "get_env_top_mapping" "need at least one mapping in the environment"; + in + (pairSyntax.dest_pair o hd) env_mappings + end; + + (* function to get the top env mapping of the first Pi state *) + fun get_birs_Pi_first_env_top_mapping tm = + let + val Pi_sys_tm = get_birs_Pi_first tm; + val (_,env,_,_) = dest_birs_state Pi_sys_tm; + in + get_env_top_mapping env + end; + + (* function to get the pcond of the first Pi state *) + fun get_birs_Pi_first_pcond tm = + let + val Pi_sys_tm = get_birs_Pi_first tm; + val (_,_,_,pcond) = dest_birs_state Pi_sys_tm; + in + pcond + end; + + (* function to get the pcond of the first Pi state *) + fun get_birs_sys_pcond tm = + let + val sys_tm = get_birs_sys tm; + val (_,_,_,pcond) = dest_birs_state sys_tm; + in + pcond + end; + + (* turn bir conjunction into list of conjuncts (care should be taken because this is only meaningful if the type of expression is indeed bit1) *) + fun dest_band x = + let + open bir_exp_immSyntax; + open bir_expSyntax; + fun is_BExp_And tm = is_BExp_BinExp tm andalso (is_BIExp_And o (fn (x,_,_) => x) o dest_BExp_BinExp) tm; + fun dest_BExp_And tm = ((fn (_,x,y) => (x,y)) o dest_BExp_BinExp) tm; + + (* could add a typecheck of x here, to make sure that tm is indeed a Bit1 bir expression *) + fun dest_band_r [] acc = acc + | dest_band_r (tm::tms) acc = + if not (is_BExp_And tm) then dest_band_r tms (tm::acc) else + let + val (tm1,tm2) = dest_BExp_And tm; + in + dest_band_r (tm1::tm2::tms) acc + end; + in + dest_band_r [x] [] + end; + + (* + - "free symbol" the top env mapping into the path condition (also need to be able to handle subexpression "free symboling" for the memory) + *) + local + val freesymb_counter = ref (0:int); + fun get_inc_freesymb_counter () = + let + val v = !freesymb_counter; + val _ = freesymb_counter := v + 1; + in + v + end; + (* replace subexp in exp by subexp' *) + fun substexp subexp' subexp exp = + if identical exp subexp then subexp' else + if (not o is_comb) exp then exp else + let + val (f, x) = dest_comb exp; + in + mk_comb + (substexp subexp' subexp f, + substexp subexp' subexp x) + end; + in + fun set_freesymb_counter i = freesymb_counter := i; + fun get_freesymb_name () = "syf_" ^ (Int.toString (get_inc_freesymb_counter ())); + + (* TODO: this is maybe too crude: just replace the given expression anywhere in the currently mapped expression *) + fun birs_Pi_first_freesymb_RULE symbname exp_tm thm = + let + val _ = if (symb_sound_struct_is_normform o concl) thm then () else + raise ERR "birs_Pi_first_freesymb_RULE" "theorem is not a standard birs_symb_exec"; + + (* get the previously mapped expression *) + val (p_tm, tri_tm) = (dest_birs_symb_exec o concl) thm; + val (sys_tm,L_tm,Pi_old_tm) = dest_sysLPi tri_tm; + val (Pi_sys_old_tm, Pi_rest_tm) = pred_setSyntax.dest_insert Pi_old_tm; + val (pc, env_old, status, pcond_old) = dest_birs_state Pi_sys_old_tm; + val (vn, exp_old) = get_env_top_mapping env_old; + + (* create new expression: check which part of the expression is supposed to be substituted *) + val symb_tm = bir_envSyntax.mk_BVar (stringSyntax.fromMLstring symbname, (bir_exp_typecheckLib.get_type_of_bexp exp_tm)); + val exp_new = substexp (bslSyntax.bden symb_tm) exp_tm exp_old; + + (* debug printout *) + (* + val _ = print "freesymboling expression: "; + val _ = print_term exp_tm; + val _ = print "in: "; + val _ = print_term exp_old; + val _ = print "to: "; + val _ = print_term exp_new; + *) + + (* create updated state (pcond and env), and purge previous environment mapping *) + val env_mod = mk_birs_update_env (pairSyntax.mk_pair (vn, exp_new), env_old); + val purge_update_env_conv = + REWRITE_CONV [birs_auxTheory.birs_update_env_thm] THENC + RAND_CONV EVAL; + val env_new = (snd o dest_eq o concl o purge_update_env_conv) env_mod; + val pcond_new = bslSyntax.band (pcond_old, bslSyntax.beq (bslSyntax.bden symb_tm, exp_tm)); + val Pi_sys_new_tm = mk_birs_state (pc, env_new, status, pcond_new); + + (* debug printout *) + (* + val _ = print "freesymboling expression to pathcondition: "; + val _ = print_term exp_tm; + val _ = print "symb: "; + val _ = print_term symb_tm; + val _ = print "pcond before: "; + val _ = print_term pcond_old; + val _ = print "pcond after: "; + val _ = print_term pcond_new; + *) + + (* check that initial and modified state don't contain the free symbol (i.e., that it really is free) *) + val symbs = List.map (pred_setSyntax.strip_set o snd o dest_eq o concl o bir_vars_ofLib.birs_symb_symbols_DIRECT_CONV o (fn x => ``birs_symb_symbols ^x``)) + [(snd o dest_eq o concl o birs_env_CONV true (EVAL THENC REWRITE_CONV [GSYM birs_auxTheory.birs_gen_env_NULL_thm, GSYM birs_auxTheory.birs_gen_env_thm])) sys_tm, Pi_sys_old_tm]; + val _ = if not (List.exists (fn x => identical x symb_tm) (List.concat symbs)) then () else + let + val _ = print_term symb_tm; + val _ = print "\nsymbs0:" + val _ = List.map (fn x => (print_term x)) (List.nth(symbs,0)); + val _ = print "\nsymbs1:" + val _ = List.map (fn x => (print_term x)) (List.nth(symbs,1)); + in + raise ERR "birs_Pi_first_freesymb_RULE" "symbol is not free in the initial state and/or the first Pi state" end; + + val Pi_new_tm = pred_setSyntax.mk_insert (Pi_sys_new_tm, Pi_rest_tm); + in + mk_oracle_thm "BIRS_FREESYMB" ([], mk_birs_symb_exec (p_tm, mk_sysLPi (sys_tm,L_tm,Pi_new_tm))) + end; + end + + (* forget the value/expression/computation of the top env mapping through free symbol and path condition widening *) + fun birs_Pi_first_forget_RULE symbname thm = + let + (*val _ = print "forgetting first mapping in first of Pi\n";*) + (* find the expression mapped at the top of env *) + val Pi_sys_tm = (get_birs_Pi_first o concl) thm; + val (_,env,_,pcond) = dest_birs_state Pi_sys_tm; + val (_,exp) = get_env_top_mapping env; + + (* "free symbol" the expression *) + val free_thm = birs_Pi_first_freesymb_RULE symbname exp thm; + val Pi_sys_tm_free = (get_birs_Pi_first o concl) free_thm; + val (_,_,_,pcond_free) = dest_birs_state Pi_sys_tm_free; + val pcond_new = (snd o dest_comb o fst o dest_comb) pcond_free; + + (* debug printout *) + (*val _ = print_thm free_thm;*) + (* + val _ = print "\npcond before: \n"; + val _ = print_term pcond_free; + val _ = print "\npcond after: \n"; + val _ = print_term pcond_new; + *) + + (* drop the pathcondition conjunct introduced by free-symboling, relies on how freesymb_RULE changes the path condition *) + val forget_thm = birs_Pi_first_pcond_RULE pcond_new free_thm + handle _ => ((*print_thm thm; + print_thm free_thm;*) + raise ERR "birs_Pi_first_forget_RULE" "something uncaught"); + in + forget_thm + end + +(* ---------------------------------------------------------------------------------------- *) + + (* helper functions for merge, merging of mapped expressions *) + (* -------------------- *) + + (* TODO: - initial implementation: just forget. then test this whole thing before moving on *) + fun birs_Pi_first_env_top_mapping_merge_forget thm = + let + val symbname = get_freesymb_name (); + in + (birs_Pi_first_forget_RULE symbname o birs_Pi_rotate_RULE o birs_Pi_first_forget_RULE symbname) thm + end; + + (* - do something special for store operations, cannot just forget the whole thing *) + (* - maybe just unfold them into a list and assume they are all disjunct memory locations, can reuse code from the cheated store-store simplification *) + (* - later need to do something special about countw here too *) + + (* - choose how to deal with the expressions at hand *) + fun birs_Pi_first_env_top_mapping_merge exp1 exp2 thm = + let + (* choose the merging approach: not touch if they are syntactically identical (or semantically, when checked with z3 under the respective path conditions), store operation, interval, others *) + (* TODO: store operation and interval *) + in + if identical exp1 exp2 then thm else + birs_Pi_first_env_top_mapping_merge_forget thm + end; + + (* the merge function for the first two Pi states *) + fun birs_Pi_merge_2_RULE thm = + let + val _ = print "merging the first two in Pi\n"; + val _ = if (symb_sound_struct_is_normform o concl) thm then () else + raise ERR "birs_Pi_merge_2_RULE" "theorem is not a standard birs_symb_exec"; + (* assumes that Pi has at least two states *) + val (_,_,Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) thm; + val Pi_tms = pred_setSyntax.strip_set Pi_tm; + val num_Pi_el = length Pi_tms; + val _ = if num_Pi_el > 1 then () else + raise ERR "birs_Pi_merge_2_RULE" "Pi has to have at least two states"; + + (* get the env mapped strings, make sure they have the same ones in each *) + val Pi_sys1_tm = List.nth(Pi_tms, 0); + val Pi_sys2_tm = List.nth(Pi_tms, 1); + val varnames = birs_env_varnames Pi_sys1_tm; + val _ = if list_eq_contents gen_eq varnames (birs_env_varnames Pi_sys2_tm) then () else + raise ERR "birs_Pi_merge_2_RULE" "the two states do not have the same variables mapped in the environment"; + + (* for each mapped variable: *) + val thm_env = List.foldl (fn (vn, thm0) => + let + (* move the mapping to the top *) + val thm1 = CONV_RULE (birs_Pi_first_CONV (birs_env_var_top_CONV vn)) thm0; + val exp1 = (snd o get_birs_Pi_first_env_top_mapping o concl) thm1; + val thm2 = birs_Pi_rotate_RULE thm1; + val thm3 = CONV_RULE (birs_Pi_first_CONV (birs_env_var_top_CONV vn)) thm2; + val exp2 = (snd o get_birs_Pi_first_env_top_mapping o concl) thm3; + + val thm4 = birs_Pi_first_env_top_mapping_merge exp2 exp1 thm3; + in thm4 end) thm varnames; + (* also unify the two path conditions *) + val thm_env_pcond = + let + val thm0 = thm_env; + val pcond1 = (get_birs_Pi_first_pcond o concl) thm0; + val thm1 = birs_Pi_rotate_RULE thm0; + val pcond2 = (get_birs_Pi_first_pcond o concl) thm1; + + (* get conjuncts as list *) + val pcond1l = dest_band pcond1; + val pcond2l = dest_band pcond2; + + (* find the common conjuncts by greedily collecting what is identical in both *) + val pcond_commonl = list_commons term_id_eq pcond1l pcond2l; + val pcond_common = bslSyntax.bandl pcond_commonl; + + (* fix the path condition in both states accordingly *) + val thm2 = (birs_Pi_first_pcond_RULE pcond_common o birs_Pi_rotate_RULE o birs_Pi_first_pcond_RULE pcond_common) thm1; + in thm2 end; + (* merge the first two states in the HOL4 pred_set *) + val _ = print "eliminating one from Pi\n"; + (* (TODO: maybe need to prove that they are equal because they are not syntactically identical) *) + val thm_merged = CONV_RULE (birs_Pi_CONV (REWRITE_CONV [ISPEC ((get_birs_Pi_first o concl) thm_env_pcond) pred_setTheory.INSERT_INSERT])) thm_env_pcond; + val _ = print "eliminated one from Pi\n"; + in + thm_merged + end; + + (* merging of all states in Pi *) + fun birs_Pi_merge_RULE thm = + let + val _ = if (symb_sound_struct_is_normform o concl) thm then () else + raise ERR "birs_Pi_merge_RULE" "theorem is not a standard birs_symb_exec"; + val (_,_,Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) thm; + val num_Pi_el = (length o pred_setSyntax.strip_set) Pi_tm; + in + (* recursion, go over all the Pi states until there is only one left *) + if num_Pi_el < 2 then + thm + else + birs_Pi_merge_RULE (birs_Pi_merge_2_RULE thm) + end; + + (* + TODO later: add interval handling (as general as possible, but for now also ok to focus on countw alone) + - have interval hol4 predicate + - squash conjuncts that are only related to the latest free symbol intro and connect to previous interval + - widen the intervals (for now only have one) + *) + +(* ---------------------------------------------------------------------------------------- *) +(* + (* TODO later (instantiate): rename all variables *) + local + val renamesymb_counter = ref (0:int); + fun get_inc_renamesymb_counter () = + let + val v = !renamesymb_counter; + val _ = renamesymb_counter := v + 1; + in + v + end; + fun get_renamesymb_name () = "syr_" ^ (Int.toString (get_inc_renamesymb_counter ())); + in + fun set_renamesymb_counter i = renamesymb_counter := i; + fun birs_sound_rename_all_RULE thm = + let + val _ = if (symb_sound_struct_is_normform o concl) thm then () else + raise ERR "birs_sound_rename_all_RULE" "theorem is not a standard birs_symb_exec"; + + (* *) + in + () + end; + end + +(* ---------------------------------------------------------------------------------------- *) + + (* TODO later (instantiate): the instantiation function *) + fun birs_sound_symb_inst_RULE symb_exp_map thm = + let + val _ = if (symb_sound_struct_is_normform o concl) thm then () else + raise ERR "birs_sound_symb_inst_RULE" "theorem is not a standard birs_symb_exec"; + + (* for now a function that does all at once and cheats *) + (* TODO: later have a subfunction that does one by one (hopefully not too slow) *) + in + () + end; + + (* + TODO later (instantiate): instantiation process + TODO: set up example like this --- execute with symbol in the path condition from the beginning (to be able to preserve path condition for after instantiation) + *) + fun birs_sound_inst_SEQ_RULE birs_rule_SEQ_thm A_thm B_thm = + let + val _ = birs_symb_exec_check_compatible A_thm B_thm; + + (* rename all symbols before instantiating! (birs_sound_rename_all_RULE) *) + + (* identify instantiation needed for B, assumes to take the first state in Pi of A, instantiate and compose sequentially *) + + (* instantiate all environment mappings (birs_sound_symb_inst_RULE) *) + + (* take care of path conditions (after instantiating the original path condition symbol) *) + (* ------- *) + (* use path condition implication with z3 to remove the summary conjuncts (only keep the conjunct corresponding to the original path condition symbol) (birs_sys_pcond_RULE) *) + (* cleanup Pi path conditions (probably only need to consider one for starters) to only preserve non-summary conjunct (as the step before) (birs_Pi_first_pcond_RULE) *) + in + (* sequential composition of the two theorems (birs_composeLib.birs_rule_SEQ_fun birs_rule_SEQ_thm A_thm B_thm) *) + () + end; +*) + +end (* local *) + +end (* struct *) From f3fee0438e31d3651d65c2dc6ede8f1d617594bb Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sun, 6 Oct 2024 23:46:15 +0200 Subject: [PATCH 57/95] Add refined merging for store operations --- src/tools/symbexec/birs_mergeLib.sml | 149 +++++++++++++++++++++++---- 1 file changed, 127 insertions(+), 22 deletions(-) diff --git a/src/tools/symbexec/birs_mergeLib.sml b/src/tools/symbexec/birs_mergeLib.sml index 6166293c0..09f272536 100644 --- a/src/tools/symbexec/birs_mergeLib.sml +++ b/src/tools/symbexec/birs_mergeLib.sml @@ -151,6 +151,8 @@ in (* local *) RAND_CONV (RAND_CONV conv); val first_CONV = LAND_CONV; + fun second_CONV conv = + RAND_CONV (first_CONV conv); val rotate_first_INSERTs_thm = prove(`` !x1 x2 xs. @@ -171,6 +173,8 @@ in (* local *) (* apply state transformer to first state in Pi *) fun birs_Pi_first_CONV conv = birs_Pi_CONV (first_CONV conv); + fun birs_Pi_second_CONV conv = + birs_Pi_CONV (second_CONV conv); (* swap the first two states in Pi *) fun birs_Pi_rotate_RULE thm = @@ -203,16 +207,19 @@ in (* local *) sys_tm end; - (* function to get the first Pi state *) - fun get_birs_Pi_first tm = + (* function to get the set Pi *) + fun get_birs_Pi tm = let val (_, tri_tm) = dest_birs_symb_exec tm; val (_,_,Pi_tm) = dest_sysLPi tri_tm; - val (Pi_sys_tm, _) = pred_setSyntax.dest_insert Pi_tm; in - Pi_sys_tm + Pi_tm end; + (* function to get the first Pi state *) + val get_birs_Pi_first = + (fst o pred_setSyntax.dest_insert o get_birs_Pi); + (* get top env mapping *) fun get_env_top_mapping env = let @@ -366,16 +373,10 @@ in (* local *) end (* forget the value/expression/computation of the top env mapping through free symbol and path condition widening *) - fun birs_Pi_first_forget_RULE symbname thm = + fun birs_Pi_first_forget_RULE_gen symbname exp_tm thm = let - (*val _ = print "forgetting first mapping in first of Pi\n";*) - (* find the expression mapped at the top of env *) - val Pi_sys_tm = (get_birs_Pi_first o concl) thm; - val (_,env,_,pcond) = dest_birs_state Pi_sys_tm; - val (_,exp) = get_env_top_mapping env; - (* "free symbol" the expression *) - val free_thm = birs_Pi_first_freesymb_RULE symbname exp thm; + val free_thm = birs_Pi_first_freesymb_RULE symbname exp_tm thm; val Pi_sys_tm_free = (get_birs_Pi_first o concl) free_thm; val (_,_,_,pcond_free) = dest_birs_state Pi_sys_tm_free; val pcond_new = (snd o dest_comb o fst o dest_comb) pcond_free; @@ -393,17 +394,28 @@ in (* local *) val forget_thm = birs_Pi_first_pcond_RULE pcond_new free_thm handle _ => ((*print_thm thm; print_thm free_thm;*) - raise ERR "birs_Pi_first_forget_RULE" "something uncaught"); + raise ERR "birs_Pi_first_forget_RULE_gen" "could not drop the conjunct, this should never happen"); in forget_thm end + fun birs_Pi_first_forget_RULE symbname thm = + let + (*val _ = print "forgetting first mapping in first of Pi\n";*) + (* find the expression mapped at the top of env *) + val Pi_sys_tm = (get_birs_Pi_first o concl) thm; + val (_,env,_,pcond) = dest_birs_state Pi_sys_tm; + val (_,exp) = get_env_top_mapping env; + in + birs_Pi_first_forget_RULE_gen symbname exp thm + end + (* ---------------------------------------------------------------------------------------- *) (* helper functions for merge, merging of mapped expressions *) (* -------------------- *) - (* TODO: - initial implementation: just forget. then test this whole thing before moving on *) + (* initial implementation: just forget the two mappings, but use the same symbol name *) fun birs_Pi_first_env_top_mapping_merge_forget thm = let val symbname = get_freesymb_name (); @@ -411,20 +423,108 @@ in (* local *) (birs_Pi_first_forget_RULE symbname o birs_Pi_rotate_RULE o birs_Pi_first_forget_RULE symbname) thm end; - (* - do something special for store operations, cannot just forget the whole thing *) - (* - maybe just unfold them into a list and assume they are all disjunct memory locations, can reuse code from the cheated store-store simplification *) - (* - later need to do something special about countw here too *) + fun birs_Pi_first_env_top_mapping_merge_fold ((exp1,exp2), thm) = + let + val symbname = get_freesymb_name (); + in + (birs_Pi_rotate_RULE o birs_Pi_first_forget_RULE_gen symbname exp2 o + birs_Pi_rotate_RULE o birs_Pi_first_forget_RULE_gen symbname exp1) thm + end; + + local + fun unify_stores_foldfun mexp (store, (stores2, stores1_new, stores2_new, forget_exps)) = + let + fun get_store_v (_, _, expv) = expv; + fun is_same_loc_store (expad, endi, _) (expad2, endi2, _) = + if not (identical endi endi2) then raise ERR "is_same_loc_store" "should be same endianness everywhere" else + (* assuming disjunctness of stores, address can be checked by syntactical identity *) + identical expad expad2; + fun exp_to_mem_ld_sz expv = (bir_valuesSyntax.dest_BType_Imm o bir_exp_typecheckLib.get_type_of_bexp) expv + handle _ => raise ERR "unify_stores_foldfun" "couldn't get type of stored expression"; + fun mk_empty_store (expad, endi, expv) = (expad, endi, bir_expSyntax.mk_BExp_Load (mexp, expad, endi, exp_to_mem_ld_sz expv)); + + val match_store2_o = List.find (is_same_loc_store store) stores2; + val store2 = Option.getOpt (match_store2_o, mk_empty_store store); + in + (List.filter (not o is_same_loc_store store) stores2, store::stores1_new, store2::stores2_new, (get_store_v store, get_store_v store2)::forget_exps) + end; + + fun flippair (x,y) = (y,x); + in + fun unify_stores mexp stores1 stores2 = + let + val (stores2_0, stores1_new_0, stores2_new_0, forget_exps_0) = List.foldl (unify_stores_foldfun mexp) (stores2, [], [], []) stores1; + val (stores1_0, stores2_new_1, stores1_new_1, forget_exps_1) = List.foldl (unify_stores_foldfun mexp) ([], [], [], List.map flippair forget_exps_0) stores2_0; + val _ = if List.null stores1_0 then () else raise ERR "unify_stores" "this should never happen"; + in + (List.rev (stores1_new_1@stores1_new_0), List.rev (stores2_new_1@stores2_new_0), List.rev (List.map flippair forget_exps_1)) + end; + end + + (* do something special for store operations, cannot just forget the whole thing *) + fun birs_Pi_first_env_top_mapping_merge_store exp1 exp2 thm = + (* just unfold them into a list and assume they are all disjunct memory locations (TODO: for now), + can reuse code from the cheated store-store simplification *) + let + (* we know that exp1 and exp2 are BExp_Store operations, when this function is called *) + val (mexp1, stores1) = birs_simp_instancesLib.dest_BExp_Store_list exp1 []; + val (mexp2, stores2) = birs_simp_instancesLib.dest_BExp_Store_list exp2 []; + + val _ = if identical mexp1 mexp2 then () else + raise ERR "birs_Pi_first_env_top_mapping_merge_store" "the bir memory symbols have to be identical"; + + (* find shuffled and padded store sequences, use disjunct assumption for this *) + (* at the same time, collect a distinct set of expression pairs that should be "freesymboled" to make the states equal *) + val (stores1_new, stores2_new, forget_exps) = unify_stores mexp1 stores1 stores2; + + (* apply the shuffling by cheated rewriting (justified by disjunct assumption) *) + fun mk_mem_eq_thm mexp stores stores_new = mk_oracle_thm "BIRS_MEM_DISJ_SHUFFLE" ([], mk_eq (birs_simp_instancesLib.mk_BExp_Store_list (mexp, stores), birs_simp_instancesLib.mk_BExp_Store_list (mexp, stores_new))); + val bad_cheat_eq_thm_1 = mk_mem_eq_thm mexp1 stores1 stores1_new; + val bad_cheat_eq_thm_2 = mk_mem_eq_thm mexp1 stores2 stores2_new; + (*val _ = print_thm bad_cheat_eq_thm_1; + val _ = print_thm bad_cheat_eq_thm_2;*) + val thm_shuffled = + CONV_RULE (birs_Pi_first_CONV (REWRITE_CONV [Once bad_cheat_eq_thm_1]) THENC + birs_Pi_second_CONV (REWRITE_CONV [Once bad_cheat_eq_thm_2])) thm; + (*val _ = print_thm thm_shuffled;*) + + (* apply the freesymboling as instructed by forget_exps *) + val thm_free = List.foldl birs_Pi_first_env_top_mapping_merge_fold thm_shuffled forget_exps; + (*val _ = print_thm thm_free;*) + val _ = print "\ndone with birs_Pi_first_env_top_mapping_merge_store\n"; + in + thm_free + end; - (* - choose how to deal with the expressions at hand *) + (* choose how to deal with the expressions at hand *) fun birs_Pi_first_env_top_mapping_merge exp1 exp2 thm = let - (* choose the merging approach: not touch if they are syntactically identical (or semantically, when checked with z3 under the respective path conditions), store operation, interval, others *) - (* TODO: store operation and interval *) + open bir_expSyntax; + val default_op = birs_Pi_first_env_top_mapping_merge_forget; + (* choose the merging approach: *) in + (* do not touch if they are syntactically identical (or semantically, when checked with z3 under the respective path conditions) *) if identical exp1 exp2 then thm else - birs_Pi_first_env_top_mapping_merge_forget thm + + (* store operation *) + if is_BExp_Store exp1 andalso is_BExp_Store exp2 then + birs_Pi_first_env_top_mapping_merge_store exp1 exp2 thm else + + (* TODO: interval (specifically countw) *) + if false then raise ERR "birs_Pi_first_env_top_mapping_merge" "not implemented yet" else + + (* just unify all others *) + default_op thm end; + val INSERT_INSERT_EQ_thm = prove(`` + !x1 x2 xs. + (x1 = x2) ==> + (x1 INSERT x2 INSERT xs) = (x1 INSERT xs) + ``, + cheat (* pred_setTheory.INSERT_INSERT *) + ); + (* the merge function for the first two Pi states *) fun birs_Pi_merge_2_RULE thm = let @@ -479,7 +579,12 @@ in (* local *) (* merge the first two states in the HOL4 pred_set *) val _ = print "eliminating one from Pi\n"; (* (TODO: maybe need to prove that they are equal because they are not syntactically identical) *) - val thm_merged = CONV_RULE (birs_Pi_CONV (REWRITE_CONV [ISPEC ((get_birs_Pi_first o concl) thm_env_pcond) pred_setTheory.INSERT_INSERT])) thm_env_pcond; + (* + val rewrite_thm = ISPECL (((fn x => List.take (x, 2)) o pred_setSyntax.strip_set o get_birs_Pi o concl) thm_env_pcond) INSERT_INSERT_EQ_thm; + (*val _ = print_thm rewrite_thm;*) + val rewrite_thm_fix = CONV_RULE (CHANGED_CONV (QUANT_CONV (LAND_CONV (*aux_setLib.birs_state_EQ_CONV*)EVAL))) rewrite_thm; + val thm_merged = CONV_RULE (CHANGED_CONV (birs_Pi_CONV (REWRITE_CONV [rewrite_thm_fix]))) thm_env_pcond;*) + val thm_merged = CONV_RULE (CHANGED_CONV (birs_Pi_CONV (REWRITE_CONV [ISPEC ((get_birs_Pi_first o concl) thm_env_pcond) pred_setTheory.INSERT_INSERT]))) thm_env_pcond; val _ = print "eliminated one from Pi\n"; in thm_merged From 8e37086667c20cca314fc06905305a5424dce5a4 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 7 Oct 2024 09:40:36 +0200 Subject: [PATCH 58/95] Fix merging for balrob_ends_merge example --- src/tools/symbexec/birs_mergeLib.sml | 150 +++++++++++++++++---------- 1 file changed, 96 insertions(+), 54 deletions(-) diff --git a/src/tools/symbexec/birs_mergeLib.sml b/src/tools/symbexec/birs_mergeLib.sml index 09f272536..376332d9c 100644 --- a/src/tools/symbexec/birs_mergeLib.sml +++ b/src/tools/symbexec/birs_mergeLib.sml @@ -14,6 +14,86 @@ local in (* local *) + fun list_distinct _ [] = true + | list_distinct eq_fun (x::xs) = + if all (fn y => (not o eq_fun) (x, y)) xs then list_distinct eq_fun xs else false; + + (* the following two functions are from test-z3-wrapper.sml *) + fun list_inclusion eq_fun l1 l2 = + foldl (fn (x, acc) => acc andalso (exists (fn y => eq_fun (x, y)) l2)) true l1; + + local + (* better than Portable.list_eq, because not order sensitive *) + fun mutual_list_inclusion eq_fun l1 l2 = + list_inclusion eq_fun l1 l2 andalso + length l1 = length l2; + in + val list_eq_contents = + mutual_list_inclusion; + end + + fun list_in eq_fun x l = + List.exists (fn y => eq_fun (x,y)) l; + + (* find the common elements of two lists *) + fun list_commons eq_fun l1 l2 = + List.foldl (fn (x,acc) => if list_in eq_fun x l2 then x::acc else acc) [] l1; + + val gen_eq = (fn (x,y) => x = y); + val term_id_eq = (fn (x,y) => identical x y); + +(* ---------------------------------------------------------------------------------------- *) + + (* turn bir conjunction into list of conjuncts (care should be taken because this is only meaningful if the type of expression is indeed bit1) *) + fun dest_band x = + let + open bir_exp_immSyntax; + open bir_expSyntax; + fun is_BExp_And tm = is_BExp_BinExp tm andalso (is_BIExp_And o (fn (x,_,_) => x) o dest_BExp_BinExp) tm; + fun dest_BExp_And tm = ((fn (_,x,y) => (x,y)) o dest_BExp_BinExp) tm; + + (* could add a typecheck of x here, to make sure that tm is indeed a Bit1 bir expression *) + fun dest_band_r [] acc = acc + | dest_band_r (tm::tms) acc = + if not (is_BExp_And tm) then dest_band_r tms (tm::acc) else + let + val (tm1,tm2) = dest_BExp_And tm; + in + dest_band_r (tm1::tm2::tms) acc + end; + in + dest_band_r [x] [] + end; + +(* ---------------------------------------------------------------------------------------- *) + + val birs_exp_imp_DROP_second_thm = prove(`` + !be1 be2. + birs_exp_imp (BExp_BinExp BIExp_And be1 be2) be1 + ``, + (* maybe only true for expressions of type Bit1 *) + cheat + ); + + fun is_DROP_second_imp imp_tm = + (SOME (UNCHANGED_CONV (REWRITE_CONV [birs_exp_imp_DROP_second_thm]) imp_tm) + handle _ => NONE); + + fun is_conjunct_inclusion_imp imp_tm = + let + val (pcond1, pcond2) = dest_birs_exp_imp imp_tm; + val pcond1l = dest_band pcond1; + val pcond2l = dest_band pcond2; + + (* find the common conjuncts by greedily collecting what is identical in both *) + val imp_is_ok = list_inclusion term_id_eq pcond2l pcond1l; + in + if imp_is_ok then + SOME (mk_oracle_thm "BIRS_CONJ_INCL_IMP" ([], imp_tm)) + else + NONE + end; + (* general path condition weakening with z3 (to throw away path condition conjuncts (to remove branch path condition conjuncts)) *) fun birs_Pi_first_pcond_RULE pcond_new thm = let @@ -29,7 +109,12 @@ in (* local *) val Pi_new_tm = pred_setSyntax.mk_insert (Pi_sys_new_tm, Pi_rest_tm); val imp_tm = mk_birs_exp_imp (pcond_old, pcond_new); - val pcond_imp_ok = isSome (birs_simpLib.check_imp_tm imp_tm); + (* + val _ = print_term imp_tm; + *) + val pcond_imp_ok = isSome (is_DROP_second_imp imp_tm) orelse + isSome (is_conjunct_inclusion_imp imp_tm) orelse + isSome (birs_simpLib.check_imp_tm imp_tm); val _ = if pcond_imp_ok then () else (print "widening failed, path condition is not weaker\n"; raise ERR "birs_Pi_first_pcond_RULE" "the supplied path condition is not weaker"); @@ -60,36 +145,6 @@ in (* local *) mk_oracle_thm "BIRS_NARROW_PCOND" ([], mk_birs_symb_exec (p_tm, mk_sysLPi (sys_new_tm,L_tm,Pi_tm))) end; -(* ---------------------------------------------------------------------------------------- *) - - fun list_distinct _ [] = true - | list_distinct eq_fun (x::xs) = - if all (fn y => (not o eq_fun) (x, y)) xs then list_distinct eq_fun xs else false; - - local - (* the following two functions are from test-z3-wrapper.sml *) - fun list_inclusion eq_fun l1 l2 = - foldl (fn (x, acc) => acc andalso (exists (fn y => eq_fun (x, y)) l2)) true l1; - - (* better than Portable.list_eq, because not order sensitive *) - fun mutual_list_inclusion eq_fun l1 l2 = - list_inclusion eq_fun l1 l2 andalso - length l1 = length l2; - in - val list_eq_contents = - mutual_list_inclusion; - end - - fun list_in eq_fun x l = - List.exists (fn y => eq_fun (x,y)) l; - - (* find the common elements of two lists *) - fun list_commons eq_fun l1 l2 = - List.foldl (fn (x,acc) => if list_in eq_fun x l2 then x::acc else acc) [] l1; - - val gen_eq = (fn (x,y) => x = y); - val term_id_eq = (fn (x,y) => identical x y); - (* ---------------------------------------------------------------------------------------- *) (* get all mapped variable names *) @@ -191,8 +246,10 @@ in (* local *) val (x1_tm, x2xs_tm) = pred_setSyntax.dest_insert Pi_tm; val (x2_tm, xs_tm) = pred_setSyntax.dest_insert x2xs_tm; val inst_thm = ISPECL [x1_tm, x2_tm, xs_tm] rotate_first_INSERTs_thm; + val res_thm = CONV_RULE (struct_CONV (Pi_CONV (REWRITE_CONV [Once inst_thm]))) thm; + (*val _ = print "finished rotating\n";*) in - CONV_RULE (struct_CONV (Pi_CONV (REWRITE_CONV [inst_thm]))) thm + res_thm end; end @@ -257,27 +314,6 @@ in (* local *) pcond end; - (* turn bir conjunction into list of conjuncts (care should be taken because this is only meaningful if the type of expression is indeed bit1) *) - fun dest_band x = - let - open bir_exp_immSyntax; - open bir_expSyntax; - fun is_BExp_And tm = is_BExp_BinExp tm andalso (is_BIExp_And o (fn (x,_,_) => x) o dest_BExp_BinExp) tm; - fun dest_BExp_And tm = ((fn (_,x,y) => (x,y)) o dest_BExp_BinExp) tm; - - (* could add a typecheck of x here, to make sure that tm is indeed a Bit1 bir expression *) - fun dest_band_r [] acc = acc - | dest_band_r (tm::tms) acc = - if not (is_BExp_And tm) then dest_band_r tms (tm::acc) else - let - val (tm1,tm2) = dest_BExp_And tm; - in - dest_band_r (tm1::tm2::tms) acc - end; - in - dest_band_r [x] [] - end; - (* - "free symbol" the top env mapping into the path condition (also need to be able to handle subexpression "free symboling" for the memory) *) @@ -529,6 +565,7 @@ in (* local *) fun birs_Pi_merge_2_RULE thm = let val _ = print "merging the first two in Pi\n"; + val timer = holba_miscLib.timer_start 0; val _ = if (symb_sound_struct_is_normform o concl) thm then () else raise ERR "birs_Pi_merge_2_RULE" "theorem is not a standard birs_symb_exec"; (* assumes that Pi has at least two states *) @@ -557,6 +594,8 @@ in (* local *) val thm4 = birs_Pi_first_env_top_mapping_merge exp2 exp1 thm3; in thm4 end) thm varnames; + val _ = print "unified envs\n"; + (* also unify the two path conditions *) val thm_env_pcond = let @@ -576,8 +615,9 @@ in (* local *) (* fix the path condition in both states accordingly *) val thm2 = (birs_Pi_first_pcond_RULE pcond_common o birs_Pi_rotate_RULE o birs_Pi_first_pcond_RULE pcond_common) thm1; in thm2 end; + val _ = print "unified pcond\n"; + (* merge the first two states in the HOL4 pred_set *) - val _ = print "eliminating one from Pi\n"; (* (TODO: maybe need to prove that they are equal because they are not syntactically identical) *) (* val rewrite_thm = ISPECL (((fn x => List.take (x, 2)) o pred_setSyntax.strip_set o get_birs_Pi o concl) thm_env_pcond) INSERT_INSERT_EQ_thm; @@ -586,6 +626,8 @@ in (* local *) val thm_merged = CONV_RULE (CHANGED_CONV (birs_Pi_CONV (REWRITE_CONV [rewrite_thm_fix]))) thm_env_pcond;*) val thm_merged = CONV_RULE (CHANGED_CONV (birs_Pi_CONV (REWRITE_CONV [ISPEC ((get_birs_Pi_first o concl) thm_env_pcond) pred_setTheory.INSERT_INSERT]))) thm_env_pcond; val _ = print "eliminated one from Pi\n"; + val _ = holba_miscLib.timer_stop + (fn delta_s => print (" merging two in Pi took " ^ delta_s ^ "\n")) timer; in thm_merged end; From 2c37cb948a9fe637712451c334e1bcd2ef5bf5fc Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 7 Oct 2024 10:46:55 +0200 Subject: [PATCH 59/95] A bit into debugging --- src/shared/smt/holba_z3Lib.sml | 16 ++++++++++++++-- src/tools/symbexec/birs_mergeLib.sml | 5 +++-- src/tools/symbexec/birs_simpLib.sml | 10 +++++----- 3 files changed, 22 insertions(+), 9 deletions(-) diff --git a/src/shared/smt/holba_z3Lib.sml b/src/shared/smt/holba_z3Lib.sml index 10b534701..2bc40a714 100644 --- a/src/shared/smt/holba_z3Lib.sml +++ b/src/shared/smt/holba_z3Lib.sml @@ -36,14 +36,21 @@ val prelude_z3 = read_from_file prelude_z3_path; val prelude_z3_n = prelude_z3 ^ "\n"; val use_stack = true; val debug_print = ref false; +fun kill_z3proc z3p = + let + val _ = endmeexit z3p; + val _ = z3proc_o := NONE; + val _ = z3proc_bin_o := NONE; + in + () + end; fun get_z3proc z3bin = let val z3proc_ = !z3proc_o; fun check_and_restart z3p = if z3bin = valOf (!z3proc_bin_o) then z3p else let - val _ = endmeexit z3p; - val _ = z3proc_o := NONE; + val _ = kill_z3proc z3p; in get_z3proc z3bin end; @@ -67,6 +74,11 @@ fun get_z3proc z3bin = p end; +fun reset_z3proc () = + case !z3proc_o of + SOME z3p => kill_z3proc z3p + | NONE => (); + val z3wrapproc_o = ref (NONE : ((TextIO.instream, TextIO.outstream) Unix.proc) option); fun get_z3wrapproc () = let diff --git a/src/tools/symbexec/birs_mergeLib.sml b/src/tools/symbexec/birs_mergeLib.sml index 376332d9c..1245eddde 100644 --- a/src/tools/symbexec/birs_mergeLib.sml +++ b/src/tools/symbexec/birs_mergeLib.sml @@ -112,8 +112,9 @@ in (* local *) (* val _ = print_term imp_tm; *) - val pcond_imp_ok = isSome (is_DROP_second_imp imp_tm) orelse - isSome (is_conjunct_inclusion_imp imp_tm) orelse + val pcond_drop_ok = isSome (is_DROP_second_imp imp_tm) orelse + isSome (is_conjunct_inclusion_imp imp_tm); + val pcond_imp_ok = pcond_drop_ok orelse (* TODO: something might be wrong in expression simplification before smtlib-z3 exporter *) isSome (birs_simpLib.check_imp_tm imp_tm); val _ = if pcond_imp_ok then () else (print "widening failed, path condition is not weaker\n"; diff --git a/src/tools/symbexec/birs_simpLib.sml b/src/tools/symbexec/birs_simpLib.sml index ec8111595..6162a146a 100644 --- a/src/tools/symbexec/birs_simpLib.sml +++ b/src/tools/symbexec/birs_simpLib.sml @@ -264,11 +264,11 @@ birs_simp_try_inst simp_t simp_inst_tm; fun check_imp_tm imp_tm = if not (birsSyntax.is_birs_exp_imp imp_tm) then raise ERR "check_imp_tm" "term needs to be birs_exp_imp" else - let - val pred1_tm = get_larg imp_tm; - val pred2_tm = get_rarg imp_tm; + (let + val (pred1_tm, pred2_tm) = birsSyntax.dest_birs_exp_imp imp_tm; val imp_bexp_tm = bslSyntax.bor (bslSyntax.bnot pred1_tm, pred2_tm); - val imp_is_taut = bir_smt_check_taut false imp_bexp_tm; + val imp_is_taut = bir_smt_check_taut false imp_bexp_tm + handle e => (print "this should only return bool, not raise exceptions\n"; raise e); val imp_thm = if imp_is_taut then mk_oracle_thm "BIRS_SIMP_LIB_Z3" ([], imp_tm) @@ -280,7 +280,7 @@ birs_simp_try_inst simp_t simp_inst_tm; in SOME imp_thm end - handle _ => NONE; + handle _ => NONE); val check_imp_tm = aux_moveawayLib.wrap_cache_result Term.compare check_imp_tm; From b57c5b78ea65f93864ae8c967477337040932b41 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 7 Oct 2024 11:52:29 +0200 Subject: [PATCH 60/95] Add option for additional symbol in initial path condition when running symbolic execution (support code fragment instantiation handling) --- src/tools/symbexec/bir_symbLib.sig | 2 ++ src/tools/symbexec/bir_symbLib.sml | 7 +++++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/src/tools/symbexec/bir_symbLib.sig b/src/tools/symbexec/bir_symbLib.sig index 68bb27788..fd86b96e3 100644 --- a/src/tools/symbexec/bir_symbLib.sig +++ b/src/tools/symbexec/bir_symbLib.sig @@ -9,6 +9,8 @@ sig val bir_symb_analysis_thm : thm -> thm -> thm list -> thm -> thm -> thm * thm; + val bir_symb_analysis_thm_gen : term option -> thm -> thm -> thm list -> thm -> thm -> thm * thm; + val bir_symb_transfer : term -> term -> term -> term -> diff --git a/src/tools/symbexec/bir_symbLib.sml b/src/tools/symbexec/bir_symbLib.sml index ab68f8579..7b77db6e0 100644 --- a/src/tools/symbexec/bir_symbLib.sml +++ b/src/tools/symbexec/bir_symbLib.sml @@ -94,7 +94,7 @@ Profile.output_profile_results (iostream) (Profile.results ()) result end (* let *) -fun bir_symb_analysis_thm bir_prog_def +fun bir_symb_analysis_thm_gen pcond_symb_o bir_prog_def init_addr_def end_addr_defs bspec_pre_def birenvtyl_def = let @@ -113,9 +113,10 @@ fun bir_symb_analysis_thm bir_prog_def val bspec_pre_tm = (lhs o snd o strip_forall o concl) bspec_pre_def; val bprog_envtyl_tm = (fst o dest_eq o concl) birenvtyl_def; + val bsysprecond_tm_f = Option.getOpt (Option.map (fn tm => fn x => ``BExp_BinExp BIExp_And (^x) (BExp_Den (^tm))``) pcond_symb_o, I); val bsysprecond_thm = (computeLib.RESTR_EVAL_CONV [``birs_eval_exp``] THENC birs_stepLib.birs_eval_exp_CONV) - ``mk_bsysprecond ^bspec_pre_tm ^bprog_envtyl_tm``; + (bsysprecond_tm_f ``mk_bsysprecond ^bspec_pre_tm ^bprog_envtyl_tm``); val birs_pcond_tm = (snd o dest_eq o concl) bsysprecond_thm; val birs_env_thm = (REWRITE_CONV [birenvtyl_def] THENC EVAL THENC REWRITE_CONV [GSYM birs_gen_env_thm, GSYM birs_gen_env_NULL_thm]) ``bir_senv_GEN_list ^bprog_envtyl_tm``; @@ -130,6 +131,8 @@ fun bir_symb_analysis_thm bir_prog_def (bsysprecond_thm, symb_analysis_fix_thm) end (* let *) +val bir_symb_analysis_thm = bir_symb_analysis_thm_gen NONE; + end (* local *) local From de49bb43837f95dcf709ff7efc568858ca171ad4 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 7 Oct 2024 11:53:16 +0200 Subject: [PATCH 61/95] Add comment to support debugging of property transfer for riscv incr example --- examples/riscv/incr/incr_symb_transfScript.sml | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/examples/riscv/incr/incr_symb_transfScript.sml b/examples/riscv/incr/incr_symb_transfScript.sml index e36cd6cb3..65bdaab1e 100644 --- a/examples/riscv/incr/incr_symb_transfScript.sml +++ b/examples/riscv/incr/incr_symb_transfScript.sml @@ -26,6 +26,17 @@ val bspec_post_tm = (lhs o snd o strip_forall o concl) bspec_incr_post_def; (* BIR symbolic execution analysis *) (* ------------------------------- *) +(* +val bir_prog_def = bir_incr_prog_def; +val birenvtyl_def = incr_birenvtyl_def; +val bspec_pre_def = bspec_incr_pre_def; +val bspec_post_def = bspec_incr_post_def; +val prog_vars_list_def = incr_prog_vars_list_def; +val symb_analysis_thm = incr_symb_analysis_thm; +val bsysprecond_thm = incr_bsysprecond_thm; +val prog_vars_thm = incr_prog_vars_thm; +*) + val bspec_cont_thm = bir_symb_transfer init_addr_tm end_addr_tm bspec_pre_tm bspec_post_tm bir_incr_prog_def incr_birenvtyl_def From 22c84f91360ead75a2161a76b1f899ee128fc229 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sat, 12 Oct 2024 10:20:42 +0200 Subject: [PATCH 62/95] Progress on instantiation (and split libraries) --- src/tools/symbexec/birs_instantiationLib.sml | 172 +++++++++ src/tools/symbexec/birs_mergeLib.sml | 387 +------------------ src/tools/symbexec/birs_utilsLib.sml | 383 ++++++++++++++++++ 3 files changed, 562 insertions(+), 380 deletions(-) create mode 100644 src/tools/symbexec/birs_instantiationLib.sml create mode 100644 src/tools/symbexec/birs_utilsLib.sml diff --git a/src/tools/symbexec/birs_instantiationLib.sml b/src/tools/symbexec/birs_instantiationLib.sml new file mode 100644 index 000000000..ec82baa97 --- /dev/null +++ b/src/tools/symbexec/birs_instantiationLib.sml @@ -0,0 +1,172 @@ +structure birs_instantiationLib = +struct + +local + + open HolKernel Parse boolLib bossLib; + + open birsSyntax; + + open birs_utilsLib; + + (* error handling *) + val libname = "birs_instantiationLib" + val ERR = Feedback.mk_HOL_ERR libname + val wrap_exn = Feedback.wrap_exn libname + +in (* local *) + + +(* ---------------------------------------------------------------------------------------- *) + + local + val renamesymb_counter = ref (0:int); + fun get_inc_renamesymb_counter () = + let + val v = !renamesymb_counter; + val _ = renamesymb_counter := v + 1; + in + v + end; + fun get_renamesymb_name () = "syr_" ^ (Int.toString (get_inc_renamesymb_counter ())); + in + fun set_renamesymb_counter i = renamesymb_counter := i; + + (* + (* TODO later (instantiate): rename all variables *) + fun birs_sound_rename_all_RULE thm = + let + val _ = if (symb_sound_struct_is_normform o concl) thm then () else + raise ERR "birs_sound_rename_all_RULE" "theorem is not a standard birs_symb_exec"; + + (* collect what to rename from the initial environment mapping, should be all just variables, skip renaming of the pathcondition *) + in + () + end; + *) + + (* find necessary iunstantiations for birs_sound_symb_inst_RULE *) + fun birs_find_symb_exp_map bv_syp_gen A_thm B_thm = + let + (* take first Pi state of A, env and pcond *) + val A_Pi_sys_tm = (get_birs_Pi_first o concl) A_thm; + val (_,A_env,_,A_pcond) = dest_birs_state A_Pi_sys_tm; + + (* construct symb_exp_map *) + fun get_default_bv (vn,exp) = + let + val ty = bir_exp_typecheckLib.get_type_of_bexp exp; + in + (snd o dest_eq o concl o EVAL) ``bir_senv_GEN_bvar ^(pairSyntax.mk_pair (vn,ty))`` + end; + val A_env_mappings = get_env_mappings A_env; + val A_env_mappings_wsymbs = List.map (fn (x,y) => (x,get_default_bv(x,y),y)) A_env_mappings; + val A_symb_mappings = List.map (fn (_,x,y) => (x,y)) A_env_mappings_wsymbs; + val symb_exp_map = (bv_syp_gen, A_pcond)::A_symb_mappings; + + (* check that initial state of B_thm does map these symbols in the same way (assuming B_sys_tm is in birs_gen_env standard form) *) + val B_sys_tm = (get_birs_sys o concl) B_thm; + val (_,B_env,_,_) = dest_birs_state B_sys_tm; + val B_env_mappings = get_env_mappings B_env + handle _ => raise ERR "birs_find_symb_exp_map" "cannot get env_mappings of B_thm"; + val B_env_mappings_expected = List.map (fn (x,y,_) => (x, bslSyntax.bden y)) A_env_mappings_wsymbs; + val _ = if list_eq_contents (fn (x,y) => pair_eq identical identical x y) B_env_mappings B_env_mappings_expected then () else + raise ERR "birs_find_symb_exp_map" "the environment of B_thm is unexpected"; + + (* better add renaming of all the remaining symbols (practically that is free symbols) to avoid capture issues elsewhere *) + val symbs_mapped_list = List.map fst symb_exp_map; + val freesymbs_in_B = + let + val B_Pi_tm = (get_birs_Pi o concl) B_thm; + val freevars_thm = bir_vars_ofLib.birs_freesymbs_DIRECT_CONV (mk_birs_freesymbs (B_sys_tm, B_Pi_tm)); + in + (pred_setSyntax.strip_set o snd o dest_eq o concl) freevars_thm + end; + fun symb_to_map bv_symb = + let + val rename_vn = get_renamesymb_name (); + val ty = (snd o bir_envSyntax.dest_BVar) bv_symb; + in + (bv_symb, bslSyntax.bden (bir_envSyntax.mk_BVar_string (rename_vn, ty))) + end; + in + (List.map symb_to_map freesymbs_in_B)@symb_exp_map + end; + end + + (* the instantiation function *) + fun birs_sound_symb_inst_RULE symb_exp_map thm = + let + val _ = if (symb_sound_struct_is_normform o concl) thm then () else + raise ERR "birs_sound_symb_inst_RULE" "theorem is not a standard birs_symb_exec"; + + (* for now a function that does all at once and cheats, either sml substitution (for simplicity and speed, double-check the documentation to make sure that it is an "all-at-once substitution") or bir expression substitution and EVAL *) + val s = List.map (fn (bv_symb,exp) => ((bslSyntax.bden bv_symb) |-> exp)) symb_exp_map; + val thm2_tm = (subst s o concl) thm; + (* TODO: later have a subfunction that does one by one (hopefully not too slow) + rename all symbols before instantiating to avoid capturing some! (birs_sound_rename_all_RULE), NOTE: only need this if rename one by one *) + in + mk_oracle_thm "BIRS_SYMB_INST_RENAME" ([], thm2_tm) + end; + + (* + instantiation process (including sequential composition) + TODO: set up example like this --- execute with symbol in the path condition from the beginning (to be able to preserve path condition for after instantiation) + *) + fun birs_sound_inst_SEQ_RULE birs_rule_SEQ_thm bv_syp_gen A_thm B_thm = + let + val _ = birs_symb_exec_check_compatible A_thm B_thm; + val A_Pi_sys_tm = (get_birs_Pi_first o concl) A_thm; + val (_,_,_,A_pcond) = dest_birs_state A_Pi_sys_tm; + val len_of_thm_Pi = get_birs_Pi_length o concl; + + open birs_auxTheory; + val _ = print "start preparing B env\n"; + (* need to unfold bir_senv_GEN_list of sys in B_thm to get a standard birs_gen_env (needed for constructing the map and also for instantiation) *) + val B_thm_norm = CONV_RULE (birs_sys_CONV (EVAL THENC REWRITE_CONV [GSYM birs_gen_env_thm, GSYM birs_gen_env_NULL_thm])) B_thm; + val _ = print "prepared B env\n"; + + (* identify instantiation needed for B, assumes to take the first state in Pi of A, + - environment mappings + - the generic path condition symbol bv_syp_gen + - renaming of all free symbols for good measure *) + val symb_exp_map = birs_find_symb_exp_map bv_syp_gen A_thm B_thm_norm; + val _ = List.map (fn (bv_symb,exp) => (print_term bv_symb; print "|->\n"; print_term exp; print "\n")) symb_exp_map; + val _ = print "created mapping\n"; + + (* instantiate all *) + val B_thm_inst = birs_sound_symb_inst_RULE symb_exp_map B_thm_norm; + val _ = print "all instantiated\n"; + + (* take care of path conditions (after instantiating bv_syp_gen) *) + (* ------- *) + (* use path condition implication with z3 to remove the summary conjuncts from sys + (only keep the conjunct corresponding to the original path condition symbol + NOTE: to be sound and possible, this conjunct must be stronger than what was there already) *) + (* take first Pi state of A, env and pcond *) + val B_thm_inst_sys = birs_sys_pcond_RULE A_pcond B_thm_inst; + val _ = print "path condition fixed\n"; + + (* TODO: can only handle one Pi state, for now *) + val _ = if len_of_thm_Pi B_thm_inst_sys = 1 then () else + raise ERR "birs_sound_inst_SEQ_RULE" "summaries can only contain 1 state currently"; + (* cleanup Pi path conditions (probably only need to consider one for starters) to only preserve non-summary conjunct (as the step before) *) + (* TODO: later this step will also have to take care of intervals (countw and stack pointer) - into B_Pi_pcond_new *) + val B_Pi_pcond_new = A_pcond; + val B_thm_inst_sys_Pi = birs_Pi_first_pcond_RULE B_Pi_pcond_new B_thm_inst_sys; + val _ = print "Pi path condition fixed\n"; + + (* sequential composition of the two theorems *) + val seq_thm = birs_composeLib.birs_rule_SEQ_fun birs_rule_SEQ_thm A_thm B_thm_inst_sys_Pi; + val _ = print "sequentially composed\n"; + + (* check that the resulting Pi set cardinality is A - 1 + B *) + val _ = if len_of_thm_Pi A_thm - 1 + len_of_thm_Pi B_thm_inst_sys_Pi = len_of_thm_Pi seq_thm then () else + raise ERR "birs_sound_inst_SEQ_RULE" "somehow the states did not merge in Pi"; + in + seq_thm + end; + +end (* local *) + +end (* struct *) diff --git a/src/tools/symbexec/birs_mergeLib.sml b/src/tools/symbexec/birs_mergeLib.sml index 1245eddde..ed6a304ab 100644 --- a/src/tools/symbexec/birs_mergeLib.sml +++ b/src/tools/symbexec/birs_mergeLib.sml @@ -7,6 +7,8 @@ local open birsSyntax; + open birs_utilsLib; + (* error handling *) val libname = "birs_mergeLib" val ERR = Feedback.mk_HOL_ERR libname @@ -14,307 +16,6 @@ local in (* local *) - fun list_distinct _ [] = true - | list_distinct eq_fun (x::xs) = - if all (fn y => (not o eq_fun) (x, y)) xs then list_distinct eq_fun xs else false; - - (* the following two functions are from test-z3-wrapper.sml *) - fun list_inclusion eq_fun l1 l2 = - foldl (fn (x, acc) => acc andalso (exists (fn y => eq_fun (x, y)) l2)) true l1; - - local - (* better than Portable.list_eq, because not order sensitive *) - fun mutual_list_inclusion eq_fun l1 l2 = - list_inclusion eq_fun l1 l2 andalso - length l1 = length l2; - in - val list_eq_contents = - mutual_list_inclusion; - end - - fun list_in eq_fun x l = - List.exists (fn y => eq_fun (x,y)) l; - - (* find the common elements of two lists *) - fun list_commons eq_fun l1 l2 = - List.foldl (fn (x,acc) => if list_in eq_fun x l2 then x::acc else acc) [] l1; - - val gen_eq = (fn (x,y) => x = y); - val term_id_eq = (fn (x,y) => identical x y); - -(* ---------------------------------------------------------------------------------------- *) - - (* turn bir conjunction into list of conjuncts (care should be taken because this is only meaningful if the type of expression is indeed bit1) *) - fun dest_band x = - let - open bir_exp_immSyntax; - open bir_expSyntax; - fun is_BExp_And tm = is_BExp_BinExp tm andalso (is_BIExp_And o (fn (x,_,_) => x) o dest_BExp_BinExp) tm; - fun dest_BExp_And tm = ((fn (_,x,y) => (x,y)) o dest_BExp_BinExp) tm; - - (* could add a typecheck of x here, to make sure that tm is indeed a Bit1 bir expression *) - fun dest_band_r [] acc = acc - | dest_band_r (tm::tms) acc = - if not (is_BExp_And tm) then dest_band_r tms (tm::acc) else - let - val (tm1,tm2) = dest_BExp_And tm; - in - dest_band_r (tm1::tm2::tms) acc - end; - in - dest_band_r [x] [] - end; - -(* ---------------------------------------------------------------------------------------- *) - - val birs_exp_imp_DROP_second_thm = prove(`` - !be1 be2. - birs_exp_imp (BExp_BinExp BIExp_And be1 be2) be1 - ``, - (* maybe only true for expressions of type Bit1 *) - cheat - ); - - fun is_DROP_second_imp imp_tm = - (SOME (UNCHANGED_CONV (REWRITE_CONV [birs_exp_imp_DROP_second_thm]) imp_tm) - handle _ => NONE); - - fun is_conjunct_inclusion_imp imp_tm = - let - val (pcond1, pcond2) = dest_birs_exp_imp imp_tm; - val pcond1l = dest_band pcond1; - val pcond2l = dest_band pcond2; - - (* find the common conjuncts by greedily collecting what is identical in both *) - val imp_is_ok = list_inclusion term_id_eq pcond2l pcond1l; - in - if imp_is_ok then - SOME (mk_oracle_thm "BIRS_CONJ_INCL_IMP" ([], imp_tm)) - else - NONE - end; - - (* general path condition weakening with z3 (to throw away path condition conjuncts (to remove branch path condition conjuncts)) *) - fun birs_Pi_first_pcond_RULE pcond_new thm = - let - val _ = if (symb_sound_struct_is_normform o concl) thm then () else - raise ERR "birs_Pi_first_pcond_RULE" "theorem is not a standard birs_symb_exec"; - - val (p_tm, tri_tm) = (dest_birs_symb_exec o concl) thm; - val (sys_tm,L_tm,Pi_old_tm) = dest_sysLPi tri_tm; - val (Pi_sys_old_tm, Pi_rest_tm) = pred_setSyntax.dest_insert Pi_old_tm; - - val (pc, env, status, pcond_old) = dest_birs_state Pi_sys_old_tm; - val Pi_sys_new_tm = mk_birs_state (pc, env, status, pcond_new); - val Pi_new_tm = pred_setSyntax.mk_insert (Pi_sys_new_tm, Pi_rest_tm); - - val imp_tm = mk_birs_exp_imp (pcond_old, pcond_new); - (* - val _ = print_term imp_tm; - *) - val pcond_drop_ok = isSome (is_DROP_second_imp imp_tm) orelse - isSome (is_conjunct_inclusion_imp imp_tm); - val pcond_imp_ok = pcond_drop_ok orelse (* TODO: something might be wrong in expression simplification before smtlib-z3 exporter *) - isSome (birs_simpLib.check_imp_tm imp_tm); - val _ = if pcond_imp_ok then () else - (print "widening failed, path condition is not weaker\n"; - raise ERR "birs_Pi_first_pcond_RULE" "the supplied path condition is not weaker"); - (* TODO: use the bir implication theorem to justify the new theorem *) - in - mk_oracle_thm "BIRS_WIDEN_PCOND" ([], mk_birs_symb_exec (p_tm, mk_sysLPi (sys_tm,L_tm,Pi_new_tm))) - end; - - (* TODO later (instantiate): general path condition strengthening with z3 *) - fun birs_sys_pcond_RULE pcond_new thm = - let - val _ = if (symb_sound_struct_is_normform o concl) thm then () else - raise ERR "birs_sys_pcond_RULE" "theorem is not a standard birs_symb_exec"; - - val (p_tm, tri_tm) = (dest_birs_symb_exec o concl) thm; - val (sys_old_tm,L_tm,Pi_tm) = dest_sysLPi tri_tm; - - val (pc, env, status, pcond_old) = dest_birs_state sys_old_tm; - val sys_new_tm = mk_birs_state (pc, env, status, pcond_new); - - val imp_tm = mk_birs_exp_imp (pcond_new, pcond_old); - val pcond_imp_ok = isSome (birs_simpLib.check_imp_tm imp_tm); - val _ = if pcond_imp_ok then () else - (print "narrowing failed, path condition is not stronger\n"; - raise ERR "birs_sys_pcond_RULE" "the supplied path condition is not stronger"); - (* TODO: use the bir implication theorem to justify the new theorem *) - in - mk_oracle_thm "BIRS_NARROW_PCOND" ([], mk_birs_symb_exec (p_tm, mk_sysLPi (sys_new_tm,L_tm,Pi_tm))) - end; - -(* ---------------------------------------------------------------------------------------- *) - - (* get all mapped variable names *) - fun birs_env_varnames birs_tm = - let - val _ = if birs_state_is_normform birs_tm then () else - raise ERR "birs_env_varnames" "symbolic bir state is not in standard form"; - - val (_, env, _, _) = dest_birs_state birs_tm; - val mappings = (fst o listSyntax.dest_list o dest_birs_gen_env) env; - val varname_tms = List.map (fst o pairSyntax.dest_pair) mappings; - val varnames = List.map stringSyntax.fromHOLstring varname_tms; - (* make sure that varnames is distinct *) - val _ = if list_distinct gen_eq varnames then () else - raise ERR "birs_env_varnames" "state has one variable mapped twice"; - in - varnames - end; - - (* modify the environment *) - fun birs_env_CONV is_start conv birs_tm = - let - val _ = if birs_state_is_normform_gen is_start birs_tm then () else - raise ERR "birs_env_CONV" "symbolic bir state is not in standard form"; - - val (pc, env, status, pcond) = dest_birs_state birs_tm; - val env_new_thm = conv env; - in - REWRITE_CONV [env_new_thm] birs_tm - end - - (* move a certain mapping to the top *) - fun birs_env_var_top_CONV varname birs_tm = - (* TODO: should use birs_env_CONV false *) - let - val _ = if birs_state_is_normform birs_tm then () else - raise ERR "birs_env_var_top_CONV" "symbolic bir state is not in standard form"; - - val (pc, env, status, pcond) = dest_birs_state birs_tm; - val (mappings, mappings_ty) = (listSyntax.dest_list o dest_birs_gen_env) env; - val is_m_for_varname = (fn x => x = varname) o stringSyntax.fromHOLstring o fst o pairSyntax.dest_pair; - fun get_exp_if m = - if is_m_for_varname m then SOME m else NONE; - val m_o = List.foldl (fn (m, acc) => case acc of SOME x => SOME x | NONE => get_exp_if m) NONE mappings; - val m = valOf m_o handle _ => raise ERR "birs_env_var_top_CONV" "variable name not mapped in bir state"; - val mappings_new = m::(List.filter (not o is_m_for_varname) mappings); - - val env_new = (mk_birs_gen_env o listSyntax.mk_list) (mappings_new, mappings_ty); - val birs_new_tm = mk_birs_state (pc, env_new, status, pcond); - in - mk_oracle_thm "BIRS_ENVVARTOP" ([], mk_eq (birs_tm, birs_new_tm)) - end - handle _ => raise ERR "birs_env_var_top_CONV" "something uncaught"; - - local - val struct_CONV = - RAND_CONV; - fun Pi_CONV conv = - RAND_CONV (RAND_CONV conv); - val first_CONV = - LAND_CONV; - fun second_CONV conv = - RAND_CONV (first_CONV conv); - - val rotate_first_INSERTs_thm = prove(`` - !x1 x2 xs. - (x1 INSERT x2 INSERT xs) = (x2 INSERT x1 INSERT xs) - ``, - cheat - ); - in - (* apply state transformer to Pi *) - fun birs_Pi_CONV conv tm = - let - val _ = if symb_sound_struct_is_normform tm then () else - raise ERR "birs_Pi_CONV" "term is not a standard birs_symb_exec"; - in - (struct_CONV (Pi_CONV conv)) tm - end; - - (* apply state transformer to first state in Pi *) - fun birs_Pi_first_CONV conv = - birs_Pi_CONV (first_CONV conv); - fun birs_Pi_second_CONV conv = - birs_Pi_CONV (second_CONV conv); - - (* swap the first two states in Pi *) - fun birs_Pi_rotate_RULE thm = - let - (*val _ = print "rotating first two in Pi\n";*) - val _ = if (symb_sound_struct_is_normform o concl) thm then () else - raise ERR "birs_Pi_rotate_RULE" "theorem is not a standard birs_symb_exec"; - val (_,_,Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) thm; - val num_Pi_el = (length o pred_setSyntax.strip_set) Pi_tm; - val _ = if num_Pi_el > 1 then () else - raise ERR "birs_Pi_rotate_RULE" "Pi has to have at least two states"; - - val (_,_,Pi_tm) = (dest_sysLPi o snd o dest_birs_symb_exec o concl) thm; - val (x1_tm, x2xs_tm) = pred_setSyntax.dest_insert Pi_tm; - val (x2_tm, xs_tm) = pred_setSyntax.dest_insert x2xs_tm; - val inst_thm = ISPECL [x1_tm, x2_tm, xs_tm] rotate_first_INSERTs_thm; - val res_thm = CONV_RULE (struct_CONV (Pi_CONV (REWRITE_CONV [Once inst_thm]))) thm; - (*val _ = print "finished rotating\n";*) - in - res_thm - end; - end - -(* ---------------------------------------------------------------------------------------- *) - - (* function to get the initial state *) - fun get_birs_sys tm = - let - val (_, tri_tm) = dest_birs_symb_exec tm; - val (sys_tm,_,_) = dest_sysLPi tri_tm; - in - sys_tm - end; - - (* function to get the set Pi *) - fun get_birs_Pi tm = - let - val (_, tri_tm) = dest_birs_symb_exec tm; - val (_,_,Pi_tm) = dest_sysLPi tri_tm; - in - Pi_tm - end; - - (* function to get the first Pi state *) - val get_birs_Pi_first = - (fst o pred_setSyntax.dest_insert o get_birs_Pi); - - (* get top env mapping *) - fun get_env_top_mapping env = - let - val (env_mappings, _) = (listSyntax.dest_list o dest_birs_gen_env) env; - val _ = if not (List.null env_mappings) then () else - raise ERR "get_env_top_mapping" "need at least one mapping in the environment"; - in - (pairSyntax.dest_pair o hd) env_mappings - end; - - (* function to get the top env mapping of the first Pi state *) - fun get_birs_Pi_first_env_top_mapping tm = - let - val Pi_sys_tm = get_birs_Pi_first tm; - val (_,env,_,_) = dest_birs_state Pi_sys_tm; - in - get_env_top_mapping env - end; - - (* function to get the pcond of the first Pi state *) - fun get_birs_Pi_first_pcond tm = - let - val Pi_sys_tm = get_birs_Pi_first tm; - val (_,_,_,pcond) = dest_birs_state Pi_sys_tm; - in - pcond - end; - - (* function to get the pcond of the first Pi state *) - fun get_birs_sys_pcond tm = - let - val sys_tm = get_birs_sys tm; - val (_,_,_,pcond) = dest_birs_state sys_tm; - in - pcond - end; - (* - "free symbol" the top env mapping into the path condition (also need to be able to handle subexpression "free symboling" for the memory) *) @@ -414,21 +115,9 @@ in (* local *) let (* "free symbol" the expression *) val free_thm = birs_Pi_first_freesymb_RULE symbname exp_tm thm; - val Pi_sys_tm_free = (get_birs_Pi_first o concl) free_thm; - val (_,_,_,pcond_free) = dest_birs_state Pi_sys_tm_free; - val pcond_new = (snd o dest_comb o fst o dest_comb) pcond_free; - - (* debug printout *) - (*val _ = print_thm free_thm;*) - (* - val _ = print "\npcond before: \n"; - val _ = print_term pcond_free; - val _ = print "\npcond after: \n"; - val _ = print_term pcond_new; - *) (* drop the pathcondition conjunct introduced by free-symboling, relies on how freesymb_RULE changes the path condition *) - val forget_thm = birs_Pi_first_pcond_RULE pcond_new free_thm + val forget_thm = birs_Pi_first_pcond_drop true free_thm handle _ => ((*print_thm thm; print_thm free_thm;*) raise ERR "birs_Pi_first_forget_RULE_gen" "could not drop the conjunct, this should never happen"); @@ -500,8 +189,10 @@ in (* local *) (* do something special for store operations, cannot just forget the whole thing *) fun birs_Pi_first_env_top_mapping_merge_store exp1 exp2 thm = - (* just unfold them into a list and assume they are all disjunct memory locations (TODO: for now), - can reuse code from the cheated store-store simplification *) + (* just unfold them into a list and assume they are all disjunct memory locations + (TODO: it is like this for now) + (NOTE: that the store address expressions themselves are not equal and disjunct is crudely justified by running the store-store cheater before) + reused code from the cheated store-store simplification *) let (* we know that exp1 and exp2 are BExp_Store operations, when this function is called *) val (mexp1, stores1) = birs_simp_instancesLib.dest_BExp_Store_list exp1 []; @@ -655,70 +346,6 @@ in (* local *) - widen the intervals (for now only have one) *) -(* ---------------------------------------------------------------------------------------- *) -(* - (* TODO later (instantiate): rename all variables *) - local - val renamesymb_counter = ref (0:int); - fun get_inc_renamesymb_counter () = - let - val v = !renamesymb_counter; - val _ = renamesymb_counter := v + 1; - in - v - end; - fun get_renamesymb_name () = "syr_" ^ (Int.toString (get_inc_renamesymb_counter ())); - in - fun set_renamesymb_counter i = renamesymb_counter := i; - fun birs_sound_rename_all_RULE thm = - let - val _ = if (symb_sound_struct_is_normform o concl) thm then () else - raise ERR "birs_sound_rename_all_RULE" "theorem is not a standard birs_symb_exec"; - - (* *) - in - () - end; - end - -(* ---------------------------------------------------------------------------------------- *) - - (* TODO later (instantiate): the instantiation function *) - fun birs_sound_symb_inst_RULE symb_exp_map thm = - let - val _ = if (symb_sound_struct_is_normform o concl) thm then () else - raise ERR "birs_sound_symb_inst_RULE" "theorem is not a standard birs_symb_exec"; - - (* for now a function that does all at once and cheats *) - (* TODO: later have a subfunction that does one by one (hopefully not too slow) *) - in - () - end; - - (* - TODO later (instantiate): instantiation process - TODO: set up example like this --- execute with symbol in the path condition from the beginning (to be able to preserve path condition for after instantiation) - *) - fun birs_sound_inst_SEQ_RULE birs_rule_SEQ_thm A_thm B_thm = - let - val _ = birs_symb_exec_check_compatible A_thm B_thm; - - (* rename all symbols before instantiating! (birs_sound_rename_all_RULE) *) - - (* identify instantiation needed for B, assumes to take the first state in Pi of A, instantiate and compose sequentially *) - - (* instantiate all environment mappings (birs_sound_symb_inst_RULE) *) - - (* take care of path conditions (after instantiating the original path condition symbol) *) - (* ------- *) - (* use path condition implication with z3 to remove the summary conjuncts (only keep the conjunct corresponding to the original path condition symbol) (birs_sys_pcond_RULE) *) - (* cleanup Pi path conditions (probably only need to consider one for starters) to only preserve non-summary conjunct (as the step before) (birs_Pi_first_pcond_RULE) *) - in - (* sequential composition of the two theorems (birs_composeLib.birs_rule_SEQ_fun birs_rule_SEQ_thm A_thm B_thm) *) - () - end; -*) - end (* local *) end (* struct *) diff --git a/src/tools/symbexec/birs_utilsLib.sml b/src/tools/symbexec/birs_utilsLib.sml new file mode 100644 index 000000000..0bfb92abd --- /dev/null +++ b/src/tools/symbexec/birs_utilsLib.sml @@ -0,0 +1,383 @@ +structure birs_utilsLib = +struct + +local + + open HolKernel Parse boolLib bossLib; + + open birsSyntax; + + (* error handling *) + val libname = "birs_utilsLib" + val ERR = Feedback.mk_HOL_ERR libname + val wrap_exn = Feedback.wrap_exn libname + +in (* local *) + + fun list_distinct _ [] = true + | list_distinct eq_fun (x::xs) = + if all (fn y => (not o eq_fun) (x, y)) xs then list_distinct eq_fun xs else false; + + (* the following two functions are from test-z3-wrapper.sml *) + fun list_inclusion eq_fun l1 l2 = + foldl (fn (x, acc) => acc andalso (exists (fn y => eq_fun (x, y)) l2)) true l1; + + local + (* better than Portable.list_eq, because not order sensitive *) + fun mutual_list_inclusion eq_fun l1 l2 = + list_inclusion eq_fun l1 l2 andalso + length l1 = length l2; + in + val list_eq_contents = + mutual_list_inclusion; + end + + fun list_in eq_fun x l = + List.exists (fn y => eq_fun (x,y)) l; + + (* find the common elements of two lists *) + fun list_commons eq_fun l1 l2 = + List.foldl (fn (x,acc) => if list_in eq_fun x l2 then x::acc else acc) [] l1; + + val gen_eq = (fn (x,y) => x = y); + val term_id_eq = (fn (x,y) => identical x y); + +(* ---------------------------------------------------------------------------------------- *) + + (* turn bir conjunction into list of conjuncts (care should be taken because this is only meaningful if the type of expression is indeed bit1) *) + fun dest_band x = + let + open bir_exp_immSyntax; + open bir_expSyntax; + fun is_BExp_And tm = is_BExp_BinExp tm andalso (is_BIExp_And o (fn (x,_,_) => x) o dest_BExp_BinExp) tm; + fun dest_BExp_And tm = ((fn (_,x,y) => (x,y)) o dest_BExp_BinExp) tm; + + (* could add a typecheck of x here, to make sure that tm is indeed a Bit1 bir expression *) + fun dest_band_r [] acc = acc + | dest_band_r (tm::tms) acc = + if not (is_BExp_And tm) then dest_band_r tms (tm::acc) else + let + val (tm1,tm2) = dest_BExp_And tm; + in + dest_band_r (tm1::tm2::tms) acc + end; + in + dest_band_r [x] [] + end; + +(* ---------------------------------------------------------------------------------------- *) + + (* function to get the initial state *) + fun get_birs_sys tm = + let + val (_, tri_tm) = dest_birs_symb_exec tm; + val (sys_tm,_,_) = dest_sysLPi tri_tm; + in + sys_tm + end; + + (* function to get the set Pi *) + fun get_birs_Pi tm = + let + val (_, tri_tm) = dest_birs_symb_exec tm; + val (_,_,Pi_tm) = dest_sysLPi tri_tm; + in + Pi_tm + end; + + (* function to get the length of Pi *) + val get_birs_Pi_length = + (length o pred_setSyntax.strip_set o get_birs_Pi); + + (* function to get the first Pi state *) + val get_birs_Pi_first = + (fst o pred_setSyntax.dest_insert o get_birs_Pi); + + (* get env mappings *) + val get_env_mappings = + (List.map pairSyntax.dest_pair o fst o listSyntax.dest_list o dest_birs_gen_env); + + (* get top env mapping *) + fun get_env_top_mapping env = + let + val env_mappings = get_env_mappings env; + val _ = if not (List.null env_mappings) then () else + raise ERR "get_env_top_mapping" "need at least one mapping in the environment"; + in + hd env_mappings + end; + + (* function to get the top env mapping of the first Pi state *) + fun get_birs_Pi_first_env_top_mapping tm = + let + val Pi_sys_tm = get_birs_Pi_first tm; + val (_,env,_,_) = dest_birs_state Pi_sys_tm; + in + get_env_top_mapping env + end; + + (* function to get the pcond of the first Pi state *) + fun get_birs_Pi_first_pcond tm = + let + val Pi_sys_tm = get_birs_Pi_first tm; + val (_,_,_,pcond) = dest_birs_state Pi_sys_tm; + in + pcond + end; + + (* function to get the pcond of the first Pi state *) + fun get_birs_sys_pcond tm = + let + val sys_tm = get_birs_sys tm; + val (_,_,_,pcond) = dest_birs_state sys_tm; + in + pcond + end; + +(* ---------------------------------------------------------------------------------------- *) + + val birs_exp_imp_DROP_R_thm = prove(`` + !be1 be2. + birs_exp_imp (BExp_BinExp BIExp_And be1 be2) be1 + ``, + (* maybe only true for expressions of type Bit1 *) + cheat + ); + val birs_exp_imp_DROP_L_thm = prove(`` + !be1 be2. + birs_exp_imp (BExp_BinExp BIExp_And be1 be2) be2 + ``, + (* maybe only true for expressions of type Bit1 *) + cheat + ); + + fun is_DROP_R_imp imp_tm = + (SOME (UNCHANGED_CONV (REWRITE_CONV [birs_exp_imp_DROP_R_thm]) imp_tm) + handle _ => NONE); + + fun is_DROP_L_imp imp_tm = + (SOME (UNCHANGED_CONV (REWRITE_CONV [birs_exp_imp_DROP_L_thm]) imp_tm) + handle _ => NONE); + + fun is_conjunct_inclusion_imp imp_tm = + let + val (pcond1, pcond2) = dest_birs_exp_imp imp_tm; + val pcond1l = dest_band pcond1; + val pcond2l = dest_band pcond2; + + (* find the common conjuncts by greedily collecting what is identical in both *) + val imp_is_ok = list_inclusion term_id_eq pcond2l pcond1l; + in + if imp_is_ok then + SOME (mk_oracle_thm "BIRS_CONJ_INCL_IMP" ([], imp_tm)) + else + NONE + end; + + (* general path condition weakening with z3 (to throw away path condition conjuncts (to remove branch path condition conjuncts)) *) + fun birs_Pi_first_pcond_RULE pcond_new thm = + let + val _ = if (symb_sound_struct_is_normform o concl) thm then () else + raise ERR "birs_Pi_first_pcond_RULE" "theorem is not a standard birs_symb_exec"; + + val (p_tm, tri_tm) = (dest_birs_symb_exec o concl) thm; + val (sys_tm,L_tm,Pi_old_tm) = dest_sysLPi tri_tm; + val (Pi_sys_old_tm, Pi_rest_tm) = pred_setSyntax.dest_insert Pi_old_tm; + + val (pc, env, status, pcond_old) = dest_birs_state Pi_sys_old_tm; + val Pi_sys_new_tm = mk_birs_state (pc, env, status, pcond_new); + val Pi_new_tm = pred_setSyntax.mk_insert (Pi_sys_new_tm, Pi_rest_tm); + + val imp_tm = mk_birs_exp_imp (pcond_old, pcond_new); + (* + val _ = print_term imp_tm; + val _ = holba_z3Lib.debug_print := true; + val _ = print "sending a z3 query\n"; + *) + val pcond_drop_ok = isSome (is_DROP_R_imp imp_tm) orelse + isSome (is_DROP_L_imp imp_tm) orelse + isSome (is_conjunct_inclusion_imp imp_tm); + val pcond_imp_ok = pcond_drop_ok orelse (* TODO: something might be wrong in expression simplification before smtlib-z3 exporter *) + isSome (birs_simpLib.check_imp_tm imp_tm); + val _ = if pcond_imp_ok then () else + (print "widening failed, path condition is not weaker\n"; + raise ERR "birs_Pi_first_pcond_RULE" "the supplied path condition is not weaker"); + (* TODO: use the bir implication theorem to justify the new theorem *) + in + mk_oracle_thm "BIRS_WIDEN_PCOND" ([], mk_birs_symb_exec (p_tm, mk_sysLPi (sys_tm,L_tm,Pi_new_tm))) + end; + + fun birs_Pi_first_pcond_drop drop_right thm = + let + val Pi_sys_tm_free = (get_birs_Pi_first o concl) thm; + val (_,_,_,pcond_old) = dest_birs_state Pi_sys_tm_free; + val sel_fun = + if drop_right then + (snd o dest_comb o fst o dest_comb) + else + (snd o dest_comb); + val pcond_new = sel_fun pcond_old; + + (* debug printout *) + (*val _ = print_thm thm;*) + (* + val _ = print "\npcond before: \n"; + val _ = print_term pcond_old; + val _ = print "\npcond after: \n"; + val _ = print_term pcond_new; + *) + in + birs_Pi_first_pcond_RULE pcond_new thm + end; + + (* TODO later (instantiate): general path condition strengthening with z3 *) + fun birs_sys_pcond_RULE pcond_new thm = + let + val _ = if (symb_sound_struct_is_normform o concl) thm then () else + raise ERR "birs_sys_pcond_RULE" "theorem is not a standard birs_symb_exec"; + + val (p_tm, tri_tm) = (dest_birs_symb_exec o concl) thm; + val (sys_old_tm,L_tm,Pi_tm) = dest_sysLPi tri_tm; + + val (pc, env, status, pcond_old) = dest_birs_state sys_old_tm; + val sys_new_tm = mk_birs_state (pc, env, status, pcond_new); + + val imp_tm = mk_birs_exp_imp (pcond_new, pcond_old); + (* + val _ = print_term imp_tm; + val _ = holba_z3Lib.debug_print := true; + val _ = print "sending a z3 query\n"; + *) + val pcond_imp_ok = isSome (birs_simpLib.check_imp_tm imp_tm); + val _ = if pcond_imp_ok then () else + (print "narrowing failed, path condition is not stronger\n"; + raise ERR "birs_sys_pcond_RULE" "the supplied path condition is not stronger"); + (* TODO: use the bir implication theorem to justify the new theorem *) + in + mk_oracle_thm "BIRS_NARROW_PCOND" ([], mk_birs_symb_exec (p_tm, mk_sysLPi (sys_new_tm,L_tm,Pi_tm))) + end; + +(* ---------------------------------------------------------------------------------------- *) + + (* get all mapped variable names *) + fun birs_env_varnames birs_tm = + let + val _ = if birs_state_is_normform birs_tm then () else + raise ERR "birs_env_varnames" "symbolic bir state is not in standard form"; + + val (_, env, _, _) = dest_birs_state birs_tm; + val mappings = (fst o listSyntax.dest_list o dest_birs_gen_env) env; + val varname_tms = List.map (fst o pairSyntax.dest_pair) mappings; + val varnames = List.map stringSyntax.fromHOLstring varname_tms; + (* make sure that varnames is distinct *) + val _ = if list_distinct gen_eq varnames then () else + raise ERR "birs_env_varnames" "state has one variable mapped twice"; + in + varnames + end; + + (* modify the environment *) + fun birs_env_CONV is_start conv birs_tm = + let + val _ = if birs_state_is_normform_gen is_start birs_tm then () else + raise ERR "birs_env_CONV" "symbolic bir state is not in standard form"; + + val (pc, env, status, pcond) = dest_birs_state birs_tm; + val env_new_thm = conv env; + in + REWRITE_CONV [env_new_thm] birs_tm + end + + (* move a certain mapping to the top *) + fun birs_env_var_top_CONV varname birs_tm = + (* TODO: should use birs_env_CONV false *) + let + val _ = if birs_state_is_normform birs_tm then () else + raise ERR "birs_env_var_top_CONV" "symbolic bir state is not in standard form"; + + val (pc, env, status, pcond) = dest_birs_state birs_tm; + val (mappings, mappings_ty) = (listSyntax.dest_list o dest_birs_gen_env) env; + val is_m_for_varname = (fn x => x = varname) o stringSyntax.fromHOLstring o fst o pairSyntax.dest_pair; + fun get_exp_if m = + if is_m_for_varname m then SOME m else NONE; + val m_o = List.foldl (fn (m, acc) => case acc of SOME x => SOME x | NONE => get_exp_if m) NONE mappings; + val m = valOf m_o handle _ => raise ERR "birs_env_var_top_CONV" "variable name not mapped in bir state"; + val mappings_new = m::(List.filter (not o is_m_for_varname) mappings); + + val env_new = (mk_birs_gen_env o listSyntax.mk_list) (mappings_new, mappings_ty); + val birs_new_tm = mk_birs_state (pc, env_new, status, pcond); + in + mk_oracle_thm "BIRS_ENVVARTOP" ([], mk_eq (birs_tm, birs_new_tm)) + end + handle _ => raise ERR "birs_env_var_top_CONV" "something uncaught"; + + local + val struct_CONV = + RAND_CONV; + fun sys_CONV conv = + LAND_CONV conv; + fun Pi_CONV conv = + RAND_CONV (RAND_CONV conv); + val first_CONV = + LAND_CONV; + fun second_CONV conv = + RAND_CONV (first_CONV conv); + + val rotate_first_INSERTs_thm = prove(`` + !x1 x2 xs. + (x1 INSERT x2 INSERT xs) = (x2 INSERT x1 INSERT xs) + ``, + cheat + ); + in + (* apply state transformer to sys *) + fun birs_sys_CONV conv tm = + let + val _ = if symb_sound_struct_is_normform tm then () else + raise ERR "birs_sys_CONV" "term is not a standard birs_symb_exec"; + in + (struct_CONV (sys_CONV conv)) tm + end; + + (* apply state transformer to Pi *) + fun birs_Pi_CONV conv tm = + let + val _ = if symb_sound_struct_is_normform tm then () else + raise ERR "birs_Pi_CONV" "term is not a standard birs_symb_exec"; + in + (struct_CONV (Pi_CONV conv)) tm + end; + + (* apply state transformer to first state in Pi *) + fun birs_Pi_first_CONV conv = + birs_Pi_CONV (first_CONV conv); + fun birs_Pi_second_CONV conv = + birs_Pi_CONV (second_CONV conv); + + (* swap the first two states in Pi *) + fun birs_Pi_rotate_RULE thm = + let + (*val _ = print "rotating first two in Pi\n";*) + val _ = if (symb_sound_struct_is_normform o concl) thm then () else + raise ERR "birs_Pi_rotate_RULE" "theorem is not a standard birs_symb_exec"; + val (_,_,Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) thm; + val num_Pi_el = (length o pred_setSyntax.strip_set) Pi_tm; + val _ = if num_Pi_el > 1 then () else + raise ERR "birs_Pi_rotate_RULE" "Pi has to have at least two states"; + + val (_,_,Pi_tm) = (dest_sysLPi o snd o dest_birs_symb_exec o concl) thm; + val (x1_tm, x2xs_tm) = pred_setSyntax.dest_insert Pi_tm; + val (x2_tm, xs_tm) = pred_setSyntax.dest_insert x2xs_tm; + val inst_thm = ISPECL [x1_tm, x2_tm, xs_tm] rotate_first_INSERTs_thm; + val res_thm = CONV_RULE (struct_CONV (Pi_CONV (REWRITE_CONV [Once inst_thm]))) thm; + (*val _ = print "finished rotating\n";*) + in + res_thm + end; + end + +(* ---------------------------------------------------------------------------------------- *) + +end (* local *) + +end (* struct *) From a2c440c145e4e95c11357454e9bbde130fbecf5f Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sat, 12 Oct 2024 10:24:02 +0200 Subject: [PATCH 63/95] Various fixes --- src/shared/smt/bir_smtlibLib.sml | 45 ++++++++++++++------------ src/tools/symbexec/aux_setLib.sml | 5 +-- src/tools/symbexec/birs_composeLib.sml | 3 +- src/tools/symbexec/birs_simpLib.sml | 21 ++++-------- 4 files changed, 37 insertions(+), 37 deletions(-) diff --git a/src/shared/smt/bir_smtlibLib.sml b/src/shared/smt/bir_smtlibLib.sml index 69921a0dc..31fe5b442 100644 --- a/src/shared/smt/bir_smtlibLib.sml +++ b/src/shared/smt/bir_smtlibLib.sml @@ -311,6 +311,17 @@ fun to_smtlib_bool (str, sty) = fun bexp_to_smtlib is_tl exst exp = let fun problem exp msg = problem_gen "bexp_to_smtlib" exp msg; + + (* solves syntactic sugar and constant word expressions in BExp_Const *) + fun generic_solution err_msg exp_tm = + let + val eqexp = (snd o dest_eq o concl o EVAL) exp_tm; + in + if not (identical exp_tm eqexp) then + bexp_to_smtlib is_tl exst eqexp + else + problem exp_tm err_msg + end val abbr_o = exst_get_abbr exst exp; in @@ -349,20 +360,21 @@ fun to_smtlib_bool (str, sty) = else let val (sz, wv) = (gen_dest_Imm o dest_BExp_Const) exp; - val vstr = - if is_word_literal wv then - (Arbnum.toString o dest_word_literal) wv - else problem exp "can only handle word literals: "; in - if sz = 1 then - if Arbnumcore.mod(((dest_word_literal) wv), Arbnumcore.fromInt 2) - = Arbnumcore.fromInt 1 then - (exst, ("true", SMTTY_Bool)) - else - (exst, ("false", SMTTY_Bool)) + if is_word_literal wv then + let val vstr = (Arbnum.toString o dest_word_literal) wv in + if sz = 1 then + if Arbnumcore.mod(((dest_word_literal) wv), Arbnumcore.fromInt 2) + = Arbnumcore.fromInt 1 then + (exst, ("true", SMTTY_Bool)) + else + (exst, ("false", SMTTY_Bool)) + else + (exst, ("(_ bv" ^ vstr ^ " " ^ (Int.toString sz) ^ ")", + SMTTY_BV sz)) + end else - (exst, ("(_ bv" ^ vstr ^ " " ^ (Int.toString sz) ^ ")", - SMTTY_BV sz)) + generic_solution "can only handle word literals: " exp end (* @@ -583,14 +595,7 @@ BExp_Store (BExp_Den (BVar "fr_269_MEM" (BType_Mem Bit32 Bit8))) else (* TODO: this is a generic solution for BIR syntactic sugar but we actually want to export some specific expressions in a direct way, if possible *) - let - val eqexp = (snd o dest_eq o concl o EVAL) exp; - in - if not (identical exp eqexp) then - bexp_to_smtlib is_tl exst eqexp - else - problem exp "don't know BIR expression: " - end + generic_solution "don't know BIR expression: " exp end; (* preprocess into CNF, into list of conjuncted clauses *) diff --git a/src/tools/symbexec/aux_setLib.sml b/src/tools/symbexec/aux_setLib.sml index 6b59812b6..42ad3c425 100644 --- a/src/tools/symbexec/aux_setLib.sml +++ b/src/tools/symbexec/aux_setLib.sml @@ -128,12 +128,13 @@ in (* local *) ) tm; + val DIFF_CONV_debug = false; fun DIFF_CONV el_EQ_CONV tm = if pred_setSyntax.is_empty tm then REFL tm else if pred_setSyntax.is_diff tm then if (pred_setSyntax.is_empty o fst o pred_setSyntax.dest_diff) tm then - (print_term tm; + (if DIFF_CONV_debug then print_term tm else (); REWRITE_CONV [EMPTY_DIFF] tm) else if (pred_setSyntax.is_insert o fst o pred_setSyntax.dest_diff) tm then (DIFF_CONV_Once el_EQ_CONV THENC @@ -145,7 +146,7 @@ in (* local *) (DIFF_CONV el_EQ_CONV) tm else - (print_term tm; + (if DIFF_CONV_debug then print_term tm else (); raise ERR "DIFF_CONV" "unexpected2"); fun UNIONs_LEFT_CONV eq_EQ_CONV tm = diff --git a/src/tools/symbexec/birs_composeLib.sml b/src/tools/symbexec/birs_composeLib.sml index 65ca1ce3f..eb86ee9cd 100644 --- a/src/tools/symbexec/birs_composeLib.sml +++ b/src/tools/symbexec/birs_composeLib.sml @@ -86,7 +86,8 @@ in val _ = print "composed\n"; (* tidy up set operations to not accumulate (in both, post state set and label set) *) - val bprog_L_fixed_thm = CONV_RULE (tidyup_birs_symb_exec_CONV aux_setLib.birs_state_DIFF_UNION_CONV aux_setLib.labelset_UNION_CONV) bprog_composed_thm; + val bprog_L_fixed_thm = CONV_RULE (tidyup_birs_symb_exec_CONV aux_setLib.birs_state_DIFF_UNION_CONV aux_setLib.labelset_UNION_CONV) bprog_composed_thm + handle e => (print "\n\n"; print_thm bprog_composed_thm; print "tidy up Pi and labelset failed\n"; raise e); val _ = if symb_sound_struct_is_normform (concl bprog_L_fixed_thm) then () else (print_term (concl bprog_L_fixed_thm); diff --git a/src/tools/symbexec/birs_simpLib.sml b/src/tools/symbexec/birs_simpLib.sml index 6162a146a..c3be33d61 100644 --- a/src/tools/symbexec/birs_simpLib.sml +++ b/src/tools/symbexec/birs_simpLib.sml @@ -264,23 +264,16 @@ birs_simp_try_inst simp_t simp_inst_tm; fun check_imp_tm imp_tm = if not (birsSyntax.is_birs_exp_imp imp_tm) then raise ERR "check_imp_tm" "term needs to be birs_exp_imp" else - (let + let val (pred1_tm, pred2_tm) = birsSyntax.dest_birs_exp_imp imp_tm; val imp_bexp_tm = bslSyntax.bor (bslSyntax.bnot pred1_tm, pred2_tm); - val imp_is_taut = bir_smt_check_taut false imp_bexp_tm - handle e => (print "this should only return bool, not raise exceptions\n"; raise e); - val imp_thm = - if imp_is_taut then - mk_oracle_thm "BIRS_SIMP_LIB_Z3" ([], imp_tm) - else ( - (*print_term imp_tm;*) - print "implication term is not a tautology\n"; - raise ERR "check_imp_tm" "implication term is not a tautology" - ) + val imp_is_taut = bir_smt_check_taut false imp_bexp_tm; in - SOME imp_thm - end - handle _ => NONE); + if imp_is_taut then + SOME (mk_oracle_thm "BIRS_SIMP_LIB_Z3" ([], imp_tm)) + else + NONE + end; val check_imp_tm = aux_moveawayLib.wrap_cache_result Term.compare check_imp_tm; From c08bd349fc106c6970197dc085d3cb636ec0ce19 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sat, 12 Oct 2024 12:11:53 +0200 Subject: [PATCH 64/95] Add oracle fix to compare environments for equality syntactically --- src/tools/symbexec/aux_setLib.sml | 52 +++- .../symbexec/examples/test-aux_setLib.sml | 229 ++++++++++++++++++ 2 files changed, 269 insertions(+), 12 deletions(-) create mode 100644 src/tools/symbexec/examples/test-aux_setLib.sml diff --git a/src/tools/symbexec/aux_setLib.sml b/src/tools/symbexec/aux_setLib.sml index 42ad3c425..bdcec0156 100644 --- a/src/tools/symbexec/aux_setLib.sml +++ b/src/tools/symbexec/aux_setLib.sml @@ -241,24 +241,52 @@ in (* local *) handle _ => NONE; val neq_t_o = List.foldl foldfun NONE thms; in - if isSome neq_t_o then - valOf neq_t_o - else - (print "\ncould not show inequality of the states, would need to check the environments\n"; - raise ERR "try_prove_birs_state_NEQ" "could not show inequality of the states, would need to check the environments") + neq_t_o + end; + + fun birs_gen_env_check_eq env1 env2 = + let + val mappings1 = birs_utilsLib.get_env_mappings env1; + val mappings2 = birs_utilsLib.get_env_mappings env2; + in + birs_utilsLib.list_eq_contents (fn (x,y) => pair_eq identical identical x y) mappings1 mappings2 end; fun birs_state_EQ_CONV tm = IFC (CHANGED_CONV (REWRITE_CONV [])) (fn tm => (print "syntactically equal, done!\n"; REFL tm)) - (fn tm => - let - val (bsys1_tm, bsys2_tm) = dest_eq tm; - val neq_t = try_prove_birs_state_NEQ bsys1_tm bsys2_tm; - in - REWRITE_CONV [neq_t] tm - end) + (IFC + (fn tm => + let + val (bsys1_tm, bsys2_tm) = dest_eq tm; + val neq_t_o = try_prove_birs_state_NEQ bsys1_tm bsys2_tm; + in + if isSome neq_t_o then + (*(print_thm (valOf neq_t_o);*) + REWRITE_CONV [valOf neq_t_o] tm + else + (print "\ncould not show inequality of the states for pc or pcond or status, need to check the environments\n"; + NO_CONV tm) + end) + (fn tm => (print "unequal due to something that is not the environment, done!\n"; REFL tm)) + (fn tm => + let + val (bsys1_tm, bsys2_tm) = dest_eq tm; + val _ = if birsSyntax.birs_state_is_normform_gen false bsys1_tm andalso + birsSyntax.birs_state_is_normform_gen false bsys2_tm then () else + raise ERR "birs_state_EQ_CONV" "need two states with birs_gen_env environments"; + + val get_state_env = (fn (_,env,_,_) => env) o birsSyntax.dest_birs_state; + val is_eq = birs_gen_env_check_eq (get_state_env bsys1_tm) (get_state_env bsys2_tm); + val _ = print (if is_eq then "states are equal\n" else "states are not equal\n"); + (* TODO: the false case might be wrong *) + val _ = if is_eq then () else + raise ERR "birs_state_EQ_CONV" "the states seem to be unequal, but they might be equal"; + val eq_thm = mk_oracle_thm "BIRS_STATE_EQ" ([], mk_eq (tm, if is_eq then T else F)); + in + REWRITE_CONV [eq_thm] tm + end)) tm; (* ---------------------------------------------------------------------------------- *) diff --git a/src/tools/symbexec/examples/test-aux_setLib.sml b/src/tools/symbexec/examples/test-aux_setLib.sml new file mode 100644 index 000000000..27990373f --- /dev/null +++ b/src/tools/symbexec/examples/test-aux_setLib.sml @@ -0,0 +1,229 @@ +open HolKernel Parse boolLib bossLib; + +open aux_setLib; + +val _ = print "start parsing\n"; + +val birs_state_DIFF_tm = ``{<|bsst_pc := + <|bpc_label := BL_Address (Imm32 0x100013B4w); bpc_index := 0|>; + bsst_environ := + birs_gen_env + [("countw", + BExp_BinExp BIExp_Plus + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 (1w + 4w)))); + ("LR",BExp_Const (Imm32 0x100012DDw)); + ("R0",BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); + ("PSR_Z", + BExp_BinPred BIExp_Equal + (BExp_Den (BVar "sy_R5" (BType_Imm Bit32))) + (BExp_Const (Imm32 0w))); + ("PSR_N", + BExp_BinPred BIExp_SignedLessThan + (BExp_Den (BVar "sy_R5" (BType_Imm Bit32))) + (BExp_Const (Imm32 0w))); + ("R11",BExp_Den (BVar "sy_R11" (BType_Imm Bit32))); + ("R10",BExp_Den (BVar "sy_R10" (BType_Imm Bit32))); + ("R9",BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); + ("R8",BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); + ("R7",BExp_Den (BVar "sy_R7" (BType_Imm Bit32))); + ("R12",BExp_Den (BVar "sy_R12" (BType_Imm Bit32))); + ("R5",BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); + ("R6",BExp_Den (BVar "sy_R6" (BType_Imm Bit32))); + ("R4",BExp_Den (BVar "sy_R4" (BType_Imm Bit32))); + ("tmp_PC",BExp_Den (BVar "sy_tmp_PC" (BType_Imm Bit32))); + ("MEM",BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); + ("tmp_SP_process", + BExp_Den (BVar "sy_tmp_SP_process" (BType_Imm Bit32))); + ("SP_process",BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))); + ("ModeHandler",BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1))); + ("tmp_PSR_C",BExp_Den (BVar "sy_tmp_PSR_C" (BType_Imm Bit1))); + ("PSR_V",BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); + ("R1",BExp_Den (BVar "sy_R1" (BType_Imm Bit32))); + ("R3",BExp_Den (BVar "sy_R3" (BType_Imm Bit32))); + ("PSR_C",BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); + ("R2",BExp_Den (BVar "sy_R2" (BType_Imm Bit32)))]; + bsst_status := BST_Running; + bsst_pcond := + BExp_BinPred BIExp_LessOrEqual + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 0xFFFFFC1w))|>} DIFF + {<|bsst_pc := + <|bpc_label := BL_Address (Imm32 0x100013B4w); bpc_index := 0|>; + bsst_environ := + birs_gen_env + [("R11",BExp_Den (BVar "sy_R11" (BType_Imm Bit32))); + ("R10",BExp_Den (BVar "sy_R10" (BType_Imm Bit32))); + ("R9",BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); + ("R8",BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); + ("R7",BExp_Den (BVar "sy_R7" (BType_Imm Bit32))); + ("R12",BExp_Den (BVar "sy_R12" (BType_Imm Bit32))); + ("R5",BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); + ("R6",BExp_Den (BVar "sy_R6" (BType_Imm Bit32))); + ("R4",BExp_Den (BVar "sy_R4" (BType_Imm Bit32))); + ("tmp_PC",BExp_Den (BVar "sy_tmp_PC" (BType_Imm Bit32))); + ("MEM",BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); + ("tmp_SP_process", + BExp_Den (BVar "sy_tmp_SP_process" (BType_Imm Bit32))); + ("SP_process",BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))); + ("ModeHandler",BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1))); + ("LR",BExp_Const (Imm32 0x100012DDw)); + ("tmp_PSR_C",BExp_Den (BVar "sy_tmp_PSR_C" (BType_Imm Bit1))); + ("PSR_V",BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); + ("R1",BExp_Den (BVar "sy_R1" (BType_Imm Bit32))); + ("R3",BExp_Den (BVar "sy_R3" (BType_Imm Bit32))); + ("PSR_C",BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); + ("R0",BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); + ("R2",BExp_Den (BVar "sy_R2" (BType_Imm Bit32))); + ("PSR_Z", + BExp_BinPred BIExp_Equal + (BExp_Den (BVar "sy_R5" (BType_Imm Bit32))) + (BExp_Const (Imm32 0w))); + ("PSR_N", + BExp_BinPred BIExp_SignedLessThan + (BExp_Den (BVar "sy_R5" (BType_Imm Bit32))) + (BExp_Const (Imm32 0w))); + ("countw", + BExp_BinExp BIExp_Plus + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 (1w + 4w))))]; bsst_status := BST_Running; + bsst_pcond := + BExp_BinPred BIExp_LessOrEqual + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 0xFFFFFC1w))|>}``; + + +val birs_state_DIFF_UNION_tm = ``{<|bsst_pc := + <|bpc_label := BL_Address (Imm32 0x100013B4w); bpc_index := 0|>; + bsst_environ := + birs_gen_env + [("countw", + BExp_BinExp BIExp_Plus + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 (1w + 4w)))); + ("LR",BExp_Const (Imm32 0x100012DDw)); + ("R0",BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); + ("PSR_Z", + BExp_BinPred BIExp_Equal + (BExp_Den (BVar "sy_R5" (BType_Imm Bit32))) + (BExp_Const (Imm32 0w))); + ("PSR_N", + BExp_BinPred BIExp_SignedLessThan + (BExp_Den (BVar "sy_R5" (BType_Imm Bit32))) + (BExp_Const (Imm32 0w))); + ("R11",BExp_Den (BVar "sy_R11" (BType_Imm Bit32))); + ("R10",BExp_Den (BVar "sy_R10" (BType_Imm Bit32))); + ("R9",BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); + ("R8",BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); + ("R7",BExp_Den (BVar "sy_R7" (BType_Imm Bit32))); + ("R12",BExp_Den (BVar "sy_R12" (BType_Imm Bit32))); + ("R5",BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); + ("R6",BExp_Den (BVar "sy_R6" (BType_Imm Bit32))); + ("R4",BExp_Den (BVar "sy_R4" (BType_Imm Bit32))); + ("tmp_PC",BExp_Den (BVar "sy_tmp_PC" (BType_Imm Bit32))); + ("MEM",BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); + ("tmp_SP_process", + BExp_Den (BVar "sy_tmp_SP_process" (BType_Imm Bit32))); + ("SP_process",BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))); + ("ModeHandler",BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1))); + ("tmp_PSR_C",BExp_Den (BVar "sy_tmp_PSR_C" (BType_Imm Bit1))); + ("PSR_V",BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); + ("R1",BExp_Den (BVar "sy_R1" (BType_Imm Bit32))); + ("R3",BExp_Den (BVar "sy_R3" (BType_Imm Bit32))); + ("PSR_C",BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); + ("R2",BExp_Den (BVar "sy_R2" (BType_Imm Bit32)))]; + bsst_status := BST_Running; + bsst_pcond := + BExp_BinPred BIExp_LessOrEqual + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 0xFFFFFC1w))|>} DIFF + {<|bsst_pc := + <|bpc_label := BL_Address (Imm32 0x100013B4w); bpc_index := 0|>; + bsst_environ := + birs_gen_env + [("R11",BExp_Den (BVar "sy_R11" (BType_Imm Bit32))); + ("R10",BExp_Den (BVar "sy_R10" (BType_Imm Bit32))); + ("R9",BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); + ("R8",BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); + ("R7",BExp_Den (BVar "sy_R7" (BType_Imm Bit32))); + ("R12",BExp_Den (BVar "sy_R12" (BType_Imm Bit32))); + ("R5",BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); + ("R6",BExp_Den (BVar "sy_R6" (BType_Imm Bit32))); + ("R4",BExp_Den (BVar "sy_R4" (BType_Imm Bit32))); + ("tmp_PC",BExp_Den (BVar "sy_tmp_PC" (BType_Imm Bit32))); + ("MEM",BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); + ("tmp_SP_process", + BExp_Den (BVar "sy_tmp_SP_process" (BType_Imm Bit32))); + ("SP_process",BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))); + ("ModeHandler",BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1))); + ("LR",BExp_Const (Imm32 0x100012DDw)); + ("tmp_PSR_C",BExp_Den (BVar "sy_tmp_PSR_C" (BType_Imm Bit1))); + ("PSR_V",BExp_Den (BVar "sy_PSR_V" (BType_Imm Bit1))); + ("R1",BExp_Den (BVar "sy_R1" (BType_Imm Bit32))); + ("R3",BExp_Den (BVar "sy_R3" (BType_Imm Bit32))); + ("PSR_C",BExp_Den (BVar "sy_PSR_C" (BType_Imm Bit1))); + ("R0",BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); + ("R2",BExp_Den (BVar "sy_R2" (BType_Imm Bit32))); + ("PSR_Z", + BExp_BinPred BIExp_Equal + (BExp_Den (BVar "sy_R5" (BType_Imm Bit32))) + (BExp_Const (Imm32 0w))); + ("PSR_N", + BExp_BinPred BIExp_SignedLessThan + (BExp_Den (BVar "sy_R5" (BType_Imm Bit32))) + (BExp_Const (Imm32 0w))); + ("countw", + BExp_BinExp BIExp_Plus + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 (1w + 4w))))]; bsst_status := BST_Running; + bsst_pcond := + BExp_BinPred BIExp_LessOrEqual + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 0xFFFFFC1w))|>} ∪ + {<|bsst_pc := + <|bpc_label := BL_Address (Imm32 0x100013DCw); bpc_index := 0|>; + bsst_environ := + birs_gen_env + [("tmp_PSR_C",BExp_Den (BVar "sy_tmp_PSR_C" (BType_Imm Bit1))); + ("LR",BExp_Const (Imm32 0x100012DDw)); + ("ModeHandler",BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1))); + ("SP_process",BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))); + ("tmp_SP_process", + BExp_Den (BVar "sy_tmp_SP_process" (BType_Imm Bit32))); + ("MEM",BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))); + ("tmp_PC",BExp_Den (BVar "sy_tmp_PC" (BType_Imm Bit32))); + ("R4",BExp_Den (BVar "sy_R4" (BType_Imm Bit32))); + ("R6",BExp_Den (BVar "sy_R6" (BType_Imm Bit32))); + ("R5",BExp_Den (BVar "sy_R5" (BType_Imm Bit32))); + ("R12",BExp_Den (BVar "sy_R12" (BType_Imm Bit32))); + ("R7",BExp_Den (BVar "sy_R7" (BType_Imm Bit32))); + ("R8",BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); + ("R9",BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); + ("R10",BExp_Den (BVar "sy_R10" (BType_Imm Bit32))); + ("R11",BExp_Den (BVar "sy_R11" (BType_Imm Bit32))); + ("R3", + BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_LeftShift (BExp_Const (Imm32 1w)) + (BExp_Const (Imm32 16w))) (BExp_Const (Imm32 8w))) + (BExp_Const (Imm32 4w))); + ("R1",BExp_Den (BVar "syr_0" (BType_Imm Bit32))); + ("R2",BExp_Const (Imm32 0x100013DEw)); + ("PSR_C",BExp_Den (BVar "syr_1" (BType_Imm Bit1))); + ("PSR_N",BExp_Den (BVar "syr_2" (BType_Imm Bit1))); + ("PSR_V",BExp_Den (BVar "syr_3" (BType_Imm Bit1))); + ("PSR_Z",BExp_Den (BVar "syr_4" (BType_Imm Bit1))); + ("R0",BExp_Den (BVar "syr_5" (BType_Imm Bit32))); + ("countw",BExp_Den (BVar "syr_6" (BType_Imm Bit64)))]; + bsst_status := BST_Running; + bsst_pcond := + BExp_BinPred BIExp_LessOrEqual + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 0xFFFFFC1w))|>}``; + +val DIFF_UNION_thm = birs_state_DIFF_UNION_CONV birs_state_DIFF_UNION_tm; +val _ = print "finished DIFF_UNION_CONV\n"; + +val DIFF_thm = (DIFF_CONV birs_state_EQ_CONV) birs_state_DIFF_tm; +val _ = print "finished DIFF_CONV\n"; + From a1122451e944b175853967524f9c658f7f999a60 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sat, 12 Oct 2024 12:43:25 +0200 Subject: [PATCH 65/95] Clean up instantiation map --- src/tools/symbexec/birs_instantiationLib.sml | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) diff --git a/src/tools/symbexec/birs_instantiationLib.sml b/src/tools/symbexec/birs_instantiationLib.sml index ec82baa97..84c6a6a0a 100644 --- a/src/tools/symbexec/birs_instantiationLib.sml +++ b/src/tools/symbexec/birs_instantiationLib.sml @@ -62,7 +62,8 @@ in (* local *) val A_env_mappings = get_env_mappings A_env; val A_env_mappings_wsymbs = List.map (fn (x,y) => (x,get_default_bv(x,y),y)) A_env_mappings; val A_symb_mappings = List.map (fn (_,x,y) => (x,y)) A_env_mappings_wsymbs; - val symb_exp_map = (bv_syp_gen, A_pcond)::A_symb_mappings; + val A_symb_mappings_changed = List.filter (fn (x,y) => not (identical (bslSyntax.bden x) y)) A_symb_mappings; (* do not need to instantiate what does not change *) + val symb_exp_map = (bv_syp_gen, A_pcond)::A_symb_mappings_changed; (* check that initial state of B_thm does map these symbols in the same way (assuming B_sys_tm is in birs_gen_env standard form) *) val B_sys_tm = (get_birs_sys o concl) B_thm; @@ -82,7 +83,7 @@ in (* local *) in (pred_setSyntax.strip_set o snd o dest_eq o concl) freevars_thm end; - fun symb_to_map bv_symb = + fun symb_to_rename_map bv_symb = let val rename_vn = get_renamesymb_name (); val ty = (snd o bir_envSyntax.dest_BVar) bv_symb; @@ -90,7 +91,7 @@ in (* local *) (bv_symb, bslSyntax.bden (bir_envSyntax.mk_BVar_string (rename_vn, ty))) end; in - (List.map symb_to_map freesymbs_in_B)@symb_exp_map + (List.map symb_to_rename_map freesymbs_in_B)@symb_exp_map end; end @@ -121,22 +122,18 @@ in (* local *) val len_of_thm_Pi = get_birs_Pi_length o concl; open birs_auxTheory; - val _ = print "start preparing B env\n"; (* need to unfold bir_senv_GEN_list of sys in B_thm to get a standard birs_gen_env (needed for constructing the map and also for instantiation) *) val B_thm_norm = CONV_RULE (birs_sys_CONV (EVAL THENC REWRITE_CONV [GSYM birs_gen_env_thm, GSYM birs_gen_env_NULL_thm])) B_thm; - val _ = print "prepared B env\n"; (* identify instantiation needed for B, assumes to take the first state in Pi of A, - environment mappings - the generic path condition symbol bv_syp_gen - renaming of all free symbols for good measure *) val symb_exp_map = birs_find_symb_exp_map bv_syp_gen A_thm B_thm_norm; - val _ = List.map (fn (bv_symb,exp) => (print_term bv_symb; print "|->\n"; print_term exp; print "\n")) symb_exp_map; - val _ = print "created mapping\n"; + (*val _ = List.map (fn (bv_symb,exp) => (print_term bv_symb; print "|->\n"; print_term exp; print "\n")) symb_exp_map;*) (* instantiate all *) val B_thm_inst = birs_sound_symb_inst_RULE symb_exp_map B_thm_norm; - val _ = print "all instantiated\n"; (* take care of path conditions (after instantiating bv_syp_gen) *) (* ------- *) @@ -145,7 +142,6 @@ in (* local *) NOTE: to be sound and possible, this conjunct must be stronger than what was there already) *) (* take first Pi state of A, env and pcond *) val B_thm_inst_sys = birs_sys_pcond_RULE A_pcond B_thm_inst; - val _ = print "path condition fixed\n"; (* TODO: can only handle one Pi state, for now *) val _ = if len_of_thm_Pi B_thm_inst_sys = 1 then () else @@ -154,11 +150,9 @@ in (* local *) (* TODO: later this step will also have to take care of intervals (countw and stack pointer) - into B_Pi_pcond_new *) val B_Pi_pcond_new = A_pcond; val B_thm_inst_sys_Pi = birs_Pi_first_pcond_RULE B_Pi_pcond_new B_thm_inst_sys; - val _ = print "Pi path condition fixed\n"; (* sequential composition of the two theorems *) val seq_thm = birs_composeLib.birs_rule_SEQ_fun birs_rule_SEQ_thm A_thm B_thm_inst_sys_Pi; - val _ = print "sequentially composed\n"; (* check that the resulting Pi set cardinality is A - 1 + B *) val _ = if len_of_thm_Pi A_thm - 1 + len_of_thm_Pi B_thm_inst_sys_Pi = len_of_thm_Pi seq_thm then () else From 32240f9b053ee22a688402b6e1aca392ad3a0f30 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sat, 12 Oct 2024 10:20:42 +0200 Subject: [PATCH 66/95] Found unhandled export case (negation of multibit word) bir_smtlibLib --- src/shared/examples/test-bir_smtLib.sml | 216 ++++++++++++++++++++++++ 1 file changed, 216 insertions(+) create mode 100644 src/shared/examples/test-bir_smtLib.sml diff --git a/src/shared/examples/test-bir_smtLib.sml b/src/shared/examples/test-bir_smtLib.sml new file mode 100644 index 000000000..e2c887800 --- /dev/null +++ b/src/shared/examples/test-bir_smtLib.sml @@ -0,0 +1,216 @@ +open HolKernel Parse boolLib bossLib; + + +val taut_inputs = [ + (``BExp_BinExp BIExp_Or + (BExp_UnaryExp BIExp_Not + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_Equal + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 pre_countw))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 0xFFFFFEBw)))) + (BExp_Den (BVar "syp_gen" (BType_Imm Bit1)))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_BinExp BIExp_LeftShift (BExp_Const (Imm32 1w)) + (BExp_Const (Imm32 16w))) + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_LeftShift (BExp_Const (Imm32 1w)) + (BExp_Const (Imm32 16w))) (BExp_Const (Imm32 8w))) + (BExp_BinExp BIExp_RightShift + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))) + (BExp_Const (Imm32 16w))))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_LeftShift (BExp_Const (Imm32 1w)) + (BExp_Const (Imm32 16w))) (BExp_Const (Imm32 8w))) + (BExp_Const (Imm32 4w))) + (BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_RightShift + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))) + (BExp_Const (Imm32 16w))) (BExp_Const (Imm32 8w))))) + (BExp_BinPred BIExp_Equal (BExp_Den (BVar "syf_1" (BType_Imm Bit1))) + (BExp_BinPred BIExp_Equal + (BExp_Cast BIExp_UnsignedCast + (BExp_Load (BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))) + (BExp_BinExp BIExp_Plus + (BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_RightShift + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))) + (BExp_Const (Imm32 16w))) + (BExp_Const (Imm32 8w))) (BExp_Const (Imm32 4w))) + (BExp_Const (Imm32 0x100013DEw))) BEnd_LittleEndian Bit8) + Bit32) + (BExp_UnaryExp BIExp_ChangeSign + (BExp_BinExp BIExp_Minus + (BExp_BinExp BIExp_Minus + (BExp_BinExp BIExp_Minus (BExp_Const (Imm32 28w)) + (BExp_Const (Imm32 16w))) (BExp_Const (Imm32 8w))) + (BExp_Const (Imm32 4w)))))))) + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_Equal + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 pre_countw))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 0xFFFFFEBw)))) + (BExp_Den (BVar "syp_gen" (BType_Imm Bit1)))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_BinExp BIExp_LeftShift (BExp_Const (Imm32 1w)) + (BExp_Const (Imm32 16w))) + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_LeftShift (BExp_Const (Imm32 1w)) + (BExp_Const (Imm32 16w))) (BExp_Const (Imm32 8w))) + (BExp_BinExp BIExp_RightShift + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))) + (BExp_Const (Imm32 16w))))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_LeftShift (BExp_Const (Imm32 1w)) + (BExp_Const (Imm32 16w))) (BExp_Const (Imm32 8w))) + (BExp_Const (Imm32 4w))) + (BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_RightShift + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))) + (BExp_Const (Imm32 16w))) (BExp_Const (Imm32 8w)))))``, true), + + (``BExp_BinExp BIExp_Or + (BExp_UnaryExp BIExp_Not + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_Equal + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 pre_countw))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 0xFFFFFEBw))))) + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 (1w + 4w)))) (BExp_Const (Imm64 pre_countw))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 (1w + 4w)))) (BExp_Const (Imm64 0xFFFFFEBw)))) + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_Equal + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 pre_countw))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 0xFFFFFEBw)))))``, false), + + (``BExp_BinExp BIExp_Or + (BExp_UnaryExp BIExp_Not + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_Equal + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 pre_countw))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 0xFFFFFEBw)))) + (BExp_Den (BVar "syp_gen" (BType_Imm Bit1)))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_BinExp BIExp_LeftShift (BExp_Const (Imm32 1w)) + (BExp_Const (Imm32 16w))) + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_LeftShift (BExp_Const (Imm32 1w)) + (BExp_Const (Imm32 16w))) (BExp_Const (Imm32 8w))) + (BExp_BinExp BIExp_RightShift + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))) + (BExp_Const (Imm32 16w))))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_LeftShift (BExp_Const (Imm32 1w)) + (BExp_Const (Imm32 16w))) (BExp_Const (Imm32 8w))) + (BExp_Const (Imm32 4w))) + (BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_RightShift + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))) + (BExp_Const (Imm32 16w))) (BExp_Const (Imm32 8w))))) + (BExp_BinPred BIExp_Equal (BExp_Den (BVar "syf_4" (BType_Imm Bit1))) + (BExp_BinPred BIExp_LessThan + (BExp_UnaryExp BIExp_Not + (BExp_BinExp BIExp_Minus + (BExp_BinExp BIExp_Minus + (BExp_BinExp BIExp_Minus (BExp_Const (Imm32 28w)) + (BExp_Const (Imm32 16w))) (BExp_Const (Imm32 8w))) + (BExp_Const (Imm32 4w)))) + (BExp_Cast BIExp_UnsignedCast + (BExp_Load (BExp_Den (BVar "sy_MEM" (BType_Mem Bit32 Bit8))) + (BExp_BinExp BIExp_Plus + (BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_RightShift + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))) + (BExp_Const (Imm32 16w))) + (BExp_Const (Imm32 8w))) (BExp_Const (Imm32 4w))) + (BExp_Const (Imm32 0x100013DEw))) BEnd_LittleEndian Bit8) + Bit32))))) + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_Equal + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 pre_countw))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 0xFFFFFEBw)))) + (BExp_Den (BVar "syp_gen" (BType_Imm Bit1)))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_BinExp BIExp_LeftShift (BExp_Const (Imm32 1w)) + (BExp_Const (Imm32 16w))) + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_LeftShift (BExp_Const (Imm32 1w)) + (BExp_Const (Imm32 16w))) (BExp_Const (Imm32 8w))) + (BExp_BinExp BIExp_RightShift + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))) + (BExp_Const (Imm32 16w))))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_LeftShift (BExp_Const (Imm32 1w)) + (BExp_Const (Imm32 16w))) (BExp_Const (Imm32 8w))) + (BExp_Const (Imm32 4w))) + (BExp_BinExp BIExp_RightShift + (BExp_BinExp BIExp_RightShift + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))) + (BExp_Const (Imm32 16w))) (BExp_Const (Imm32 8w)))))``, true) +]; + +val _ = holba_z3Lib.debug_print := true; + +val _ = List.map (fn (inputexp, expected_output) => + if bir_smtLib.bir_smt_check_taut false inputexp = expected_output then () + else raise Fail "wrong output" + ) taut_inputs; From 73a8ed59fe72448b22c449e4ffcf9b9ffc26c2ed Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sat, 12 Oct 2024 13:45:12 +0200 Subject: [PATCH 67/95] Reorganize a bit --- src/tools/symbexec/bir_symbLib.sig | 4 +- src/tools/symbexec/bir_symbLib.sml | 124 ++++++++---------- src/tools/symbexec/birs_driveLib.sml | 44 ++++++- .../symbexec/examples/test-birs_transfer.sml | 33 ++--- 4 files changed, 111 insertions(+), 94 deletions(-) diff --git a/src/tools/symbexec/bir_symbLib.sig b/src/tools/symbexec/bir_symbLib.sig index fd86b96e3..270f034ef 100644 --- a/src/tools/symbexec/bir_symbLib.sig +++ b/src/tools/symbexec/bir_symbLib.sig @@ -5,7 +5,9 @@ sig val birs_simp_select : (term -> thm) ref; - val bir_symb_analysis : term -> term -> term list -> term -> term -> thm; + val bir_symb_analysis_init_gen : term option -> term -> term -> thm -> term * thm * thm; + + val bir_symb_analysis : term -> term list -> term -> thm; val bir_symb_analysis_thm : thm -> thm -> thm list -> thm -> thm -> thm * thm; diff --git a/src/tools/symbexec/bir_symbLib.sml b/src/tools/symbexec/bir_symbLib.sml index 7b77db6e0..8b5a45579 100644 --- a/src/tools/symbexec/bir_symbLib.sml +++ b/src/tools/symbexec/bir_symbLib.sml @@ -3,12 +3,14 @@ struct open Abbrev; +(* error handling *) +val libname = "bir_symbLib" +val ERR = Feedback.mk_HOL_ERR libname +val wrap_exn = Feedback.wrap_exn libname + local open HolKernel Parse boolLib bossLib; open bitTheory; - open birs_execLib; - open birs_composeLib; - open birs_driveLib; open birs_auxTheory; open bir_immSyntax; @@ -28,78 +30,66 @@ in (* TODO: later make the whole post step function a parameter to the symb_analysis function *) val birs_simp_select = ref birs_simp_instancesLib.birs_simp_default_riscv; -fun bir_symb_analysis bprog_tm birs_state_init_lbl - birs_end_lbls birs_env birs_pcond = +val pcond_gen_symb = ``BVar "syp_gen" (BType_Imm Bit1)``; + +fun bir_symb_analysis_init_gen pcond_symb_o birs_state_init_lbl bspec_pre_tm birenvtyl_def = + let + val bprog_envtyl_tm = (fst o dest_eq o concl) birenvtyl_def; + + val bsysprecond_tm_f = Option.getOpt (Option.map (fn tm => fn x => ``BExp_BinExp BIExp_And (^x) (BExp_Den (^tm))``) pcond_symb_o, I); + val mk_bsysprecond_pcond_thm = + (computeLib.RESTR_EVAL_CONV [``birs_eval_exp``] THENC birs_stepLib.birs_eval_exp_CONV) + (bsysprecond_tm_f ``mk_bsysprecond ^bspec_pre_tm ^bprog_envtyl_tm``); + val birs_pcond_tm = (snd o dest_eq o concl) mk_bsysprecond_pcond_thm; + + val senv_GEN_list_thm = (REWRITE_CONV [birenvtyl_def] THENC EVAL THENC REWRITE_CONV [GSYM birs_gen_env_thm, GSYM birs_gen_env_NULL_thm]) ``bir_senv_GEN_list ^bprog_envtyl_tm``; + val birs_env_tm = (snd o dest_eq o concl) senv_GEN_list_thm; + + val pcond_is_sat = bir_smtLib.bir_smt_check_sat false birs_pcond_tm; + val _ = if pcond_is_sat then () else + raise ERR "bir_symb_analysis_init_gen" "initial pathcondition is not satisfiable; it seems to contain a contradiction"; + + val birs_state_init = ``<| + bsst_pc := ^birs_state_init_lbl; + bsst_environ := ^birs_env_tm; + bsst_status := BST_Running; + bsst_pcond := ^birs_pcond_tm + |>``; + in + (birs_state_init, senv_GEN_list_thm, mk_bsysprecond_pcond_thm) + end; + +fun bir_symb_analysis bprog_tm birs_end_lbls birs_state = let - val pcond_is_sat = bir_smtLib.bir_smt_check_sat false birs_pcond; - val _ = if pcond_is_sat then () else - raise Feedback.mk_HOL_ERR "bir_symbLib" "bir_symb_analysis" "initial pathcondition is not satisfiable; it seems to contain a contradiction"; - val birs_state_init = ``<| - bsst_pc := ^birs_state_init_lbl; - bsst_environ := ^birs_env; - bsst_status := BST_Running; - bsst_pcond := ^birs_pcond - |>``; val timer_symbanalysis = holba_miscLib.timer_start 0; val timer_symbanalysis_last = ref (holba_miscLib.timer_start 0); - val birs_rule_STEP_thm = birs_rule_STEP_prog_fun (bir_prog_has_no_halt_fun bprog_tm); + + open birs_execLib; val birs_rule_SUBST_thm = birs_rule_SUBST_prog_fun bprog_tm; fun birs_post_step_fun (t, (last_pc, last_stmt)) = ( - (fn t => ( + (fn t => ( holba_miscLib.timer_stop (fn delta_s => print ("running since " ^ delta_s ^ "\n")) timer_symbanalysis; holba_miscLib.timer_stop (fn delta_s => print ("time since last step " ^ delta_s ^ "\n")) (!timer_symbanalysis_last); timer_symbanalysis_last := holba_miscLib.timer_start 0; - (*print_term ((last o pairSyntax.strip_pair o snd o dest_comb o concl) t);*) - t)) o - apply_if_assign last_stmt (birs_rule_SUBST_trysimp_fun birs_rule_SUBST_thm (!birs_simp_select)) o - birs_rule_tryprune_fun birs_rulesTheory.branch_prune1_spec_thm o - birs_rule_tryprune_fun birs_rulesTheory.branch_prune2_spec_thm o - birs_rule_tryjustassert_fun true - ) t; - val birs_rule_STEP_fun_spec = - (birs_post_step_fun o - birs_rule_STEP_fun birs_rule_STEP_thm); - (* now the composition *) - val birs_rule_SEQ_thm = birs_rule_SEQ_prog_fun bprog_tm; - val birs_rule_SEQ_fun_spec = birs_rule_SEQ_fun birs_rule_SEQ_thm; - val single_step_A_thm = birs_rule_STEP_fun_spec birs_state_init; - (*val _ = print_thm single_step_A_thm;*) - (* and also the sequential composition *) - val birs_rule_STEP_SEQ_thm = MATCH_MP - birs_rulesTheory.birs_rule_STEP_SEQ_gen_thm - (bir_prog_has_no_halt_fun bprog_tm); - val birs_rule_STEP_SEQ_fun_spec = - (birs_post_step_fun o - birs_rule_STEP_SEQ_fun (birs_rule_SUBST_thm, birs_rule_STEP_SEQ_thm)); - - val _ = print "now reducing it to one sound structure\n"; - val timer = holba_miscLib.timer_start 0; - val result = exec_until - (birs_rule_STEP_fun_spec, birs_rule_SEQ_fun_spec, birs_rule_STEP_SEQ_fun_spec) - single_step_A_thm birs_end_lbls - handle e => (Profile.print_profile_results (Profile.results ()); raise e); - val _ = holba_miscLib.timer_stop - (fn delta_s => print ("\n======\n > exec_until took " ^ delta_s ^ "\n")) timer; - -(* - -Profile.reset_all () - -Profile.print_profile_results (Profile.results ()) -Profile.output_profile_results (iostream) (Profile.results ()) - -*) - val _ = Profile.print_profile_results (Profile.results ()); + (*print_term ((last o pairSyntax.strip_pair o snd o dest_comb o concl) t);*) + t)) o + apply_if_assign last_stmt (birs_rule_SUBST_trysimp_fun birs_rule_SUBST_thm (!birs_simp_select)) o + birs_rule_tryprune_fun birs_rulesTheory.branch_prune1_spec_thm o + birs_rule_tryprune_fun birs_rulesTheory.branch_prune2_spec_thm o + birs_rule_tryjustassert_fun true + ) t; in - result + birs_driveLib.bir_symb_exec_to (bprog_tm, birs_post_step_fun) birs_end_lbls birs_state end (* let *) + fun bir_symb_analysis_thm_gen pcond_symb_o bir_prog_def init_addr_def end_addr_defs bspec_pre_def birenvtyl_def = let val _ = print "\n======\n > bir_symb_analysis_thm started\n"; val timer = holba_miscLib.timer_start 0; + val bprog_tm = (fst o dest_eq o concl) bir_prog_def; val init_addr_tm = (snd o dest_eq o concl) init_addr_def; val birs_state_init_lbl_tm = @@ -111,22 +101,14 @@ fun bir_symb_analysis_thm_gen pcond_symb_o bir_prog_def (snd o dest_eq o concl o EVAL) ``bir_block_pc (BL_Address ^(gen_mk_Imm end_addr_tm))`` end) end_addr_defs; val bspec_pre_tm = (lhs o snd o strip_forall o concl) bspec_pre_def; - val bprog_envtyl_tm = (fst o dest_eq o concl) birenvtyl_def; - - val bsysprecond_tm_f = Option.getOpt (Option.map (fn tm => fn x => ``BExp_BinExp BIExp_And (^x) (BExp_Den (^tm))``) pcond_symb_o, I); - val bsysprecond_thm = - (computeLib.RESTR_EVAL_CONV [``birs_eval_exp``] THENC birs_stepLib.birs_eval_exp_CONV) - (bsysprecond_tm_f ``mk_bsysprecond ^bspec_pre_tm ^bprog_envtyl_tm``); - val birs_pcond_tm = (snd o dest_eq o concl) bsysprecond_thm; - - val birs_env_thm = (REWRITE_CONV [birenvtyl_def] THENC EVAL THENC REWRITE_CONV [GSYM birs_gen_env_thm, GSYM birs_gen_env_NULL_thm]) ``bir_senv_GEN_list ^bprog_envtyl_tm``; - val birs_env_tm = (snd o dest_eq o concl) birs_env_thm; + val (birs_state_init, birs_env_thm, bsysprecond_thm) = + bir_symb_analysis_init_gen pcond_symb_o birs_state_init_lbl_tm bspec_pre_tm birenvtyl_def; val symb_analysis_thm = bir_symb_analysis - bprog_tm birs_state_init_lbl_tm birs_state_end_tm_lbls - birs_env_tm birs_pcond_tm; - val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n======\n > bir_symb_analysis_thm took " ^ delta_s ^ "\n")) timer; + bprog_tm birs_state_end_tm_lbls birs_state_init; val symb_analysis_fix_thm = CONV_RULE (RAND_CONV (LAND_CONV (REWRITE_CONV [GSYM birs_env_thm]))) symb_analysis_thm; + + val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n======\n > bir_symb_analysis_thm took " ^ delta_s ^ "\n")) timer; in (bsysprecond_thm, symb_analysis_fix_thm) end (* let *) diff --git a/src/tools/symbexec/birs_driveLib.sml b/src/tools/symbexec/birs_driveLib.sml index 62fc3791c..68a9d8b0f 100644 --- a/src/tools/symbexec/birs_driveLib.sml +++ b/src/tools/symbexec/birs_driveLib.sml @@ -66,7 +66,7 @@ val SUBST_thm = birs_rule_SUBST_thm; val STEP_SEQ_thm = birs_rule_STEP_SEQ_thm; val symbex_A_thm = single_step_A_thm; *) -fun birs_rule_STEP_SEQ_fun (SUBST_thm, STEP_SEQ_thm) symbex_A_thm = +fun birs_rule_STEP_SEQ_fun STEP_SEQ_thm symbex_A_thm = let val step1_thm = MATCH_MP STEP_SEQ_thm symbex_A_thm; val step2_thm = REWRITE_RULE [bir_symbTheory.birs_state_t_accessors, bir_symbTheory.birs_state_t_accfupds, combinTheory.K_THM] step1_thm; @@ -177,6 +177,48 @@ fun exec_until (STEP_fun_spec, SEQ_fun_spec, STEP_SEQ_fun_spec) symbex_A_thm sto Profile.profile "reduce_tree" (reduce_tree SEQ_fun_spec) tree end; +fun bir_symb_exec_to (bprog_tm, birs_post_step_fun) birs_end_lbls birs_state = + let + val _ = if birs_state_is_normform_gen false birs_state then () else + raise ERR "bir_symb_exec_to" "state is not in standard form with birs_gen_env"; + + open birs_execLib; + + val birs_rule_STEP_thm = birs_rule_STEP_prog_fun (bir_prog_has_no_halt_fun bprog_tm); + val birs_rule_STEP_fun_spec = + (birs_post_step_fun o + birs_rule_STEP_fun birs_rule_STEP_thm); + (* now the composition *) + val birs_rule_SEQ_thm = birs_rule_SEQ_prog_fun bprog_tm; + val birs_rule_SEQ_fun_spec = birs_rule_SEQ_fun birs_rule_SEQ_thm; + val single_step_A_thm = birs_rule_STEP_fun_spec birs_state; + (*val _ = print_thm single_step_A_thm;*) + (* and also the sequential composition *) + val birs_rule_STEP_SEQ_thm = MATCH_MP + birs_rulesTheory.birs_rule_STEP_SEQ_gen_thm + (bir_prog_has_no_halt_fun bprog_tm); + val birs_rule_STEP_SEQ_fun_spec = + (birs_post_step_fun o + birs_rule_STEP_SEQ_fun birs_rule_STEP_SEQ_thm); + + val _ = print "now reducing it to one sound structure\n"; + val timer = holba_miscLib.timer_start 0; + val result = exec_until + (birs_rule_STEP_fun_spec, birs_rule_SEQ_fun_spec, birs_rule_STEP_SEQ_fun_spec) + single_step_A_thm birs_end_lbls + handle e => (Profile.print_profile_results (Profile.results ()); raise e); + val _ = holba_miscLib.timer_stop + (fn delta_s => print ("\n======\n > exec_until took " ^ delta_s ^ "\n")) timer; + + (* + Profile.reset_all () + Profile.print_profile_results (Profile.results ()) + Profile.output_profile_results (iostream) (Profile.results ()) + *) + val _ = Profile.print_profile_results (Profile.results ()); + in + result + end; end (* local *) diff --git a/src/tools/symbexec/examples/test-birs_transfer.sml b/src/tools/symbexec/examples/test-birs_transfer.sml index 0dc98f61b..9ff2ece9e 100644 --- a/src/tools/symbexec/examples/test-birs_transfer.sml +++ b/src/tools/symbexec/examples/test-birs_transfer.sml @@ -94,6 +94,18 @@ val bprecond_def = Define ` `; val bprecond = (fst o dest_eq o concl) bprecond_def; +val (birs_state_init, birs_env_thm, bsysprecond_thm) = + bir_symb_analysis_init_gen NONE birs_state_init_lbl bprecond birenvtyl_def; +val symb_analysis_thm = bir_symb_analysis + bprog [birs_state_end_lbl] birs_state_init; +val exec_thm = CONV_RULE (RAND_CONV (LAND_CONV (REWRITE_CONV [GSYM birs_env_thm]))) symb_analysis_thm; + +val (sys_tm, L_tm, Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) exec_thm; + + +(* ---------------------------------------------------------------------- *) + +(* need the following legacy code because mk_bsysprecond (via birs_env_thm) is not incorporated into the rest of the code yet *) (* need to translate the precondition to a symbolic pathcondition, it means taking from the environment the corresponding mappings and substitute (that's symbolic evaluation) (then we know that states with matching environments also satisfy the original precondition because it is constructed by symbolic evaluation) *) val bsysprecond_def = Define ` bsysprecond = FST (THE (birs_eval_exp ^bprecond (bir_senv_GEN_list birenvtyl))) @@ -114,27 +126,6 @@ val bprecond_birs_eval_exp_thm2 = save_thm( ); val bsysprecond = (snd o dest_eq o concl) bsysprecond_thm (*(fst o dest_eq o concl) bsysprecond_def*); -(* ---------------------------------------------------------------------- *) - - -val bprog_tm = (fst o dest_eq o concl) bprog_test_def; -val birs_state_init_lbl_tm = birs_state_init_lbl; -val birs_state_end_tm_lbls = [birs_state_end_lbl]; -val birs_pcond_tm = bsysprecond; - -val birs_env_thm = (REWRITE_CONV [birenvtyl_def] THENC EVAL THENC REWRITE_CONV [GSYM birs_gen_env_thm, GSYM birs_gen_env_NULL_thm]) ``bir_senv_GEN_list birenvtyl``; -val birs_env_tm = (snd o dest_eq o concl) birs_env_thm; - -val symb_analysis_thm = - bir_symb_analysis - bprog_tm - birs_state_init_lbl_tm - birs_state_end_tm_lbls - birs_env_tm - birs_pcond_tm; - -val exec_thm = CONV_RULE (RAND_CONV (LAND_CONV (REWRITE_CONV [GSYM birs_env_thm]))) symb_analysis_thm; -val (sys_tm, L_tm, Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) exec_thm; (* ---------------------------------------------------------------------- *) (* ---------------------------------------------------------------------- *) From a20a5c9d30b92c8899ebfbfcb1ab8be7abc803ed Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sat, 12 Oct 2024 15:14:58 +0200 Subject: [PATCH 68/95] Deactivate the failing test input for now --- src/shared/examples/test-bir_smtLib.sml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/shared/examples/test-bir_smtLib.sml b/src/shared/examples/test-bir_smtLib.sml index e2c887800..7f3552953 100644 --- a/src/shared/examples/test-bir_smtLib.sml +++ b/src/shared/examples/test-bir_smtLib.sml @@ -116,7 +116,7 @@ val taut_inputs = [ (BExp_Const (Imm64 pre_countw))) (BExp_BinPred BIExp_LessOrEqual (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) - (BExp_Const (Imm64 0xFFFFFEBw)))))``, false), + (BExp_Const (Imm64 0xFFFFFEBw)))))``, false) (*, (``BExp_BinExp BIExp_Or (BExp_UnaryExp BIExp_Not @@ -206,6 +206,7 @@ val taut_inputs = [ (BExp_BinExp BIExp_RightShift (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))) (BExp_Const (Imm32 16w))) (BExp_Const (Imm32 8w)))))``, true) + *) ]; val _ = holba_z3Lib.debug_print := true; From fdd91c6094ee8774eadbfdc1d4deb08d6fdcfa1a Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sat, 12 Oct 2024 17:46:19 +0200 Subject: [PATCH 69/95] Fixes and improvements --- src/tools/symbexec/bir_symbLib.sig | 2 ++ src/tools/symbexec/birsSyntax.sml | 2 +- src/tools/symbexec/birs_instantiationLib.sml | 6 ++--- src/tools/symbexec/birs_mergeLib.sml | 24 +++++++++++++------- 4 files changed, 21 insertions(+), 13 deletions(-) diff --git a/src/tools/symbexec/bir_symbLib.sig b/src/tools/symbexec/bir_symbLib.sig index 270f034ef..142d94433 100644 --- a/src/tools/symbexec/bir_symbLib.sig +++ b/src/tools/symbexec/bir_symbLib.sig @@ -5,6 +5,8 @@ sig val birs_simp_select : (term -> thm) ref; + val pcond_gen_symb : term; + val bir_symb_analysis_init_gen : term option -> term -> term -> thm -> term * thm * thm; val bir_symb_analysis : term -> term list -> term -> thm; diff --git a/src/tools/symbexec/birsSyntax.sml b/src/tools/symbexec/birsSyntax.sml index ab15c3240..ca286b97b 100644 --- a/src/tools/symbexec/birsSyntax.sml +++ b/src/tools/symbexec/birsSyntax.sml @@ -248,7 +248,7 @@ fun symb_sound_struct_is_normform tm = val (sys, L, Pi) = symb_sound_struct_get_sysLPi_fun tm handle _ => raise ERR "symb_sound_struct_is_normform" "unexpected term, should be a birs_symb_exec with a triple as structure"; - val sys_ok = birs_state_is_normform_gen true sys; + val sys_ok = birs_state_is_normform_gen false sys; val L_ok = is_a_normform_set L; val Pi_ok = birs_states_are_normform Pi; in diff --git a/src/tools/symbexec/birs_instantiationLib.sml b/src/tools/symbexec/birs_instantiationLib.sml index 84c6a6a0a..95078e8c9 100644 --- a/src/tools/symbexec/birs_instantiationLib.sml +++ b/src/tools/symbexec/birs_instantiationLib.sml @@ -122,18 +122,16 @@ in (* local *) val len_of_thm_Pi = get_birs_Pi_length o concl; open birs_auxTheory; - (* need to unfold bir_senv_GEN_list of sys in B_thm to get a standard birs_gen_env (needed for constructing the map and also for instantiation) *) - val B_thm_norm = CONV_RULE (birs_sys_CONV (EVAL THENC REWRITE_CONV [GSYM birs_gen_env_thm, GSYM birs_gen_env_NULL_thm])) B_thm; (* identify instantiation needed for B, assumes to take the first state in Pi of A, - environment mappings - the generic path condition symbol bv_syp_gen - renaming of all free symbols for good measure *) - val symb_exp_map = birs_find_symb_exp_map bv_syp_gen A_thm B_thm_norm; + val symb_exp_map = birs_find_symb_exp_map bv_syp_gen A_thm B_thm; (*val _ = List.map (fn (bv_symb,exp) => (print_term bv_symb; print "|->\n"; print_term exp; print "\n")) symb_exp_map;*) (* instantiate all *) - val B_thm_inst = birs_sound_symb_inst_RULE symb_exp_map B_thm_norm; + val B_thm_inst = birs_sound_symb_inst_RULE symb_exp_map B_thm; (* take care of path conditions (after instantiating bv_syp_gen) *) (* ------- *) diff --git a/src/tools/symbexec/birs_mergeLib.sml b/src/tools/symbexec/birs_mergeLib.sml index ed6a304ab..182ee1680 100644 --- a/src/tools/symbexec/birs_mergeLib.sml +++ b/src/tools/symbexec/birs_mergeLib.sml @@ -14,6 +14,8 @@ local val ERR = Feedback.mk_HOL_ERR libname val wrap_exn = Feedback.wrap_exn libname + val debug_mode = false; + in (* local *) (* @@ -72,9 +74,11 @@ in (* local *) (* create updated state (pcond and env), and purge previous environment mapping *) val env_mod = mk_birs_update_env (pairSyntax.mk_pair (vn, exp_new), env_old); + val _ = print "created update env exp\n"; val purge_update_env_conv = REWRITE_CONV [birs_auxTheory.birs_update_env_thm] THENC RAND_CONV EVAL; + val _ = print "purged update env exp\n"; val env_new = (snd o dest_eq o concl o purge_update_env_conv) env_mod; val pcond_new = bslSyntax.band (pcond_old, bslSyntax.beq (bslSyntax.bden symb_tm, exp_tm)); val Pi_sys_new_tm = mk_birs_state (pc, env_new, status, pcond_new); @@ -93,7 +97,7 @@ in (* local *) (* check that initial and modified state don't contain the free symbol (i.e., that it really is free) *) val symbs = List.map (pred_setSyntax.strip_set o snd o dest_eq o concl o bir_vars_ofLib.birs_symb_symbols_DIRECT_CONV o (fn x => ``birs_symb_symbols ^x``)) - [(snd o dest_eq o concl o birs_env_CONV true (EVAL THENC REWRITE_CONV [GSYM birs_auxTheory.birs_gen_env_NULL_thm, GSYM birs_auxTheory.birs_gen_env_thm])) sys_tm, Pi_sys_old_tm]; + [sys_tm, Pi_sys_old_tm]; val _ = if not (List.exists (fn x => identical x symb_tm) (List.concat symbs)) then () else let val _ = print_term symb_tm; @@ -219,7 +223,7 @@ in (* local *) (* apply the freesymboling as instructed by forget_exps *) val thm_free = List.foldl birs_Pi_first_env_top_mapping_merge_fold thm_shuffled forget_exps; (*val _ = print_thm thm_free;*) - val _ = print "\ndone with birs_Pi_first_env_top_mapping_merge_store\n"; + val _ = if not debug_mode then () else print "\ndone with birs_Pi_first_env_top_mapping_merge_store\n"; in thm_free end; @@ -238,11 +242,12 @@ in (* local *) if is_BExp_Store exp1 andalso is_BExp_Store exp2 then birs_Pi_first_env_top_mapping_merge_store exp1 exp2 thm else - (* TODO: interval (specifically countw) *) + (* TODO: interval (specifically countw and SP) *) if false then raise ERR "birs_Pi_first_env_top_mapping_merge" "not implemented yet" else (* just unify all others *) - default_op thm + (if not debug_mode then () else print "applying default_op\n"; + default_op thm) end; val INSERT_INSERT_EQ_thm = prove(`` @@ -256,7 +261,7 @@ in (* local *) (* the merge function for the first two Pi states *) fun birs_Pi_merge_2_RULE thm = let - val _ = print "merging the first two in Pi\n"; + val _ = if not debug_mode then () else print "merging the first two in Pi\n"; val timer = holba_miscLib.timer_start 0; val _ = if (symb_sound_struct_is_normform o concl) thm then () else raise ERR "birs_Pi_merge_2_RULE" "theorem is not a standard birs_symb_exec"; @@ -277,16 +282,19 @@ in (* local *) (* for each mapped variable: *) val thm_env = List.foldl (fn (vn, thm0) => let + val _ = if not debug_mode then () else print ("start a mapping:" ^ vn ^ "\n"); (* move the mapping to the top *) val thm1 = CONV_RULE (birs_Pi_first_CONV (birs_env_var_top_CONV vn)) thm0; val exp1 = (snd o get_birs_Pi_first_env_top_mapping o concl) thm1; val thm2 = birs_Pi_rotate_RULE thm1; val thm3 = CONV_RULE (birs_Pi_first_CONV (birs_env_var_top_CONV vn)) thm2; val exp2 = (snd o get_birs_Pi_first_env_top_mapping o concl) thm3; + val _ = if not debug_mode then () else print "got the expressions\n"; val thm4 = birs_Pi_first_env_top_mapping_merge exp2 exp1 thm3; + val _ = if not debug_mode then () else print "fixed the mapping\n"; in thm4 end) thm varnames; - val _ = print "unified envs\n"; + val _ = if not debug_mode then () else print "unified envs\n"; (* also unify the two path conditions *) val thm_env_pcond = @@ -307,7 +315,7 @@ in (* local *) (* fix the path condition in both states accordingly *) val thm2 = (birs_Pi_first_pcond_RULE pcond_common o birs_Pi_rotate_RULE o birs_Pi_first_pcond_RULE pcond_common) thm1; in thm2 end; - val _ = print "unified pcond\n"; + val _ = if not debug_mode then () else print "unified pcond\n"; (* merge the first two states in the HOL4 pred_set *) (* (TODO: maybe need to prove that they are equal because they are not syntactically identical) *) @@ -317,7 +325,7 @@ in (* local *) val rewrite_thm_fix = CONV_RULE (CHANGED_CONV (QUANT_CONV (LAND_CONV (*aux_setLib.birs_state_EQ_CONV*)EVAL))) rewrite_thm; val thm_merged = CONV_RULE (CHANGED_CONV (birs_Pi_CONV (REWRITE_CONV [rewrite_thm_fix]))) thm_env_pcond;*) val thm_merged = CONV_RULE (CHANGED_CONV (birs_Pi_CONV (REWRITE_CONV [ISPEC ((get_birs_Pi_first o concl) thm_env_pcond) pred_setTheory.INSERT_INSERT]))) thm_env_pcond; - val _ = print "eliminated one from Pi\n"; + val _ = if not debug_mode then () else print "eliminated one from Pi\n"; val _ = holba_miscLib.timer_stop (fn delta_s => print (" merging two in Pi took " ^ delta_s ^ "\n")) timer; in From 3d5bca7af6d8f711a5c8fa2440ecff802ce1ee95 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sun, 13 Oct 2024 22:12:28 +0200 Subject: [PATCH 70/95] Add interval prototype --- src/theory/tools/symbexec/birs_auxScript.sml | 59 +++ src/tools/symbexec/birsSyntax.sml | 3 + src/tools/symbexec/birs_intervalLib.sml | 367 +++++++++++++++++++ src/tools/symbexec/birs_mergeLib.sml | 16 +- src/tools/symbexec/birs_utilsLib.sml | 73 +++- 5 files changed, 498 insertions(+), 20 deletions(-) create mode 100644 src/tools/symbexec/birs_intervalLib.sml diff --git a/src/theory/tools/symbexec/birs_auxScript.sml b/src/theory/tools/symbexec/birs_auxScript.sml index 292d089bd..0f6766460 100644 --- a/src/theory/tools/symbexec/birs_auxScript.sml +++ b/src/theory/tools/symbexec/birs_auxScript.sml @@ -871,4 +871,63 @@ QED *) + +Definition BExp_IntervalPred_def: + BExp_IntervalPred e (e_l, e_h) = + BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual e_l e) + (BExp_BinPred BIExp_LessOrEqual e e_h) +End + +Theorem bir_vars_of_exp_BExp_IntervalPred_thm: + !e e_l e_h. + bir_vars_of_exp (BExp_IntervalPred e (e_l, e_h)) = + (bir_vars_of_exp e UNION + bir_vars_of_exp e_l UNION + bir_vars_of_exp e_h) +Proof + fs [BExp_IntervalPred_def, bir_typing_expTheory.bir_vars_of_exp_def] >> + metis_tac [UNION_COMM, UNION_ASSOC, UNION_IDEMPOT] +QED + +Theorem bir_eval_exp_BExp_IntervalPred_thm: + !e e_l e_h env. + bir_eval_exp (BExp_IntervalPred e (e_l, e_h)) env = ( + bir_eval_bin_exp BIExp_And + (bir_eval_bin_pred BIExp_LessOrEqual + (bir_eval_exp e_l env) + (bir_eval_exp e env)) + (bir_eval_bin_pred BIExp_LessOrEqual + (bir_eval_exp e env) + (bir_eval_exp e_h env))) +Proof + fs [BExp_IntervalPred_def, bir_expTheory.bir_eval_exp_def] +QED + +Theorem type_of_bir_exp_BExp_IntervalPred_thm: + !e e_l e_h. + type_of_bir_exp (BExp_IntervalPred e (e_l, e_h)) = + (case (type_of_bir_exp e, type_of_bir_exp e_l, type_of_bir_exp e_h) of + (SOME (BType_Imm ty), SOME (BType_Imm lty), SOME (BType_Imm hty)) => + (if ((ty = lty) /\ (ty = hty)) then SOME (BType_Imm Bit1) else NONE) + | _, _ => NONE) +Proof + fs [BExp_IntervalPred_def, bir_typing_expTheory.type_of_bir_exp_def] >> + Cases_on ‘type_of_bir_exp e’ >> Cases_on ‘type_of_bir_exp e_l’ >> Cases_on ‘type_of_bir_exp e_h’ >> ( + EVAL_TAC + ) >- ( + CASE_TAC + ) >- ( + CASE_TAC + ) >- ( + Cases_on ‘x’ >> Cases_on ‘x'’ >> EVAL_TAC >> CASE_TAC + ) >> + + Cases_on ‘x’ >> Cases_on ‘x'’ >> Cases_on ‘x''’ >> FULL_SIMP_TAC std_ss [bir_valuesTheory.bir_type_t_11] >> EVAL_TAC >> CASE_TAC >> ( + FULL_SIMP_TAC std_ss []) >> + CASE_TAC >> FULL_SIMP_TAC std_ss [] +QED + + + val _ = export_theory(); diff --git a/src/tools/symbexec/birsSyntax.sml b/src/tools/symbexec/birsSyntax.sml index ca286b97b..75bd89c2e 100644 --- a/src/tools/symbexec/birsSyntax.sml +++ b/src/tools/symbexec/birsSyntax.sml @@ -44,10 +44,13 @@ local val syntax_fns1 = syntax_fns 1 HolKernel.dest_monop HolKernel.mk_monop; val syntax_fns1_env = syntax_fns 2 HolKernel.dest_monop HolKernel.mk_monop; val syntax_fns1_set = syntax_fns 2 HolKernel.dest_monop HolKernel.mk_monop; + val syntax_fns2 = syntax_fns 2 HolKernel.dest_binop HolKernel.mk_binop; in val (birs_gen_env_tm, mk_birs_gen_env, dest_birs_gen_env, is_birs_gen_env) = syntax_fns1_env "birs_gen_env"; val (bir_senv_GEN_list_tm, mk_bir_senv_GEN_list, dest_bir_senv_GEN_list, is_bir_senv_GEN_list) = syntax_fns1_env "bir_senv_GEN_list"; val (birs_exps_of_senv_tm, mk_birs_exps_of_senv, dest_birs_exps_of_senv, is_birs_exps_of_senv) = syntax_fns1_set "birs_exps_of_senv"; + + val (BExp_IntervalPred_tm, mk_BExp_IntervalPred, dest_BExp_IntervalPred, is_BExp_IntervalPred) = syntax_fns2 "BExp_IntervalPred"; end; local diff --git a/src/tools/symbexec/birs_intervalLib.sml b/src/tools/symbexec/birs_intervalLib.sml new file mode 100644 index 000000000..3f8a63f5a --- /dev/null +++ b/src/tools/symbexec/birs_intervalLib.sml @@ -0,0 +1,367 @@ +structure birs_intervalLib = +struct + +local + + open HolKernel Parse boolLib bossLib; + + open stringSyntax; + open bir_envSyntax bir_expSyntax; + + open birsSyntax; + open birs_utilsLib; + open birs_mergeLib; + + (* error handling *) + val libname = "birs_intervalLib" + val ERR = Feedback.mk_HOL_ERR libname + val wrap_exn = Feedback.wrap_exn libname + + val debug_mode = true; + +(* TODO: move to bir_vars_ofLib *) + fun get_vars_of_bexp tm = + let + open bir_vars_ofLib; + open pred_setSyntax; + open bir_typing_expSyntax; + val thm = bir_vars_of_exp_DIRECT_CONV (mk_bir_vars_of_exp tm); + in + (strip_set o snd o dest_eq o concl) thm + end + handle _ => raise ERR "get_vars_of_bexp" "did not work"; + + fun is_beq_left ref_symb tm = (is_comb tm) andalso ((identical ``BExp_BinPred BIExp_Equal (BExp_Den ^(ref_symb))`` o fst o dest_comb) tm); + fun is_binterval ref_symb tm = (is_comb tm) andalso ((identical ``BExp_IntervalPred (BExp_Den ^(ref_symb))`` o fst o dest_comb) tm); + fun beq_left_to_binterval ref_symb tm = + let val minmax_tm = (snd o dest_comb) tm; + in ``BExp_IntervalPred (BExp_Den ^(ref_symb)) (^minmax_tm, ^minmax_tm)`` end; + + fun fuse_intervals interval1 interval2 = + let + val _ = if not debug_mode then () else print "starting to fuse two intervals\n"; + val _ = if not debug_mode then () else print_term interval1; + val _ = if not debug_mode then () else print_term interval2; + val _ = raise ERR "fuse_intervals" "not implemented"; + in + interval1 + end; + +(* +val interval1 = ``BExp_IntervalPred (BExp_Den (BVar "syi_countw" (BType_Imm Bit64))) + (BExp_BinExp BIExp_Plus (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 21w)), + BExp_BinExp BIExp_Plus (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 21w)))``; + +val interval2 = ``BExp_IntervalPred (BExp_Den (BVar "syi_countw" (BType_Imm Bit64))) + (BExp_BinExp BIExp_Plus (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 21w)), + BExp_BinExp BIExp_Plus (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 21w)))``; +bplus (bden ``x:bir_var_t``, bconstimm ``y:bir_imm_t``); +*) +local +val intervalpattern64_tm = `` + BExp_IntervalPred (BExp_Den (BVar x_a (BType_Imm Bit64))) + (BExp_BinExp BIExp_Plus (BExp_Den (BVar x_b (BType_Imm Bit64))) + (BExp_Const (Imm64 x_c)), + BExp_BinExp BIExp_Plus (BExp_Den (BVar x_b (BType_Imm Bit64))) + (BExp_Const (Imm64 x_d)))``; + +fun get_interval_parameters i_tm = + let + val (vs, _) = hol88Lib.match intervalpattern64_tm i_tm; + val symb_str = fst (List.nth (vs, 0)); + val refsymb_str = fst (List.nth (vs, 1)); + val lc = fst (List.nth (vs, 2)); + val hc = fst (List.nth (vs, 3)); + in + (fromHOLstring symb_str, fromHOLstring refsymb_str, + (Arbnum.toInt o wordsSyntax.dest_word_literal) lc, + (Arbnum.toInt o wordsSyntax.dest_word_literal) hc) + end + handle _ => raise ERR "get_interval_parameters" ("no match? : " ^ (term_to_string i_tm)); +fun mk_interval_tm (symb_str, refsymb_str, lc, hc) = + subst [``x_a:string`` |-> fromMLstring symb_str, + ``x_b:string`` |-> fromMLstring refsymb_str, + ``x_c:word64`` |-> wordsSyntax.mk_wordii(lc, 64), + ``x_d:word64`` |-> wordsSyntax.mk_wordii(hc, 64) + ] intervalpattern64_tm; +in + fun widen_intervals (interval1, interval2) = + let + val _ = if not debug_mode then () else print "starting to find the widest limits of two intervals\n"; + (* quickfix for unfinished word expression in constants *) + val interval1 = (snd o dest_eq o concl o RAND_CONV EVAL) interval1; + val interval2 = (snd o dest_eq o concl o RAND_CONV EVAL) interval2; + val _ = if not debug_mode then () else print_term interval1; + val _ = if not debug_mode then () else print_term interval2; + val (symb_str1, refsymb_str1, lc1, hc1) = get_interval_parameters interval1; + val (symb_str2, refsymb_str2, lc2, hc2) = get_interval_parameters interval2; + val _ = if (symb_str1 = symb_str2) andalso (refsymb_str1 = refsymb_str2) then () else + raise ERR "widen_intervals" "intervals are not trivially compatible"; + val lc_min = if lc1 < lc2 then lc1 else lc2; + val hc_max = if hc1 > hc2 then hc1 else hc2; + val interval = mk_interval_tm (symb_str1, refsymb_str1, lc_min, hc_max); + in + interval + end; +end + +in (* local *) + + (* unifies the representation of the interval for env mapping vn (handles introduction (e.g., after symbolic execution without interval) and also fusion of transitive intervals (e.g., after instantiation)) *) + (* afterwards: vn is on top, symbolname mapped for interval is ("syi_"^vn), exactly one interval relating to it in the pathcondition *) + (* this has to be used after an execution (which in turn is either from an initial state, or from after a merge operation), and before a bounds operation below *) + fun birs_intervals_Pi_first_unify_RULE vn thm = + let + val _ = if (symb_sound_struct_is_normform o concl) thm then () else + raise ERR "birs_intervals_Pi_first_unify_RULE" "theorem is not a standard birs_symb_exec"; + val vn_symb = "syi_" ^ vn; + val init_symb = ("sy_"^vn); + + val _ = if not debug_mode then () else print "starting to unify interval for one Pi state\n"; + + (* bring up mapping vn to the top of env mappings *) + val thm0 = CONV_RULE (birs_Pi_first_CONV (birs_env_var_top_CONV vn)) thm; + val env_exp = (snd o get_birs_Pi_first_env_top_mapping o concl) thm0; + + (* is the mapping just a symbol, which is not the initial symbolic one? + then remember it (because there should already be an interval for it in the path condition), + otherwise freesymbol the mapping *) + val (thm1, env_symbol) = + if (is_BExp_Den env_exp) andalso (((fn x => x <> init_symb) o fst o dest_BVar_string o dest_BExp_Den) env_exp) then + (thm0, dest_BExp_Den env_exp) + else + let + val exp_tm = env_exp; + val symbname = get_freesymb_name (); + val symb_tm = mk_BVar (fromMLstring symbname, (bir_exp_typecheckLib.get_type_of_bexp exp_tm)); + val thm1 = birs_Pi_first_freesymb_RULE symbname exp_tm thm0; + in (thm1, symb_tm) end; + val _ = if not debug_mode then () else print "freesymboling done\n"; + (* now we have only one symbol env_symbol in the mapping and the rest should be in the path condition *) + + (* need to operate on the path condition *) + val pcond = (get_birs_Pi_first_pcond o concl) thm1; + val pcondl = dest_band pcond; + + (* search for related simple equality, or for an interval *) + val pcond_eqtms = List.filter (is_beq_left env_symbol) pcondl; + val pcond_intervaltms_0 = List.filter (is_binterval env_symbol) pcondl; + val pcondl_filtd = (List.filter (not o is_binterval env_symbol) o List.filter (not o is_beq_left env_symbol)) pcondl; + val intervaltm = + if length pcond_eqtms = 0 then ( + if length pcond_intervaltms_0 = 0 then + raise ERR "birs_intervals_Pi_first_unify_RULE" ("unexpected, seems like " ^ vn ^ "is a free symbol or not managed by birs_intervalLib") + else if length pcond_intervaltms_0 > 1 then + raise ERR "birs_intervals_Pi_first_unify_RULE" ("unexpected1") + else + hd pcond_intervaltms_0 + ) else if length pcond_eqtms > 1 then + raise ERR "birs_intervals_Pi_first_unify_RULE" "unexpected2" + else + (beq_left_to_binterval env_symbol (hd pcond_eqtms)); + val _ = if not debug_mode then () else print_term intervaltm; + + (* TODO: this interval should relate to the original symbol, or maybe another interval that it relates to *) + (* TODO: the following is a quick solution without much checks *) + fun get_ref_symb intervaltm_ = + let + val refsymbs = List.filter (fn x => not (identical x env_symbol)) (get_vars_of_bexp intervaltm_); + (* + val _ = PolyML.print_depth 10; + val _ = PolyML.print refsymbs; + val _ = print_term (hd refsymbs); + *) + val _ = if length refsymbs = 1 then () else + raise ERR "get_ref_symb" "unexpected"; + in + hd refsymbs + end; + val refsymb = get_ref_symb intervaltm; + val (intervalterm_fusion, pcondl_filtd_two) = + if (fst o dest_BVar_string) refsymb = init_symb then + (intervaltm, pcondl_filtd) + else + let + val pcond_intervaltms_1 = List.filter (is_binterval refsymb) pcondl_filtd; + val pcondl_filtd_two = List.filter (not o is_binterval refsymb) pcondl_filtd; + in + if length pcond_intervaltms_1 = 1 then + (fuse_intervals (intervaltm) (hd pcond_intervaltms_1), pcondl_filtd_two) + else + raise ERR "birs_intervals_Pi_first_unify_RULE" ("unexpected3") + end; + val _ = if not debug_mode then () else print_term intervalterm_fusion; + + val pcond_new = bslSyntax.bandl (intervalterm_fusion::pcondl_filtd_two); + val thm2 = birs_Pi_first_pcond_RULE pcond_new thm1; + val thmx = thm2; + + (* all that is left is to make sure that we use the standardname for the symbol in the envmapping, if not, just rename it *) + (* rename so that the symbol used is ("syi_"^vn) for readability *) + (* TODO: check, at this point no BVar symbol with the name vn_symb should occur in thm *) + (* TODO: we will need a rename rule for this later, this one just works now because it is not following the theorem checks *) + val thm9 = birs_instantiationLib.birs_sound_symb_inst_RULE [(env_symbol, mk_BExp_Den (mk_BVar_string (vn_symb, (snd o dest_BVar) env_symbol)))] thmx; + + val _ = if not debug_mode then () else print "done unifying interval for one Pi state\n"; + in + thm9 + end; + + fun birs_intervals_Pi_unify_RULE vn = birs_Pi_each_RULE (birs_intervals_Pi_first_unify_RULE vn); + + (* goes through all Pi states and unifies the interval bounds for env mapping vn (needed prior to merging of states) *) + (* assumes that the unify rule was running before *) + (* this has to be used after a unify operation above, and before the actual merging to be able to keep the interval in the path condition and the symbol reference in the environment mapping *) + fun birs_intervals_Pi_bounds_RULE vn thm = + let + val _ = if (symb_sound_struct_is_normform o concl) thm then () else + raise ERR "birs_intervals_Pi_bounds_RULE" "theorem is not a standard birs_symb_exec"; + val vn_symb = "syi_" ^ vn; + val init_symb = ("sy_"^vn); + + val _ = if not debug_mode then () else print "starting to widen the bounds of the intervals in all Pi states\n"; + + (* collect the intervals from each Pi pathcondition *) + val Pi_tms = (pred_setSyntax.strip_set o get_birs_Pi o concl) thm; + fun interval_from_state tm = + let + val (_,env,_,pcond) = dest_birs_state tm; + val env_exp = (snd o get_env_top_mapping) env; + (* check that env_exp is just a bexp_den and has the name vn_symb *) + val _ = if (is_BExp_Den env_exp) andalso (((fn x => x = vn_symb) o fst o dest_BVar_string o dest_BExp_Den) env_exp) then () else + raise ERR "birs_intervals_Pi_bounds_RULE" ("unexpected, the expression should be just the syi_ symbol: " ^ (term_to_string env_exp)); + val env_symbol = dest_BExp_Den env_exp; + val pcondl = dest_band pcond; + val pcond_intervaltms = List.filter (is_binterval env_symbol) pcondl; + val pcondl_filtd = List.filter (not o is_binterval env_symbol) pcondl; + val _ = if length pcond_intervaltms = 1 then () else + raise ERR "birs_intervals_Pi_bounds_RULE" ("unexpected, could not find interval for: " ^ (term_to_string env_symbol)); + val interval = hd pcond_intervaltms; + in + (interval, fn x => bslSyntax.bandl (x::pcondl_filtd)) + end; + val (intervaltms, pcond_new_funs) = unzip (List.map interval_from_state Pi_tms); + + (* compute the new min and max, generate the new interval predicate with it *) + val interval_largest = List.foldl widen_intervals (hd intervaltms) (tl intervaltms); + + (* for each Pi state: replace the old predicate with the new one and justify with Pi_first_pcond_RULE *) + val pconds = List.map (fn x => x interval_largest) pcond_new_funs; + val thm_new = List.foldl (birs_Pi_rotate_RULE o (fn (pcond,acc) => birs_Pi_first_pcond_RULE pcond acc)) thm pconds; + + val _ = if not debug_mode then () else print "done widening the bounds of the intervals in all Pi states\n"; + in + thm_new + end; + + + (* use this function after an execution (or after merging), and before the next merging *) + fun birs_intervals_Pi_RULE vn = (birs_intervals_Pi_bounds_RULE vn o birs_intervals_Pi_unify_RULE vn); + + +end (* local *) + +end (* struct *) + +(* ================================================================================================================ *) + +(* + local + open pred_setSyntax; + val rotate_first_INSERTs_thm = prove(`` + !x1 x2 xs. + (x1 INSERT x2 INSERT xs) = (x2 INSERT x1 INSERT xs) + ``, + cheat + ); + fun is_two_INSERTs tm = (is_insert tm) andalso ((is_insert o snd o dest_insert) tm); + in + fun rotate_two_INSERTs_conv tm = + let + val _ = if is_two_INSERTs tm then () else + raise ERR "rotate_two_INSERTs_conv" "need to be a term made up of two inserts"; + val (x1_tm, x2xs_tm) = dest_insert tm; + val (x2_tm, xs_tm) = dest_insert x2xs_tm; + val inst_thm = ISPECL [x1_tm, x2_tm, xs_tm] rotate_first_INSERTs_thm; + in + (* TODO: the result of this should actually just be inst_thm *) + REWRITE_CONV [Once inst_thm] tm + end; + + fun rotate_INSERTs_conv tm = + (if not (is_two_INSERTs tm) then REFL else + (rotate_two_INSERTs_conv THENC + RAND_CONV rotate_INSERTs_conv)) tm; + end + + +rotate_INSERTs_conv “{1;2;3;4;5}” + +val thm = (prove(“ +birs_symb_exec bir_balrob_prog + (<|bsst_pc := + <|bpc_label := BL_Address (Imm32 0x100013B4w); + bpc_index := 0|>; + bsst_environ := + birs_gen_env + []; + bsst_status := BST_Running; + bsst_pcond := BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1)) |>, + {<|bpc_label := BL_Address (Imm32 0x100013BCw); bpc_index := 2|>}, +{ +<|bsst_pc := + <|bpc_label := BL_Address (Imm32 0x0w); + bpc_index := 0|>; + bsst_environ := + birs_gen_env + [("R11",BExp_Den (BVar "sy_R11" (BType_Imm Bit32))); + ("PSR_Z",BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); + ("R7",BExp_Den (BVar "sy_R7" (BType_Imm Bit32)));]; + bsst_status := BST_Running; + bsst_pcond := BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1)) |> +; +<|bsst_pc := + <|bpc_label := BL_Address (Imm32 0x1w); + bpc_index := 0|>; + bsst_environ := + birs_gen_env + [("R9",BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); + ("PSR_Z",BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); + ("R7",BExp_Den (BVar "sy_R7" (BType_Imm Bit32)));]; + bsst_status := BST_Running; + bsst_pcond := BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1)) |> +; +<|bsst_pc := + <|bpc_label := BL_Address (Imm32 0x2w); + bpc_index := 0|>; + bsst_environ := + birs_gen_env + [("R9",BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); + ("PSR_Z",BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); + ("R7",BExp_Den (BVar "sy_R7" (BType_Imm Bit32)));]; + bsst_status := BST_Running; + bsst_pcond := BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1)) |> +; +<|bsst_pc := + <|bpc_label := BL_Address (Imm32 0x3w); + bpc_index := 0|>; + bsst_environ := + birs_gen_env + [("R9",BExp_Den (BVar "sy_R9" (BType_Imm Bit32))); + ("PSR_Z",BExp_Den (BVar "sy_R8" (BType_Imm Bit32))); + ("R7",BExp_Den (BVar "sy_R7" (BType_Imm Bit32)));]; + bsst_status := BST_Running; + bsst_pcond := BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1)) |> + +}) +”, cheat)); + + +birs_utilsLib.birs_Pi_rotate_RULE thm; + +birs_intervals_Pi_unify_RULE "PSR_Z" thm +*) diff --git a/src/tools/symbexec/birs_mergeLib.sml b/src/tools/symbexec/birs_mergeLib.sml index 182ee1680..12683a8e7 100644 --- a/src/tools/symbexec/birs_mergeLib.sml +++ b/src/tools/symbexec/birs_mergeLib.sml @@ -74,11 +74,11 @@ in (* local *) (* create updated state (pcond and env), and purge previous environment mapping *) val env_mod = mk_birs_update_env (pairSyntax.mk_pair (vn, exp_new), env_old); - val _ = print "created update env exp\n"; + val _ = if not debug_mode then () else print "created update env exp\n"; val purge_update_env_conv = REWRITE_CONV [birs_auxTheory.birs_update_env_thm] THENC RAND_CONV EVAL; - val _ = print "purged update env exp\n"; + val _ = if not debug_mode then () else print "purged update env exp\n"; val env_new = (snd o dest_eq o concl o purge_update_env_conv) env_mod; val pcond_new = bslSyntax.band (pcond_old, bslSyntax.beq (bslSyntax.bden symb_tm, exp_tm)); val Pi_sys_new_tm = mk_birs_state (pc, env_new, status, pcond_new); @@ -150,15 +150,15 @@ in (* local *) let val symbname = get_freesymb_name (); in - (birs_Pi_first_forget_RULE symbname o birs_Pi_rotate_RULE o birs_Pi_first_forget_RULE symbname) thm + (birs_Pi_first_forget_RULE symbname o birs_Pi_rotate_two_RULE o birs_Pi_first_forget_RULE symbname) thm end; fun birs_Pi_first_env_top_mapping_merge_fold ((exp1,exp2), thm) = let val symbname = get_freesymb_name (); in - (birs_Pi_rotate_RULE o birs_Pi_first_forget_RULE_gen symbname exp2 o - birs_Pi_rotate_RULE o birs_Pi_first_forget_RULE_gen symbname exp1) thm + (birs_Pi_rotate_two_RULE o birs_Pi_first_forget_RULE_gen symbname exp2 o + birs_Pi_rotate_two_RULE o birs_Pi_first_forget_RULE_gen symbname exp1) thm end; local @@ -286,7 +286,7 @@ in (* local *) (* move the mapping to the top *) val thm1 = CONV_RULE (birs_Pi_first_CONV (birs_env_var_top_CONV vn)) thm0; val exp1 = (snd o get_birs_Pi_first_env_top_mapping o concl) thm1; - val thm2 = birs_Pi_rotate_RULE thm1; + val thm2 = birs_Pi_rotate_two_RULE thm1; val thm3 = CONV_RULE (birs_Pi_first_CONV (birs_env_var_top_CONV vn)) thm2; val exp2 = (snd o get_birs_Pi_first_env_top_mapping o concl) thm3; val _ = if not debug_mode then () else print "got the expressions\n"; @@ -301,7 +301,7 @@ in (* local *) let val thm0 = thm_env; val pcond1 = (get_birs_Pi_first_pcond o concl) thm0; - val thm1 = birs_Pi_rotate_RULE thm0; + val thm1 = birs_Pi_rotate_two_RULE thm0; val pcond2 = (get_birs_Pi_first_pcond o concl) thm1; (* get conjuncts as list *) @@ -313,7 +313,7 @@ in (* local *) val pcond_common = bslSyntax.bandl pcond_commonl; (* fix the path condition in both states accordingly *) - val thm2 = (birs_Pi_first_pcond_RULE pcond_common o birs_Pi_rotate_RULE o birs_Pi_first_pcond_RULE pcond_common) thm1; + val thm2 = (birs_Pi_first_pcond_RULE pcond_common o birs_Pi_rotate_two_RULE o birs_Pi_first_pcond_RULE pcond_common) thm1; in thm2 end; val _ = if not debug_mode then () else print "unified pcond\n"; diff --git a/src/tools/symbexec/birs_utilsLib.sml b/src/tools/symbexec/birs_utilsLib.sml index 0bfb92abd..d50b527d7 100644 --- a/src/tools/symbexec/birs_utilsLib.sml +++ b/src/tools/symbexec/birs_utilsLib.sml @@ -323,12 +323,33 @@ in (* local *) fun second_CONV conv = RAND_CONV (first_CONV conv); - val rotate_first_INSERTs_thm = prove(`` - !x1 x2 xs. - (x1 INSERT x2 INSERT xs) = (x2 INSERT x1 INSERT xs) - ``, - cheat - ); + local + open pred_setSyntax; + val rotate_first_INSERTs_thm = prove(`` + !x1 x2 xs. + (x1 INSERT x2 INSERT xs) = (x2 INSERT x1 INSERT xs) + ``, + cheat + ); + fun is_two_INSERTs tm = (is_insert tm) andalso ((is_insert o snd o dest_insert) tm); + in + fun rotate_two_INSERTs_conv tm = + let + val _ = if is_two_INSERTs tm then () else + raise ERR "rotate_two_INSERTs_conv" "need to be a term made up of two inserts"; + val (x1_tm, x2xs_tm) = dest_insert tm; + val (x2_tm, xs_tm) = dest_insert x2xs_tm; + val inst_thm = ISPECL [x1_tm, x2_tm, xs_tm] rotate_first_INSERTs_thm; + in + (* TODO: the result of this should actually just be inst_thm *) + REWRITE_CONV [Once inst_thm] tm + end; + + fun rotate_INSERTs_conv tm = + (if not (is_two_INSERTs tm) then REFL else + (rotate_two_INSERTs_conv THENC + RAND_CONV rotate_INSERTs_conv)) tm; + end in (* apply state transformer to sys *) fun birs_sys_CONV conv tm = @@ -355,9 +376,25 @@ in (* local *) birs_Pi_CONV (second_CONV conv); (* swap the first two states in Pi *) - fun birs_Pi_rotate_RULE thm = + fun birs_Pi_rotate_two_RULE thm = let (*val _ = print "rotating first two in Pi\n";*) + val _ = if (symb_sound_struct_is_normform o concl) thm then () else + raise ERR "birs_Pi_rotate_two_RULE" "theorem is not a standard birs_symb_exec"; + val (_,_,Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) thm; + val num_Pi_el = (length o pred_setSyntax.strip_set) Pi_tm; + val _ = if num_Pi_el > 1 then () else + raise ERR "birs_Pi_rotate_two_RULE" "Pi has to have at least two states"; + + val res_thm = CONV_RULE (struct_CONV (Pi_CONV (rotate_two_INSERTs_conv))) thm; + (*val _ = print "finished rotating\n";*) + in + res_thm + end; + + fun birs_Pi_rotate_RULE thm = + let + (*val _ = print "rotating elements of Pi\n";*) val _ = if (symb_sound_struct_is_normform o concl) thm then () else raise ERR "birs_Pi_rotate_RULE" "theorem is not a standard birs_symb_exec"; val (_,_,Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) thm; @@ -365,17 +402,29 @@ in (* local *) val _ = if num_Pi_el > 1 then () else raise ERR "birs_Pi_rotate_RULE" "Pi has to have at least two states"; - val (_,_,Pi_tm) = (dest_sysLPi o snd o dest_birs_symb_exec o concl) thm; - val (x1_tm, x2xs_tm) = pred_setSyntax.dest_insert Pi_tm; - val (x2_tm, xs_tm) = pred_setSyntax.dest_insert x2xs_tm; - val inst_thm = ISPECL [x1_tm, x2_tm, xs_tm] rotate_first_INSERTs_thm; - val res_thm = CONV_RULE (struct_CONV (Pi_CONV (REWRITE_CONV [Once inst_thm]))) thm; + val res_thm = CONV_RULE (struct_CONV (Pi_CONV (rotate_INSERTs_conv))) thm; (*val _ = print "finished rotating\n";*) in res_thm end; end + (* goes through all Pi states and applies rule *) + fun birs_Pi_each_RULE rule thm = + let + val len = (get_birs_Pi_length o concl) thm; + (* iterate through all Pi states (with Pi rotate) and apply rule *) + val thm_new = + if len = 0 then + thm + else if len = 1 then + rule thm + else + List.foldl (birs_Pi_rotate_RULE o rule o snd) thm (List.tabulate(len, I)); + in + thm_new + end; + (* ---------------------------------------------------------------------------------------- *) end (* local *) From 2b2f0dcda31cfd51ff1d7bb55cb5db650bea32a1 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sun, 13 Oct 2024 23:12:06 +0200 Subject: [PATCH 71/95] Fixes --- src/tools/symbexec/birs_intervalLib.sml | 7 ++++++- src/tools/symbexec/birs_utilsLib.sml | 3 +++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/src/tools/symbexec/birs_intervalLib.sml b/src/tools/symbexec/birs_intervalLib.sml index 3f8a63f5a..78a14dad2 100644 --- a/src/tools/symbexec/birs_intervalLib.sml +++ b/src/tools/symbexec/birs_intervalLib.sml @@ -220,6 +220,10 @@ in (* local *) let val _ = if (symb_sound_struct_is_normform o concl) thm then () else raise ERR "birs_intervals_Pi_bounds_RULE" "theorem is not a standard birs_symb_exec"; + val Pi_len = (get_birs_Pi_length o concl) thm; + in + if Pi_len < 2 then thm else + let val vn_symb = "syi_" ^ vn; val init_symb = ("sy_"^vn); @@ -254,8 +258,9 @@ in (* local *) val thm_new = List.foldl (birs_Pi_rotate_RULE o (fn (pcond,acc) => birs_Pi_first_pcond_RULE pcond acc)) thm pconds; val _ = if not debug_mode then () else print "done widening the bounds of the intervals in all Pi states\n"; - in + in thm_new + end end; diff --git a/src/tools/symbexec/birs_utilsLib.sml b/src/tools/symbexec/birs_utilsLib.sml index d50b527d7..519de1282 100644 --- a/src/tools/symbexec/birs_utilsLib.sml +++ b/src/tools/symbexec/birs_utilsLib.sml @@ -39,6 +39,9 @@ in (* local *) fun list_commons eq_fun l1 l2 = List.foldl (fn (x,acc) => if list_in eq_fun x l2 then x::acc else acc) [] l1; + fun list_minus eq_fun l1 l2 = + List.filter (fn x => not (list_in eq_fun x l2)) l1; + val gen_eq = (fn (x,y) => x = y); val term_id_eq = (fn (x,y) => identical x y); From f5e3d581d0da662e8a245c5716e8f240622711bf Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 14 Oct 2024 00:29:53 +0200 Subject: [PATCH 72/95] Fixes --- src/tools/symbexec/birs_instantiationLib.sml | 14 ++-- src/tools/symbexec/birs_intervalLib.sml | 75 +++++++++++++------- src/tools/symbexec/birs_mergeLib.sml | 24 ++++++- src/tools/symbexec/birs_utilsLib.sml | 7 ++ 4 files changed, 87 insertions(+), 33 deletions(-) diff --git a/src/tools/symbexec/birs_instantiationLib.sml b/src/tools/symbexec/birs_instantiationLib.sml index 95078e8c9..f0e1a7280 100644 --- a/src/tools/symbexec/birs_instantiationLib.sml +++ b/src/tools/symbexec/birs_instantiationLib.sml @@ -112,7 +112,6 @@ in (* local *) (* instantiation process (including sequential composition) - TODO: set up example like this --- execute with symbol in the path condition from the beginning (to be able to preserve path condition for after instantiation) *) fun birs_sound_inst_SEQ_RULE birs_rule_SEQ_thm bv_syp_gen A_thm B_thm = let @@ -144,9 +143,16 @@ in (* local *) (* TODO: can only handle one Pi state, for now *) val _ = if len_of_thm_Pi B_thm_inst_sys = 1 then () else raise ERR "birs_sound_inst_SEQ_RULE" "summaries can only contain 1 state currently"; - (* cleanup Pi path conditions (probably only need to consider one for starters) to only preserve non-summary conjunct (as the step before) *) - (* TODO: later this step will also have to take care of intervals (countw and stack pointer) - into B_Pi_pcond_new *) - val B_Pi_pcond_new = A_pcond; + (* cleanup Pi path conditions (probably only need to consider one for starters) to only preserve non-summary conjunct (as the step before), but preserve also the intervals *) + val B_Pi_pcond = (get_birs_Pi_first_pcond o concl) B_thm_inst_sys; + val B_Pi_pcond_intervals = List.filter (is_BExp_IntervalPred) (dest_band B_Pi_pcond); + val B_pcondl_new = B_Pi_pcond_intervals@(list_minus term_id_eq (dest_band A_pcond) B_Pi_pcond_intervals); + val B_Pi_pcond_new = bslSyntax.bandl (B_pcondl_new); + (* + val _ = print_term (bslSyntax.bandl B_Pi_pcond_intervals_); + val _ = print_term B_Pi_pcond_new; + val _ = print_thm B_thm_inst_sys; + *) val B_thm_inst_sys_Pi = birs_Pi_first_pcond_RULE B_Pi_pcond_new B_thm_inst_sys; (* sequential composition of the two theorems *) diff --git a/src/tools/symbexec/birs_intervalLib.sml b/src/tools/symbexec/birs_intervalLib.sml index 78a14dad2..599f6172b 100644 --- a/src/tools/symbexec/birs_intervalLib.sml +++ b/src/tools/symbexec/birs_intervalLib.sml @@ -37,30 +37,6 @@ local let val minmax_tm = (snd o dest_comb) tm; in ``BExp_IntervalPred (BExp_Den ^(ref_symb)) (^minmax_tm, ^minmax_tm)`` end; - fun fuse_intervals interval1 interval2 = - let - val _ = if not debug_mode then () else print "starting to fuse two intervals\n"; - val _ = if not debug_mode then () else print_term interval1; - val _ = if not debug_mode then () else print_term interval2; - val _ = raise ERR "fuse_intervals" "not implemented"; - in - interval1 - end; - -(* -val interval1 = ``BExp_IntervalPred (BExp_Den (BVar "syi_countw" (BType_Imm Bit64))) - (BExp_BinExp BIExp_Plus (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) - (BExp_Const (Imm64 21w)), - BExp_BinExp BIExp_Plus (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) - (BExp_Const (Imm64 21w)))``; - -val interval2 = ``BExp_IntervalPred (BExp_Den (BVar "syi_countw" (BType_Imm Bit64))) - (BExp_BinExp BIExp_Plus (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) - (BExp_Const (Imm64 21w)), - BExp_BinExp BIExp_Plus (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) - (BExp_Const (Imm64 21w)))``; -bplus (bden ``x:bir_var_t``, bconstimm ``y:bir_imm_t``); -*) local val intervalpattern64_tm = `` BExp_IntervalPred (BExp_Den (BVar x_a (BType_Imm Bit64))) @@ -89,6 +65,52 @@ fun mk_interval_tm (symb_str, refsymb_str, lc, hc) = ``x_d:word64`` |-> wordsSyntax.mk_wordii(hc, 64) ] intervalpattern64_tm; in +(* +val interval1 = ``BExp_IntervalPred (BExp_Den (BVar "syr_7" (BType_Imm Bit64))) + (BExp_BinExp BIExp_Plus (BExp_Den (BVar "syi_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 21w)), + BExp_BinExp BIExp_Plus (BExp_Den (BVar "syi_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 21w)))``; + +val interval2 = ``BExp_IntervalPred (BExp_Den (BVar "syi_countw" (BType_Imm Bit64))) + (BExp_BinExp BIExp_Plus (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 (5w))), + BExp_BinExp BIExp_Plus (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 (5w))))``; +*) + (* interval1 uses interval2 *) + fun fuse_intervals interval1 interval2 = + let + val _ = if not debug_mode then () else print "starting to fuse two intervals\n"; + (* quickfix for unfinished word expression in constants *) + val interval1 = (snd o dest_eq o concl o RAND_CONV EVAL) interval1; + val interval2 = (snd o dest_eq o concl o RAND_CONV EVAL) interval2; + val _ = if not debug_mode then () else print_term interval1; + val _ = if not debug_mode then () else print_term interval2; + val (symb_str1, refsymb_str1, lc1, hc1) = get_interval_parameters interval1; + val (symb_str2, refsymb_str2, lc2, hc2) = get_interval_parameters interval2; + val _ = if (refsymb_str1 = symb_str2) then () else + raise ERR "fuse_intervals" "intervals are not trivially compatible"; + val lc_min = lc1 + lc2; + val hc_max = hc1 + hc2; + val interval = mk_interval_tm (symb_str1, refsymb_str2, lc_min, hc_max); + in + interval + end; + +(* +val interval1 = ``BExp_IntervalPred (BExp_Den (BVar "syi_countw" (BType_Imm Bit64))) + (BExp_BinExp BIExp_Plus (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 21w)), + BExp_BinExp BIExp_Plus (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 21w)))``; + +val interval2 = ``BExp_IntervalPred (BExp_Den (BVar "syi_countw" (BType_Imm Bit64))) + (BExp_BinExp BIExp_Plus (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 21w)), + BExp_BinExp BIExp_Plus (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 21w)))``; +*) fun widen_intervals (interval1, interval2) = let val _ = if not debug_mode then () else print "starting to find the widest limits of two intervals\n"; @@ -176,7 +198,7 @@ in (* local *) val _ = print_term (hd refsymbs); *) val _ = if length refsymbs = 1 then () else - raise ERR "get_ref_symb" "unexpected"; + raise ERR "birs_intervals_Pi_first_unify_RULE::get_ref_symb" "unexpected"; in hd refsymbs end; @@ -192,7 +214,8 @@ in (* local *) if length pcond_intervaltms_1 = 1 then (fuse_intervals (intervaltm) (hd pcond_intervaltms_1), pcondl_filtd_two) else - raise ERR "birs_intervals_Pi_first_unify_RULE" ("unexpected3") + (print "\n\n";print_term pcond;print "\n\n";print_term (bslSyntax.bandl pcondl_filtd);print "\n\n";List.map print_term pcond_intervaltms_1;print "\n\n"; + raise ERR "birs_intervals_Pi_first_unify_RULE" ("unexpected3")) end; val _ = if not debug_mode then () else print_term intervalterm_fusion; diff --git a/src/tools/symbexec/birs_mergeLib.sml b/src/tools/symbexec/birs_mergeLib.sml index 12683a8e7..400c9b46a 100644 --- a/src/tools/symbexec/birs_mergeLib.sml +++ b/src/tools/symbexec/birs_mergeLib.sml @@ -333,10 +333,10 @@ in (* local *) end; (* merging of all states in Pi *) - fun birs_Pi_merge_RULE thm = + fun birs_Pi_merge_RULE_ thm = let val _ = if (symb_sound_struct_is_normform o concl) thm then () else - raise ERR "birs_Pi_merge_RULE" "theorem is not a standard birs_symb_exec"; + raise ERR "birs_Pi_merge_RULE_" "theorem is not a standard birs_symb_exec"; val (_,_,Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) thm; val num_Pi_el = (length o pred_setSyntax.strip_set) Pi_tm; in @@ -344,7 +344,25 @@ in (* local *) if num_Pi_el < 2 then thm else - birs_Pi_merge_RULE (birs_Pi_merge_2_RULE thm) + birs_Pi_merge_RULE_ (birs_Pi_merge_2_RULE thm) + end; + + fun birs_Pi_merge_RULE thm = + let + val merged_thm = birs_Pi_merge_RULE_ thm; + + (* check that the path condition has only changed in ways we want *) + val pcond_sysl = (dest_band o get_birs_sys_pcond o concl) merged_thm; + val pcond_Pifl = (dest_band o get_birs_Pi_first_pcond o concl) merged_thm; + val pcond_sys_extral = list_minus term_id_eq pcond_sysl pcond_Pifl; + val pcond_Pif_extral = list_minus term_id_eq pcond_Pifl pcond_sysl; + fun check_extra extra = + if (length extra = 0) orelse ((length extra = 1) andalso (birsSyntax.is_BExp_IntervalPred (hd extra))) then () else + raise ERR "birs_Pi_merge_RULE" ("should be none or exactly one conjunct that is a BExp_IntervalPred, something is wrong:" ^ (term_to_string (bslSyntax.bandl extra))); + val _ = check_extra pcond_sys_extral; + val _ = check_extra pcond_Pif_extral; + in + merged_thm end; (* diff --git a/src/tools/symbexec/birs_utilsLib.sml b/src/tools/symbexec/birs_utilsLib.sml index 519de1282..f56ad6b98 100644 --- a/src/tools/symbexec/birs_utilsLib.sml +++ b/src/tools/symbexec/birs_utilsLib.sml @@ -18,6 +18,13 @@ in (* local *) | list_distinct eq_fun (x::xs) = if all (fn y => (not o eq_fun) (x, y)) xs then list_distinct eq_fun xs else false; + fun list_mk_distinct_ _ [] acc = List.rev acc + | list_mk_distinct_ eq_fun (x::xs) acc = + list_mk_distinct_ eq_fun (List.filter (fn y => not (eq_fun (x, y))) xs) (x::acc); + + fun list_mk_distinct eq_fun l = + list_mk_distinct_ eq_fun l []; + (* the following two functions are from test-z3-wrapper.sml *) fun list_inclusion eq_fun l1 l2 = foldl (fn (x, acc) => acc andalso (exists (fn y => eq_fun (x, y)) l2)) true l1; From 8ae97904ff5c9cd5fc16dcdd4f23821a1abf6a60 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 14 Oct 2024 01:37:36 +0200 Subject: [PATCH 73/95] Fix handling of BExp_IntervalPred Improvements --- src/tools/symbexec/birs_intervalLib.sml | 4 ++-- src/tools/symbexec/birs_mergeLib.sml | 3 ++- src/tools/symbexec/birs_stepLib.sml | 7 +++++++ 3 files changed, 11 insertions(+), 3 deletions(-) diff --git a/src/tools/symbexec/birs_intervalLib.sml b/src/tools/symbexec/birs_intervalLib.sml index 599f6172b..809ef27b2 100644 --- a/src/tools/symbexec/birs_intervalLib.sml +++ b/src/tools/symbexec/birs_intervalLib.sml @@ -17,7 +17,7 @@ local val ERR = Feedback.mk_HOL_ERR libname val wrap_exn = Feedback.wrap_exn libname - val debug_mode = true; + val debug_mode = false; (* TODO: move to bir_vars_ofLib *) fun get_vars_of_bexp tm = @@ -135,7 +135,7 @@ in (* local *) (* unifies the representation of the interval for env mapping vn (handles introduction (e.g., after symbolic execution without interval) and also fusion of transitive intervals (e.g., after instantiation)) *) (* afterwards: vn is on top, symbolname mapped for interval is ("syi_"^vn), exactly one interval relating to it in the pathcondition *) - (* this has to be used after an execution (which in turn is either from an initial state, or from after a merge operation), and before a bounds operation below *) + (* this has to be used after an instantiation and after an execution (which in turn is either from an initial state, or from after a merge operation), and before a bounds operation below *) fun birs_intervals_Pi_first_unify_RULE vn thm = let val _ = if (symb_sound_struct_is_normform o concl) thm then () else diff --git a/src/tools/symbexec/birs_mergeLib.sml b/src/tools/symbexec/birs_mergeLib.sml index 400c9b46a..4fa78c67e 100644 --- a/src/tools/symbexec/birs_mergeLib.sml +++ b/src/tools/symbexec/birs_mergeLib.sml @@ -324,7 +324,8 @@ in (* local *) (*val _ = print_thm rewrite_thm;*) val rewrite_thm_fix = CONV_RULE (CHANGED_CONV (QUANT_CONV (LAND_CONV (*aux_setLib.birs_state_EQ_CONV*)EVAL))) rewrite_thm; val thm_merged = CONV_RULE (CHANGED_CONV (birs_Pi_CONV (REWRITE_CONV [rewrite_thm_fix]))) thm_env_pcond;*) - val thm_merged = CONV_RULE (CHANGED_CONV (birs_Pi_CONV (REWRITE_CONV [ISPEC ((get_birs_Pi_first o concl) thm_env_pcond) pred_setTheory.INSERT_INSERT]))) thm_env_pcond; + val thm_merged = CONV_RULE (CHANGED_CONV (birs_Pi_CONV (REWRITE_CONV [ISPEC ((get_birs_Pi_first o concl) thm_env_pcond) pred_setTheory.INSERT_INSERT]))) thm_env_pcond + handle _ => (print_thm thm_env_pcond; raise ERR "birs_Pi_merge_2_RULE" "merging did not work"); val _ = if not debug_mode then () else print "eliminated one from Pi\n"; val _ = holba_miscLib.timer_stop (fn delta_s => print (" merging two in Pi took " ^ delta_s ^ "\n")) timer; diff --git a/src/tools/symbexec/birs_stepLib.sml b/src/tools/symbexec/birs_stepLib.sml index 3c5b8f358..3a3761989 100644 --- a/src/tools/symbexec/birs_stepLib.sml +++ b/src/tools/symbexec/birs_stepLib.sml @@ -512,6 +512,13 @@ in in 1 + bir_exp_size mem_e + bir_exp_size a_e + bir_exp_size v_e end + else if is_BExp_IntervalPred t then + let + val (ref_e, lim_tm) = dest_BExp_IntervalPred t; + val (l_e, h_e) = pairSyntax.dest_pair lim_tm; + in + 1 + bir_exp_size ref_e + bir_exp_size l_e + bir_exp_size h_e + end (* else if is_... t then let From 126770e1acc08b0647ef0c0246ad8bf897c78b8a Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 14 Oct 2024 02:24:29 +0200 Subject: [PATCH 74/95] Fix --- src/tools/symbexec/birs_intervalLib.sml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/tools/symbexec/birs_intervalLib.sml b/src/tools/symbexec/birs_intervalLib.sml index 809ef27b2..feda6ad6c 100644 --- a/src/tools/symbexec/birs_intervalLib.sml +++ b/src/tools/symbexec/birs_intervalLib.sml @@ -286,9 +286,10 @@ in (* local *) end end; - +(* (* use this function after an execution (or after merging), and before the next merging *) fun birs_intervals_Pi_RULE vn = (birs_intervals_Pi_bounds_RULE vn o birs_intervals_Pi_unify_RULE vn); +*) end (* local *) From 0222b445505a7a7b8e3c6bb1157913811759e8b9 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 14 Oct 2024 23:09:40 +0200 Subject: [PATCH 75/95] Small fixes and cleanup --- .../tools/symbexec/birs_rulesScript.sml | 74 ++++++++++++++++--- src/tools/symbexec/birs_composeLib.sml | 33 +++------ src/tools/symbexec/birs_execLib.sml | 52 +++++++++++-- src/tools/symbexec/birs_intervalLib.sml | 3 +- src/tools/symbexec/birs_utilsLib.sml | 26 +++++-- 5 files changed, 140 insertions(+), 48 deletions(-) diff --git a/src/theory/tools/symbexec/birs_rulesScript.sml b/src/theory/tools/symbexec/birs_rulesScript.sml index 74af91f24..b0b198f41 100644 --- a/src/theory/tools/symbexec/birs_rulesScript.sml +++ b/src/theory/tools/symbexec/birs_rulesScript.sml @@ -315,6 +315,29 @@ QED (* ******************************************************* *) (* SUBST rule *) (* ******************************************************* *) +Theorem symb_rule_SUBST_thm[local]: + !sr. +!sys L sys2 var symbexp symbexp' Pi. + (symb_symbols_f_sound sr) ==> + (symb_ARB_val_sound sr) ==> + + (symb_hl_step_in_L_sound sr (sys, L, sys2 INSERT Pi)) ==> + ((symb_symbst_store sys2) var = SOME symbexp) ==> + + (symb_simplification sr (symb_symbst_pcond sys2) symbexp symbexp') ==> + + (symb_hl_step_in_L_sound sr (sys, L, (symb_symbst_store_update var symbexp' sys2) INSERT (Pi DELETE sys2))) +Proof +REPEAT STRIP_TAC >> + +`!B.((sys2 INSERT Pi) DIFF {sys2}) UNION {B} = B INSERT (Pi DELETE sys2)` by ( + fs [] >> + METIS_TAC [INSERT_SING_UNION, UNION_COMM, DELETE_DEF] + ) >> + + METIS_TAC [symb_rulesTheory.symb_rule_SUBST_thm] +QED + Theorem symb_rule_SUBST_SING_thm[local]: !sr. !sys L sys2 var symbexp symbexp'. @@ -328,17 +351,23 @@ Theorem symb_rule_SUBST_SING_thm[local]: (symb_hl_step_in_L_sound sr (sys, L, {symb_symbst_store_update var symbexp' sys2})) Proof -REPEAT STRIP_TAC >> + REPEAT STRIP_TAC >> - `({sys2} DIFF {sys2}) UNION {symb_symbst_store_update var symbexp' sys2} = {symb_symbst_store_update var symbexp' sys2}` by ( - METIS_TAC [pred_setTheory.DIFF_EQ_EMPTY, pred_setTheory.UNION_EMPTY] - ) >> + METIS_TAC [symb_rule_SUBST_thm, EMPTY_DELETE] +QED - METIS_TAC [symb_rulesTheory.symb_rule_SUBST_thm] +(* TODO: move to bir_symbScript.sml *) +Theorem birs_symb_to_symbst_IMAGE_DELETE_thm: +!x s. + IMAGE birs_symb_to_symbst s DELETE birs_symb_to_symbst x = + IMAGE birs_symb_to_symbst (s DELETE x) +Proof + simp_tac std_ss [EXTENSION, IN_DELETE, IN_IMAGE] >> + metis_tac [birs_symb_to_symbst_EXISTS_thm, birs_symb_from_symbst_EXISTS_thm, birs_symb_to_from_symbst_thm] QED -Theorem birs_rule_SUBST_spec_thm: - !prog bs L bs2 bs2' lbl envl status pcond vn symbexp symbexp'. +Theorem birs_rule_SUBST_thm: + !prog bs L bs2 bs2' lbl envl status pcond vn symbexp symbexp' Pi. (bs2 = <|bsst_pc := lbl; bsst_environ := birs_gen_env ((vn, symbexp)::envl); @@ -349,19 +378,21 @@ Theorem birs_rule_SUBST_spec_thm: bsst_environ := birs_gen_env ((vn, symbexp')::envl); bsst_status := status; bsst_pcond := pcond|>) ==> - birs_symb_exec prog (bs, L, {bs2}) ==> + birs_symb_exec prog (bs, L, bs2 INSERT Pi) ==> birs_simplification pcond symbexp symbexp' ==> - birs_symb_exec prog (bs, L, {bs2'}) + birs_symb_exec prog (bs, L, bs2' INSERT (Pi DELETE bs2)) Proof - REWRITE_TAC [birs_symb_exec_def] >> + REWRITE_TAC [birs_symb_exec_def, IMAGE_INSERT] >> REPEAT STRIP_TAC >> ASSUME_TAC ( - (Q.SPECL [`birs_symb_to_symbst bs`, `L`, `birs_symb_to_symbst bs2`, `vn`, `symbexp`, `symbexp'`] o + (Q.SPECL [`birs_symb_to_symbst bs`, `L`, `birs_symb_to_symbst bs2`, `vn`, `symbexp`, `symbexp'`, `IMAGE birs_symb_to_symbst Pi`] o SIMP_RULE std_ss [bir_symb_soundTheory.birs_symb_ARB_val_sound_thm] o - MATCH_MP symb_rule_SUBST_SING_thm o + MATCH_MP symb_rule_SUBST_thm o Q.SPEC `prog`) bir_symb_soundTheory.birs_symb_symbols_f_sound_thm) >> + FULL_SIMP_TAC std_ss [birs_symb_to_symbst_IMAGE_DELETE_thm] >> + REV_FULL_SIMP_TAC (std_ss++birs_state_ss) [IMAGE_SING, birs_symb_to_symbst_def, symb_symbst_store_def, symb_symbst_pcond_def, bir_symb_simpTheory.birs_simplification_thm, @@ -369,6 +400,25 @@ Proof combinTheory.UPDATE_APPLY] QED +Theorem birs_rule_SUBST_spec_thm: + !prog bs L bs2 bs2' lbl envl status pcond vn symbexp symbexp'. + (bs2 = + <|bsst_pc := lbl; + bsst_environ := birs_gen_env ((vn, symbexp)::envl); + bsst_status := status; + bsst_pcond := pcond|>) ==> + (bs2' = + <|bsst_pc := lbl; + bsst_environ := birs_gen_env ((vn, symbexp')::envl); + bsst_status := status; + bsst_pcond := pcond|>) ==> + birs_symb_exec prog (bs, L, {bs2}) ==> + birs_simplification pcond symbexp symbexp' ==> + birs_symb_exec prog (bs, L, {bs2'}) +Proof + metis_tac [birs_rule_SUBST_thm, EMPTY_DELETE] +QED + diff --git a/src/tools/symbexec/birs_composeLib.sml b/src/tools/symbexec/birs_composeLib.sml index eb86ee9cd..4f5e6ddf1 100644 --- a/src/tools/symbexec/birs_composeLib.sml +++ b/src/tools/symbexec/birs_composeLib.sml @@ -9,6 +9,10 @@ local open birsSyntax; open birs_auxTheory; + + open aux_setLib; + open birs_utilsLib; + val birs_state_ss = rewrites (type_rws ``:birs_state_t``); (* error handling *) @@ -42,7 +46,7 @@ in (fn (al,g) => (print_term g; ([(al,g)], fn ([t]) => t))) >> (fn x => (print "starting to compute concrete set of free symbols\n"; ALL_TAC x)) >> *) - CONV_TAC (LAND_CONV (aux_setLib.varset_INTER_CONV)) >> + CONV_TAC (LAND_CONV (varset_INTER_CONV)) >> REWRITE_TAC [pred_setTheory.EMPTY_SUBSET] ); @@ -50,22 +54,6 @@ in freesymbols_thm end; - fun tidyup_birs_symb_exec_CONV stateset_conv labelset_conv tm = - let - val _ = if is_birs_symb_exec tm then () else - raise ERR "tidyup_birs_symb_exec_CONV" "cannot handle term"; - - val struct_CONV = - RAND_CONV; - fun Pi_CONV conv = - RAND_CONV (RAND_CONV conv); - fun L_CONV conv = - RAND_CONV (LAND_CONV conv); - in - (struct_CONV (Pi_CONV stateset_conv) THENC - struct_CONV (L_CONV labelset_conv)) tm - end; - (* val step_A_thm = single_step_A_thm; val step_B_thm = single_step_B_thm; @@ -86,14 +74,17 @@ in val _ = print "composed\n"; (* tidy up set operations to not accumulate (in both, post state set and label set) *) - val bprog_L_fixed_thm = CONV_RULE (tidyup_birs_symb_exec_CONV aux_setLib.birs_state_DIFF_UNION_CONV aux_setLib.labelset_UNION_CONV) bprog_composed_thm + val bprog_fixed_thm = CONV_RULE + (birs_Pi_CONV birs_state_DIFF_UNION_CONV THENC + birs_L_CONV labelset_UNION_CONV) + bprog_composed_thm handle e => (print "\n\n"; print_thm bprog_composed_thm; print "tidy up Pi and labelset failed\n"; raise e); - val _ = if symb_sound_struct_is_normform (concl bprog_L_fixed_thm) then () else - (print_term (concl bprog_L_fixed_thm); + val _ = if symb_sound_struct_is_normform (concl bprog_fixed_thm) then () else + (print_term (concl bprog_fixed_thm); raise ERR "birs_rule_SEQ_fun" "something is not right, the produced theorem is not evaluated enough"); in - bprog_L_fixed_thm + bprog_fixed_thm end; diff --git a/src/tools/symbexec/birs_execLib.sml b/src/tools/symbexec/birs_execLib.sml index 6a5a3fe25..979f5f679 100644 --- a/src/tools/symbexec/birs_execLib.sml +++ b/src/tools/symbexec/birs_execLib.sml @@ -255,20 +255,21 @@ fun birs_rule_SUBST_prog_fun bprog_tm = ``, cheat (* TODO: connect this with prep_thm from above *) );*) - val inst_thm = SIMP_RULE std_ss [] ((SPEC bprog_tm o INST_TYPE [Type.alpha |-> prog_type]) birs_rule_SUBST_spec_thm); + val inst_thm1 = SIMP_RULE std_ss [] ((SPEC bprog_tm o INST_TYPE [Type.alpha |-> prog_type]) birs_rule_SUBST_thm); + val inst_thm2 = SIMP_RULE std_ss [] ((SPEC bprog_tm o INST_TYPE [Type.alpha |-> prog_type]) birs_rule_SUBST_spec_thm); (*val _ = (print_term o concl) inst_thm;*) in - inst_thm + (inst_thm1,inst_thm2) end; (* -val single_step_prog_thm = result; +val thm = result; *) -fun birs_rule_SUBST_trysimp_fun birs_rule_SUBST_thm birs_simp_fun single_step_prog_thm = +fun birs_rule_SUBST_trysimp_SING_fun (_,birs_rule_SUBST_thm) birs_simp_fun thm = let val assignment_thm_o = - SOME (MATCH_MP birs_rule_SUBST_thm single_step_prog_thm) + SOME (MATCH_MP birs_rule_SUBST_thm thm) handle _ => NONE; val simp_t_o = Option.mapPartial (fn assignment_thm => @@ -286,9 +287,46 @@ fun birs_rule_SUBST_trysimp_fun birs_rule_SUBST_thm birs_simp_fun single_step_pr in case simp_t_o of SOME (simp_t, assignment_thm) => MATCH_MP assignment_thm simp_t - | NONE => single_step_prog_thm + | NONE => thm end; -val birs_rule_SUBST_trysimp_fun = fn x => Profile.profile "birs_rule_SUBST_trysimp_fun" (birs_rule_SUBST_trysimp_fun x); +val birs_rule_SUBST_trysimp_SING_fun = fn x => Profile.profile "birs_rule_SUBST_trysimp_SING_fun" (birs_rule_SUBST_trysimp_SING_fun x); + +fun birs_rule_SUBST_trysimp_first_fun (birs_rule_SUBST_thm,_) birs_simp_fun thm = + let + val assignment_thm_o = + SOME (MATCH_MP birs_rule_SUBST_thm thm) + handle _ => NONE; + + val simp_t_o = Option.mapPartial (fn assignment_thm => + let + val simp_tm = (fst o dest_imp o (*snd o strip_binder (SOME boolSyntax.universal) o*) concl o Q.SPEC `symbexp'`) assignment_thm; + (*val _ = print_term simp_tm;*) + val timer_exec_step_p3 = holba_miscLib.timer_start 0; + val simp_t = birs_simp_fun simp_tm; + (* TODO: need to remove the following line later and enable the simp function above *) + (*val simp_t_o = NONE;*) + val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n>>>>>> SUBST in " ^ delta_s ^ "\n")) timer_exec_step_p3; + in + SOME (simp_t, assignment_thm) + end) assignment_thm_o; + (* Pi is "bs2' INSERT (Pi DELETE bs2)"*) + val cleanup_Pi_conv = + let + open pred_setLib; + open aux_setLib; + in + RAND_CONV (DELETE_CONV birs_state_EQ_CONV) + end; + val cleanup_RULE = CONV_RULE (birs_utilsLib.birs_Pi_CONV cleanup_Pi_conv); + in + case simp_t_o of + SOME (simp_t, assignment_thm) => cleanup_RULE (MATCH_MP assignment_thm simp_t) + | NONE => thm + end; +val birs_rule_SUBST_trysimp_first_fun = fn x => Profile.profile "birs_rule_SUBST_trysimp_first_fun" (birs_rule_SUBST_trysimp_first_fun x); + +(* TODO: check if there is performance difference between this version and the one that applies the single item case, probably don't need special case... *) +fun birs_rule_SUBST_trysimp_fun x y = birs_utilsLib.birs_Pi_each_RULE (birs_rule_SUBST_trysimp_first_fun x y); end (* local *) diff --git a/src/tools/symbexec/birs_intervalLib.sml b/src/tools/symbexec/birs_intervalLib.sml index feda6ad6c..1d66743c4 100644 --- a/src/tools/symbexec/birs_intervalLib.sml +++ b/src/tools/symbexec/birs_intervalLib.sml @@ -198,7 +198,8 @@ in (* local *) val _ = print_term (hd refsymbs); *) val _ = if length refsymbs = 1 then () else - raise ERR "birs_intervals_Pi_first_unify_RULE::get_ref_symb" "unexpected"; + (print "\n\n"; print_term env_symbol; print_term intervaltm_; print "\n\n"; + raise ERR "birs_intervals_Pi_first_unify_RULE::get_ref_symb" "unexpected"); in hd refsymbs end; diff --git a/src/tools/symbexec/birs_utilsLib.sml b/src/tools/symbexec/birs_utilsLib.sml index f56ad6b98..b7941a2a4 100644 --- a/src/tools/symbexec/birs_utilsLib.sml +++ b/src/tools/symbexec/birs_utilsLib.sml @@ -326,6 +326,8 @@ in (* local *) RAND_CONV; fun sys_CONV conv = LAND_CONV conv; + fun L_CONV conv = + RAND_CONV (LAND_CONV conv); fun Pi_CONV conv = RAND_CONV (RAND_CONV conv); val first_CONV = @@ -335,11 +337,13 @@ in (* local *) local open pred_setSyntax; + open pred_setTheory; val rotate_first_INSERTs_thm = prove(`` !x1 x2 xs. (x1 INSERT x2 INSERT xs) = (x2 INSERT x1 INSERT xs) ``, - cheat + fs [EXTENSION] >> + metis_tac [] ); fun is_two_INSERTs tm = (is_insert tm) andalso ((is_insert o snd o dest_insert) tm); in @@ -351,8 +355,7 @@ in (* local *) val (x2_tm, xs_tm) = dest_insert x2xs_tm; val inst_thm = ISPECL [x1_tm, x2_tm, xs_tm] rotate_first_INSERTs_thm; in - (* TODO: the result of this should actually just be inst_thm *) - REWRITE_CONV [Once inst_thm] tm + inst_thm end; fun rotate_INSERTs_conv tm = @@ -364,8 +367,8 @@ in (* local *) (* apply state transformer to sys *) fun birs_sys_CONV conv tm = let - val _ = if symb_sound_struct_is_normform tm then () else - raise ERR "birs_sys_CONV" "term is not a standard birs_symb_exec"; + val _ = if is_birs_symb_exec tm then () else + raise ERR "birs_sys_CONV" "cannot handle term"; in (struct_CONV (sys_CONV conv)) tm end; @@ -373,12 +376,21 @@ in (* local *) (* apply state transformer to Pi *) fun birs_Pi_CONV conv tm = let - val _ = if symb_sound_struct_is_normform tm then () else - raise ERR "birs_Pi_CONV" "term is not a standard birs_symb_exec"; + val _ = if is_birs_symb_exec tm then () else + raise ERR "birs_Pi_CONV" "cannot handle term"; in (struct_CONV (Pi_CONV conv)) tm end; + (* apply state transformer to L *) + fun birs_L_CONV conv tm = + let + val _ = if is_birs_symb_exec tm then () else + raise ERR "birs_L_CONV" "cannot handle term"; + in + struct_CONV (L_CONV conv) tm + end; + (* apply state transformer to first state in Pi *) fun birs_Pi_first_CONV conv = birs_Pi_CONV (first_CONV conv); From e66f3014bbed347f411724b6f9abf7bf80902a56 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Wed, 16 Oct 2024 15:48:55 +0200 Subject: [PATCH 76/95] Add checks, profiling and cleanup a bit --- src/tools/symbexec/birs_intervalLib.sml | 110 +++++++++++++++--- src/tools/symbexec/birs_simp_instancesLib.sml | 15 +++ src/tools/symbexec/examples/test-simps.sml | 82 +++++++++++++ 3 files changed, 193 insertions(+), 14 deletions(-) create mode 100644 src/tools/symbexec/examples/test-simps.sml diff --git a/src/tools/symbexec/birs_intervalLib.sml b/src/tools/symbexec/birs_intervalLib.sml index 1d66743c4..87c63a172 100644 --- a/src/tools/symbexec/birs_intervalLib.sml +++ b/src/tools/symbexec/birs_intervalLib.sml @@ -6,7 +6,7 @@ local open HolKernel Parse boolLib bossLib; open stringSyntax; - open bir_envSyntax bir_expSyntax; + open bir_envSyntax bir_expSyntax bir_exp_immSyntax; open birsSyntax; open birs_utilsLib; @@ -30,12 +30,94 @@ local (strip_set o snd o dest_eq o concl) thm end handle _ => raise ERR "get_vars_of_bexp" "did not work"; +(**) - fun is_beq_left ref_symb tm = (is_comb tm) andalso ((identical ``BExp_BinPred BIExp_Equal (BExp_Den ^(ref_symb))`` o fst o dest_comb) tm); - fun is_binterval ref_symb tm = (is_comb tm) andalso ((identical ``BExp_IntervalPred (BExp_Den ^(ref_symb))`` o fst o dest_comb) tm); + fun vn_symb vn = "syi_" ^ vn; + fun init_symb vn = ("sy_"^vn); + + fun dest_BExp_IntervalPred_normform_limit tm = + let + val (bop, left, right) = dest_BExp_BinExp tm; + val refvar = dest_BExp_Den left; + val v = dest_BExp_Const right; + val _ = + if is_BIExp_Plus bop + then () + else raise ERR "dest_BExp_IntervalPred_normform_limit" ""; + in + (refvar, v) + end + handle _ => raise ERR "dest_BExp_IntervalPred_normform_limit" ("not in standard shape" ^ (term_to_string tm)); + + fun is_beq_left ref_symb tm = (is_comb tm) andalso ((identical (mk_comb (mk_comb (BExp_BinPred_tm, BIExp_Equal_tm), mk_BExp_Den ref_symb)) o fst o dest_comb) tm); + fun is_binterval ref_symb tm = (is_comb tm) andalso ((identical (mk_comb (BExp_IntervalPred_tm, mk_BExp_Den ref_symb)) o fst o dest_comb) tm); fun beq_left_to_binterval ref_symb tm = - let val minmax_tm = (snd o dest_comb) tm; - in ``BExp_IntervalPred (BExp_Den ^(ref_symb)) (^minmax_tm, ^minmax_tm)`` end; + let + val minmax_tm = (snd o dest_comb) tm; + val minmax_fixed_tm = + if can dest_BExp_IntervalPred_normform_limit minmax_tm then + minmax_tm + else if is_BExp_Den minmax_tm then + mk_BExp_BinExp (BIExp_Plus_tm, minmax_tm, mk_BExp_Const (``0w:word64``)) + else + raise (print_term tm; ERR "beq_left_to_binterval" "unexpected expression"); + in mk_BExp_IntervalPred (mk_BExp_Den ref_symb, pairSyntax.mk_pair(minmax_fixed_tm, minmax_fixed_tm)) end; + + fun interval_from_state vn tm = + let + val (_,env,_,pcond) = dest_birs_state tm; + val env_exp = (snd o get_env_top_mapping) env; + (* check that env_exp is just a bexp_den and has the name vn_symb *) + val _ = if (is_BExp_Den env_exp) andalso (((fn x => x = vn_symb vn) o fst o dest_BVar_string o dest_BExp_Den) env_exp) then () else + raise ERR "interval_from_state" ("unexpected, the expression should be just the syi_ symbol: " ^ (term_to_string env_exp)); + val env_symbol = dest_BExp_Den env_exp; + val pcondl = dest_band pcond; + val pcond_intervaltms = List.filter (is_binterval env_symbol) pcondl; + val pcondl_filtd = List.filter (not o is_binterval env_symbol) pcondl; + val _ = if length pcond_intervaltms = 1 then () else + raise ERR "interval_from_state" ("unexpected, could not find interval for: " ^ (term_to_string env_symbol)); + val interval = hd pcond_intervaltms; + in + (interval, fn x => bslSyntax.bandl (x::pcondl_filtd)) + end; + + fun dest_BExp_IntervalPred_normform tm = + let + val (x,iv) = dest_BExp_IntervalPred tm; + val (l,h) = pairSyntax.dest_pair iv; + val xvar = dest_BExp_Den x; + val (refvarl, lval) = dest_BExp_IntervalPred_normform_limit l; + val (refvarh, hval) = dest_BExp_IntervalPred_normform_limit h; + val _ = + if identical refvarl refvarh + then () + else raise ERR "dest_BExp_IntervalPred_normform" ""; + in + (xvar, refvarl, (lval,hval)) + end + handle _ => raise ERR "dest_BExp_IntervalPred_normform" ("not in standard shape" ^ (term_to_string tm)); + + fun is_BExp_IntervalPred_normform vn tm = + let + val (xvar, refvar, _) = dest_BExp_IntervalPred_normform tm; + in + ((fst o dest_BVar_string) xvar) = vn_symb vn andalso + ((fst o dest_BVar_string) refvar) = init_symb vn + end + handle _ => false; + + fun check_BExp_IntervalPred_normform_RULE vn thm = + let + val Pi_tms = (pred_setSyntax.strip_set o get_birs_Pi o concl) thm; + val intervaltms = List.map (fst o interval_from_state vn) Pi_tms; + + val is_ok = if List.all (is_BExp_IntervalPred_normform vn) intervaltms then () else ( + print_thm thm; + raise ERR "check_BExp_IntervalPred_normform_RULE" "some interval is not in a standard form" + ); + in + thm + end; local val intervalpattern64_tm = `` @@ -140,8 +222,6 @@ in (* local *) let val _ = if (symb_sound_struct_is_normform o concl) thm then () else raise ERR "birs_intervals_Pi_first_unify_RULE" "theorem is not a standard birs_symb_exec"; - val vn_symb = "syi_" ^ vn; - val init_symb = ("sy_"^vn); val _ = if not debug_mode then () else print "starting to unify interval for one Pi state\n"; @@ -153,7 +233,7 @@ in (* local *) then remember it (because there should already be an interval for it in the path condition), otherwise freesymbol the mapping *) val (thm1, env_symbol) = - if (is_BExp_Den env_exp) andalso (((fn x => x <> init_symb) o fst o dest_BVar_string o dest_BExp_Den) env_exp) then + if (is_BExp_Den env_exp) andalso (((fn x => x <> init_symb vn) o fst o dest_BVar_string o dest_BExp_Den) env_exp) then (thm0, dest_BExp_Den env_exp) else let @@ -184,6 +264,7 @@ in (* local *) ) else if length pcond_eqtms > 1 then raise ERR "birs_intervals_Pi_first_unify_RULE" "unexpected2" else + (* introduction of interval must already start in standard form, limits have to be plus(den,const) *) (beq_left_to_binterval env_symbol (hd pcond_eqtms)); val _ = if not debug_mode then () else print_term intervaltm; @@ -205,7 +286,7 @@ in (* local *) end; val refsymb = get_ref_symb intervaltm; val (intervalterm_fusion, pcondl_filtd_two) = - if (fst o dest_BVar_string) refsymb = init_symb then + if (fst o dest_BVar_string) refsymb = init_symb vn then (intervaltm, pcondl_filtd) else let @@ -228,7 +309,7 @@ in (* local *) (* rename so that the symbol used is ("syi_"^vn) for readability *) (* TODO: check, at this point no BVar symbol with the name vn_symb should occur in thm *) (* TODO: we will need a rename rule for this later, this one just works now because it is not following the theorem checks *) - val thm9 = birs_instantiationLib.birs_sound_symb_inst_RULE [(env_symbol, mk_BExp_Den (mk_BVar_string (vn_symb, (snd o dest_BVar) env_symbol)))] thmx; + val thm9 = birs_instantiationLib.birs_sound_symb_inst_RULE [(env_symbol, mk_BExp_Den (mk_BVar_string (vn_symb vn, (snd o dest_BVar) env_symbol)))] thmx; val _ = if not debug_mode then () else print "done unifying interval for one Pi state\n"; in @@ -236,6 +317,8 @@ in (* local *) end; fun birs_intervals_Pi_unify_RULE vn = birs_Pi_each_RULE (birs_intervals_Pi_first_unify_RULE vn); + val birs_intervals_Pi_unify_RULE = fn vn => check_BExp_IntervalPred_normform_RULE vn o birs_intervals_Pi_unify_RULE vn; + val birs_intervals_Pi_unify_RULE = fn x => Profile.profile "birs_intervals_Pi_unify_RULE" (birs_intervals_Pi_unify_RULE x); (* goes through all Pi states and unifies the interval bounds for env mapping vn (needed prior to merging of states) *) (* assumes that the unify rule was running before *) @@ -248,9 +331,6 @@ in (* local *) in if Pi_len < 2 then thm else let - val vn_symb = "syi_" ^ vn; - val init_symb = ("sy_"^vn); - val _ = if not debug_mode then () else print "starting to widen the bounds of the intervals in all Pi states\n"; (* collect the intervals from each Pi pathcondition *) @@ -260,7 +340,7 @@ in (* local *) val (_,env,_,pcond) = dest_birs_state tm; val env_exp = (snd o get_env_top_mapping) env; (* check that env_exp is just a bexp_den and has the name vn_symb *) - val _ = if (is_BExp_Den env_exp) andalso (((fn x => x = vn_symb) o fst o dest_BVar_string o dest_BExp_Den) env_exp) then () else + val _ = if (is_BExp_Den env_exp) andalso (((fn x => x = vn_symb vn) o fst o dest_BVar_string o dest_BExp_Den) env_exp) then () else raise ERR "birs_intervals_Pi_bounds_RULE" ("unexpected, the expression should be just the syi_ symbol: " ^ (term_to_string env_exp)); val env_symbol = dest_BExp_Den env_exp; val pcondl = dest_band pcond; @@ -286,6 +366,8 @@ in (* local *) thm_new end end; + val birs_intervals_Pi_bounds_RULE = fn vn => check_BExp_IntervalPred_normform_RULE vn o birs_intervals_Pi_bounds_RULE vn; + val birs_intervals_Pi_bounds_RULE = fn x => Profile.profile "birs_intervals_Pi_bounds_RULE" (birs_intervals_Pi_bounds_RULE x); (* (* use this function after an execution (or after merging), and before the next merging *) diff --git a/src/tools/symbexec/birs_simp_instancesLib.sml b/src/tools/symbexec/birs_simp_instancesLib.sml index 5be4db50f..669b48ad1 100644 --- a/src/tools/symbexec/birs_simp_instancesLib.sml +++ b/src/tools/symbexec/birs_simp_instancesLib.sml @@ -277,6 +277,21 @@ fun birs_simp_store_cheater simp_tm = []), subexp_cast_thms); + val birs_simp_default_core_exp_simp = + let + val include_64 = true; + val include_32 = true; + val mem_64 = false; + val mem_32 = false; + val riscv = false; + val cm0 = false; + in + birs_simp_gen + (simp_thms_tuple include_64 include_32 mem_64 mem_32 riscv cm0) + (load_thms_tuple mem_64 mem_32) + false + end; + fun birs_simp_default_riscv_gen use_store_cheater = let val include_64 = true; diff --git a/src/tools/symbexec/examples/test-simps.sml b/src/tools/symbexec/examples/test-simps.sml new file mode 100644 index 000000000..db773986e --- /dev/null +++ b/src/tools/symbexec/examples/test-simps.sml @@ -0,0 +1,82 @@ +open HolKernel Parse boolLib bossLib; + + +open birs_simpLib; +open birs_simp_instancesLib; + +val default_exp_simp = birs_simp_default_core_exp_simp; +val armcm0_simp = birs_simp_default_armcm0_gen false; + + + +val test_cases = [ + (default_exp_simp, + ``BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_UnaryExp BIExp_Not + (BExp_Den (BVar "sy_ModeHandler" (BType_Imm Bit1)))) + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_And + (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))) + (BExp_Const (Imm32 3w))) (BExp_Const (Imm32 0w))) + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessThan + (BExp_Const (Imm32 0x10001FE0w)) + (BExp_Den + (BVar "sy_SP_process" (BType_Imm Bit32)))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_Den + (BVar "sy_SP_process" (BType_Imm Bit32))) + (BExp_Const (Imm32 0x10001FF0w)))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 0xFFFFF38w)))))) + (BExp_Den (BVar "syp_gen" (BType_Imm Bit1)))) + (BExp_UnaryExp BIExp_Not + (BExp_BinPred BIExp_LessOrEqual + (BExp_BinExp BIExp_LeftShift (BExp_Const (Imm32 1w)) + (BExp_Const (Imm32 16w))) + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32)))))``, + ``BExp_IfThenElse + (BExp_BinPred BIExp_LessOrEqual + (BExp_BinExp BIExp_LeftShift (BExp_Const (Imm32 1w)) + (BExp_Const (Imm32 16w))) + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32)))) + (BExp_BinExp BIExp_Plus + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 4w))) (BExp_Const (Imm64 1w))) + (BExp_BinExp BIExp_Plus + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 4w))) (BExp_Const (Imm64 3w)))``, + ``(BExp_BinExp BIExp_Plus (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 (4w + 3w))))``) +]; + +(* +val (simp_fun, pcond, bexp, expected) = hd test_cases; +*) + +fun test (simp_fun, pcond, bexp, expected) = + let + val simp_tm = birs_simp_gen_term pcond bexp; + (*val _ = print_term simp_tm;*) + val expected_thm_concl = subst [``symbexp':bir_exp_t`` |-> expected] simp_tm; + val res_thm = simp_fun simp_tm; + (*val _ = print_thm res_thm;*) + val is_expected = identical expected_thm_concl (concl res_thm); + + val _ = if is_expected then () else ( + print "\nexpected:\n"; + print_term expected_thm_concl; + print "\nwe have\n"; + print_thm res_thm; + raise Fail "not as expected" + ); + in () end; + +val _ = List.app test test_cases; From 395ec57a91382f5074815d04444f14bb11c3a0b7 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Wed, 16 Oct 2024 16:07:56 +0200 Subject: [PATCH 77/95] More cleanup --- src/tools/symbexec/bir_vars_ofLib.sml | 9 + src/tools/symbexec/birs_intervalLib.sml | 15 +- src/tools/symbexec/birs_simpLib.sml | 313 +--------------- src/tools/symbexec/birs_simp_instancesLib.sml | 3 +- src/tools/symbexec/birs_utilsLib.sml | 31 +- src/tools/symbexec/examples/test-simps.sml | 346 +++++++++++++++++- 6 files changed, 385 insertions(+), 332 deletions(-) diff --git a/src/tools/symbexec/bir_vars_ofLib.sml b/src/tools/symbexec/bir_vars_ofLib.sml index 056070aa8..329685b9d 100644 --- a/src/tools/symbexec/bir_vars_ofLib.sml +++ b/src/tools/symbexec/bir_vars_ofLib.sml @@ -38,6 +38,15 @@ in (* local *) val bir_vars_of_exp_CONV = birs_auxLib.GEN_match_conv (is_bir_vars_of_exp) bir_vars_of_exp_DIRECT_CONV; + fun get_vars_of_bexp tm = + let + open pred_setSyntax; + val thm = bir_vars_of_exp_DIRECT_CONV (mk_bir_vars_of_exp tm); + in + (strip_set o snd o dest_eq o concl) thm + end + handle _ => raise ERR "get_vars_of_bexp" "did not work"; + (* ---------------------------------------------------------------------------------- *) (* symbols of set of symbolic states *) (* ---------------------------------------------------------------------------------- *) diff --git a/src/tools/symbexec/birs_intervalLib.sml b/src/tools/symbexec/birs_intervalLib.sml index 87c63a172..8812bac55 100644 --- a/src/tools/symbexec/birs_intervalLib.sml +++ b/src/tools/symbexec/birs_intervalLib.sml @@ -19,19 +19,6 @@ local val debug_mode = false; -(* TODO: move to bir_vars_ofLib *) - fun get_vars_of_bexp tm = - let - open bir_vars_ofLib; - open pred_setSyntax; - open bir_typing_expSyntax; - val thm = bir_vars_of_exp_DIRECT_CONV (mk_bir_vars_of_exp tm); - in - (strip_set o snd o dest_eq o concl) thm - end - handle _ => raise ERR "get_vars_of_bexp" "did not work"; -(**) - fun vn_symb vn = "syi_" ^ vn; fun init_symb vn = ("sy_"^vn); @@ -272,7 +259,7 @@ in (* local *) (* TODO: the following is a quick solution without much checks *) fun get_ref_symb intervaltm_ = let - val refsymbs = List.filter (fn x => not (identical x env_symbol)) (get_vars_of_bexp intervaltm_); + val refsymbs = List.filter (fn x => not (identical x env_symbol)) (bir_vars_ofLib.get_vars_of_bexp intervaltm_); (* val _ = PolyML.print_depth 10; val _ = PolyML.print refsymbs; diff --git a/src/tools/symbexec/birs_simpLib.sml b/src/tools/symbexec/birs_simpLib.sml index c3be33d61..fafff22bd 100644 --- a/src/tools/symbexec/birs_simpLib.sml +++ b/src/tools/symbexec/birs_simpLib.sml @@ -8,7 +8,6 @@ open HolKernel Parse boolLib bossLib; open bir_symb_simpTheory; open bir_exp_typecheckLib; -open bir_smtLib; open birs_auxLib; @@ -262,22 +261,6 @@ birs_simp_try_inst simp_t simp_inst_tm; val abc = simp_try_fold_gen birs_simp_try_plain birs_simp_exp_plain_thms (simp_inst_tm, NONE); *) - fun check_imp_tm imp_tm = - if not (birsSyntax.is_birs_exp_imp imp_tm) then raise ERR "check_imp_tm" "term needs to be birs_exp_imp" else - let - val (pred1_tm, pred2_tm) = birsSyntax.dest_birs_exp_imp imp_tm; - val imp_bexp_tm = bslSyntax.bor (bslSyntax.bnot pred1_tm, pred2_tm); - val imp_is_taut = bir_smt_check_taut false imp_bexp_tm; - in - if imp_is_taut then - SOME (mk_oracle_thm "BIRS_SIMP_LIB_Z3" ([], imp_tm)) - else - NONE - end; - val check_imp_tm = aux_moveawayLib.wrap_cache_result Term.compare check_imp_tm; - - - (* val simp_t = birs_simplification_IfThenElse_T_thm; val simp_t = birs_simplification_IfThenElse_F_thm; @@ -311,7 +294,7 @@ val simp_tm = birs_simp_gen_term pcond bexp; (* take out the implication predicate, prove it with the smt solver function, and remove it from the theorem *) val imp_tm = (get_fst_antec o concl) instd_thm; val imp_thm = - case check_imp_tm imp_tm of + case birs_utilsLib.check_imp_tm imp_tm of SOME t => t | NONE => raise ERR "birs_simp_try_pcond" "path condition does not entail the simplification condition"; val final_thm = MP (MP instd_thm imp_thm) simp_thm; @@ -350,300 +333,6 @@ val simp_inst_tm = birs_simp_gen_term pcond bexp; *) - -(* - -val pcond = ````; -val bexp = ````; - -val pcond = ``(BExp_Const (Imm1 1w))``; -val bexp = ``BExp_Cast BIExp_SignedCast - (BExp_Cast BIExp_LowCast - (BExp_Cast BIExp_SignedCast - (BExp_Cast BIExp_LowCast - (BExp_BinExp BIExp_Plus - (BExp_Cast BIExp_SignedCast - (BExp_Cast BIExp_LowCast - (BExp_Const (Imm64 3w)) Bit32) - Bit64) - (BExp_Cast BIExp_SignedCast - (BExp_Cast BIExp_LowCast - (BExp_Const (Imm64 7w)) Bit32) - Bit64)) Bit32) Bit64) Bit32) Bit64``; - -val bexp = ``BExp_Cast BIExp_SignedCast - (BExp_Cast BIExp_LowCast - (BExp_Cast BIExp_SignedCast - (BExp_Cast BIExp_LowCast - (BExp_BinExp BIExp_Plus - (BExp_Cast BIExp_SignedCast - (BExp_Cast BIExp_LowCast - (BExp_Const (Imm64 3w)) Bit32) - Bit64) - (BExp_Cast BIExp_SignedCast - (BExp_Cast - BIExp_LowCast - (BExp_Const - (Imm64 1w)) - Bit32) Bit64)) - Bit32) Bit64) Bit32) Bit64``; - -val pcond = ``BExp_BinExp BIExp_And - (BExp_BinPred BIExp_Equal - (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) - (BExp_Const (Imm64 pre_x2))) - (BExp_BinExp BIExp_And - (BExp_BinPred BIExp_Equal - (BExp_BinExp BIExp_And - (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) - (BExp_Const (Imm64 7w))) - (BExp_Const (Imm64 0w))) - (BExp_BinExp BIExp_And - (BExp_BinPred BIExp_LessOrEqual - (BExp_Const (Imm64 4096w)) - (BExp_Den (BVar "sy_x2" (BType_Imm Bit64)))) - (BExp_BinPred BIExp_LessThan - (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) - (BExp_Const (Imm64 0x100000000w)))))``; -val bexp = ``(BExp_Load - (BExp_Store - (BExp_Den (BVar "sy_MEM8" (BType_Mem Bit64 Bit8))) - (BExp_BinExp BIExp_Minus - (BExp_BinExp BIExp_Minus - (BExp_Den - (BVar "sy_x2" (BType_Imm Bit64))) - (BExp_Const (Imm64 32w))) - (BExp_Const (Imm64 28w))) - BEnd_LittleEndian - (BExp_Cast BIExp_LowCast - (BExp_Const (Imm64 7w)) Bit32)) - (BExp_BinExp BIExp_Minus - (BExp_BinExp BIExp_Minus - (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) - (BExp_Const (Imm64 32w))) - (BExp_Const (Imm64 28w))) BEnd_LittleEndian - Bit32)``; -val bexp_stores = `` - (BExp_Store - (BExp_Store - (BExp_Store - (BExp_Store - (BExp_Store - (BExp_Store - (BExp_Den - (BVar "sy_MEM8" - (BType_Mem Bit64 Bit8))) - (BExp_BinExp BIExp_Plus - (BExp_BinExp BIExp_Minus - (BExp_Den - (BVar "sy_x2" - (BType_Imm Bit64))) - (BExp_Const (Imm64 32w))) - (BExp_Const (Imm64 24w))) - BEnd_LittleEndian - (BExp_Den - (BVar "sy_x1" - (BType_Imm Bit64)))) - (BExp_BinExp BIExp_Plus - (BExp_BinExp BIExp_Minus - (BExp_Den - (BVar "sy_x2" - (BType_Imm Bit64))) - (BExp_Const (Imm64 32w))) - (BExp_Const (Imm64 16w))) - BEnd_LittleEndian - (BExp_Den - (BVar "sy_x8" - (BType_Imm Bit64)))) - (BExp_BinExp BIExp_Minus - (BExp_BinExp BIExp_Minus - (BExp_Den - (BVar "sy_x2" - (BType_Imm Bit64))) - (BExp_Const (Imm64 0w))) - (BExp_Const (Imm64 20w))) - BEnd_LittleEndian - (BExp_Cast BIExp_LowCast - (BExp_Const (Imm64 1w)) Bit32)) - (BExp_BinExp BIExp_Plus - (BExp_BinExp BIExp_Minus - (BExp_Den - (BVar "sy_x2" - (BType_Imm Bit64))) - (BExp_Const (Imm64 64w))) - (BExp_Const (Imm64 24w))) - BEnd_LittleEndian - (BExp_BinExp BIExp_Minus - (BExp_Den - (BVar "sy_x2" (BType_Imm Bit64))) - (BExp_Const (Imm64 0w)))) - (BExp_BinExp BIExp_Minus - (BExp_BinExp BIExp_Minus - (BExp_Den - (BVar "sy_x2" (BType_Imm Bit64))) - (BExp_Const (Imm64 32w))) - (BExp_Const (Imm64 24w))) - BEnd_LittleEndian (BExp_Const (Imm64 3w))) - (BExp_BinExp BIExp_Minus - (BExp_BinExp BIExp_Minus - (BExp_Den - (BVar "sy_x2" (BType_Imm Bit64))) - (BExp_Const (Imm64 32w))) - (BExp_Const (Imm64 28w))) - BEnd_LittleEndian - (BExp_Cast BIExp_LowCast - (BExp_Const (Imm64 7w)) Bit32)) -``; -val bexp = bexp_stores; -val bexp = ``(BExp_Load - ^bexp_stores - (BExp_BinExp BIExp_Minus - (BExp_BinExp BIExp_Minus - (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) - (BExp_Const (Imm64 32w))) - (BExp_Const (Imm64 28w))) BEnd_LittleEndian - Bit32)``; -val bexp = ``BExp_Cast BIExp_SignedCast - (BExp_Load - (BExp_Store - (BExp_Store - (BExp_Store - (BExp_Store - (BExp_Store - (BExp_Store - (BExp_Den - (BVar "sy_MEM8" - (BType_Mem Bit64 Bit8))) - (BExp_BinExp BIExp_Plus - (BExp_BinExp BIExp_Minus - (BExp_Den - (BVar "sy_x2" - (BType_Imm Bit64))) - (BExp_Const (Imm64 32w))) - (BExp_Const (Imm64 24w))) - BEnd_LittleEndian - (BExp_Den - (BVar "sy_x1" - (BType_Imm Bit64)))) - (BExp_BinExp BIExp_Plus - (BExp_BinExp BIExp_Minus - (BExp_Den - (BVar "sy_x2" - (BType_Imm Bit64))) - (BExp_Const (Imm64 32w))) - (BExp_Const (Imm64 16w))) - BEnd_LittleEndian - (BExp_Den - (BVar "sy_x8" - (BType_Imm Bit64)))) - (BExp_BinExp BIExp_Minus - (BExp_BinExp BIExp_Minus - (BExp_Den - (BVar "sy_x2" - (BType_Imm Bit64))) - (BExp_Const (Imm64 0w))) - (BExp_Const (Imm64 20w))) - BEnd_LittleEndian - (BExp_Cast BIExp_LowCast - (BExp_Const (Imm64 1w)) Bit32)) - (BExp_BinExp BIExp_Plus - (BExp_BinExp BIExp_Minus - (BExp_Den - (BVar "sy_x2" - (BType_Imm Bit64))) - (BExp_Const (Imm64 64w))) - (BExp_Const (Imm64 24w))) - BEnd_LittleEndian - (BExp_BinExp BIExp_Minus - (BExp_Den - (BVar "sy_x2" (BType_Imm Bit64))) - (BExp_Const (Imm64 0w)))) - (BExp_BinExp BIExp_Minus - (BExp_BinExp BIExp_Minus - (BExp_Den - (BVar "sy_x2" (BType_Imm Bit64))) - (BExp_Const (Imm64 32w))) - (BExp_Const (Imm64 24w))) - BEnd_LittleEndian (BExp_Const (Imm64 3w))) - (BExp_BinExp BIExp_Minus - (BExp_BinExp BIExp_Minus - (BExp_Den - (BVar "sy_x2" (BType_Imm Bit64))) - (BExp_Const (Imm64 32w))) - (BExp_Const (Imm64 28w))) - BEnd_LittleEndian - (BExp_Cast BIExp_LowCast - (BExp_Const (Imm64 7w)) Bit32)) - (BExp_BinExp BIExp_Minus - (BExp_BinExp BIExp_Minus - (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) - (BExp_Const (Imm64 32w))) - (BExp_Const (Imm64 28w))) BEnd_LittleEndian - Bit32) Bit64``; - -val pcond = ``(BExp_BinPred BIExp_Equal - (BExp_Cast BIExp_UnsignedCast - (BExp_Cast BIExp_LowCast - (BExp_BinExp BIExp_RightShift - (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))) - (BExp_Const (Imm32 31w))) Bit8) Bit32) - (BExp_Const (Imm32 0w)))``; - -val pcond = ``BExp_UnaryExp BIExp_Not (^pcond)`` - -val bexp = `` - (BExp_IfThenElse - (BExp_BinPred BIExp_Equal - (BExp_Cast BIExp_UnsignedCast - (BExp_Cast BIExp_LowCast - (BExp_BinExp BIExp_RightShift - (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))) - (BExp_Const (Imm32 31w))) Bit8) Bit32) - (BExp_Const (Imm32 0w))) - (BExp_BinExp BIExp_Plus - (BExp_BinExp BIExp_Plus - (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) - (BExp_Const (Imm64 19w))) (BExp_Const (Imm64 3w))) - (BExp_BinExp BIExp_Plus - (BExp_BinExp BIExp_Plus - (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) - (BExp_Const (Imm64 19w))) (BExp_Const (Imm64 1w))))``; - - - - -val pcond = ``(BExp_Const (Imm1 1w))``; -val bexp = `` - BExp_BinExp BIExp_Plus - (BExp_BinExp BIExp_Plus - (BExp_Den (BVar "abcd" (BType_Imm Bit64))) - (BExp_Const (Imm64 22w))) - (BExp_Const (Imm64 14w))``; - - - -val pcond = `` - BExp_BinPred BIExp_Equal - (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))) - (BExp_Const (Imm32 35w))``; - -val bexp = `` - BExp_IfThenElse - (BExp_BinPred BIExp_LessThan - (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))) - (BExp_Const (Imm32 31w))) - (BExp_Const (Imm64 19w)) - (BExp_Const (Imm64 77w))``; - -val bexp = `` - BExp_BinExp BIExp_Minus - ^bexp - (BExp_Const (Imm64 2w))``; - - -*) - - end (* local *) end (* struct *) diff --git a/src/tools/symbexec/birs_simp_instancesLib.sml b/src/tools/symbexec/birs_simp_instancesLib.sml index 669b48ad1..6e4faa4b8 100644 --- a/src/tools/symbexec/birs_simp_instancesLib.sml +++ b/src/tools/symbexec/birs_simp_instancesLib.sml @@ -5,7 +5,6 @@ local open HolKernel Parse boolLib bossLib; open bir_exp_typecheckLib; - open bir_smtLib; open birs_simpLib; open bir_symb_simpTheory; @@ -75,7 +74,7 @@ in val vsz_eq = identical (get_type_of_bexp expv1) (get_type_of_bexp expv2); val imp_tm = birsSyntax.mk_birs_exp_imp (pcond, bslSyntax.beq (expad1, expad2)); - val ad_is_eq = isSome (check_imp_tm imp_tm); + val ad_is_eq = isSome (birs_utilsLib.check_imp_tm imp_tm); in endi_eq andalso vsz_eq andalso diff --git a/src/tools/symbexec/birs_utilsLib.sml b/src/tools/symbexec/birs_utilsLib.sml index b7941a2a4..430a88397 100644 --- a/src/tools/symbexec/birs_utilsLib.sml +++ b/src/tools/symbexec/birs_utilsLib.sml @@ -184,6 +184,20 @@ in (* local *) NONE end; + fun check_imp_tm imp_tm = + if not (is_birs_exp_imp imp_tm) then raise ERR "check_imp_tm" "term needs to be birs_exp_imp" else + let + val (pred1_tm, pred2_tm) = dest_birs_exp_imp imp_tm; + val imp_bexp_tm = bslSyntax.bor (bslSyntax.bnot pred1_tm, pred2_tm); + val imp_is_taut = bir_smtLib.bir_smt_check_taut false imp_bexp_tm; + in + if imp_is_taut then + SOME (mk_oracle_thm "BIRS_SIMP_LIB_Z3" ([], imp_tm)) + else + NONE + end; + val check_imp_tm = aux_moveawayLib.wrap_cache_result Term.compare check_imp_tm; + (* general path condition weakening with z3 (to throw away path condition conjuncts (to remove branch path condition conjuncts)) *) fun birs_Pi_first_pcond_RULE pcond_new thm = let @@ -208,7 +222,7 @@ in (* local *) isSome (is_DROP_L_imp imp_tm) orelse isSome (is_conjunct_inclusion_imp imp_tm); val pcond_imp_ok = pcond_drop_ok orelse (* TODO: something might be wrong in expression simplification before smtlib-z3 exporter *) - isSome (birs_simpLib.check_imp_tm imp_tm); + isSome (check_imp_tm imp_tm); val _ = if pcond_imp_ok then () else (print "widening failed, path condition is not weaker\n"; raise ERR "birs_Pi_first_pcond_RULE" "the supplied path condition is not weaker"); @@ -258,7 +272,7 @@ in (* local *) val _ = holba_z3Lib.debug_print := true; val _ = print "sending a z3 query\n"; *) - val pcond_imp_ok = isSome (birs_simpLib.check_imp_tm imp_tm); + val pcond_imp_ok = isSome (check_imp_tm imp_tm); val _ = if pcond_imp_ok then () else (print "narrowing failed, path condition is not stronger\n"; raise ERR "birs_sys_pcond_RULE" "the supplied path condition is not stronger"); @@ -448,6 +462,19 @@ in (* local *) end; (* ---------------------------------------------------------------------------------------- *) + local + open bir_programSyntax; + open optionSyntax; + in + fun birs_is_stmt_Assign tm = is_some tm andalso (is_BStmtB o dest_some) tm andalso (is_BStmt_Assign o dest_BStmtB o dest_some) tm; + fun birs_is_exec_branch thm = (get_birs_Pi_length o concl) thm > 1; + + fun birs_cond_RULE c f = + if c then f else I; + + fun birs_if_assign_RULE tm = birs_cond_RULE (birs_is_stmt_Assign tm); + fun birs_if_branch_RULE f thm = birs_cond_RULE (birs_is_exec_branch thm) f thm; + end end (* local *) diff --git a/src/tools/symbexec/examples/test-simps.sml b/src/tools/symbexec/examples/test-simps.sml index db773986e..133d96df3 100644 --- a/src/tools/symbexec/examples/test-simps.sml +++ b/src/tools/symbexec/examples/test-simps.sml @@ -6,8 +6,80 @@ open birs_simp_instancesLib; val default_exp_simp = birs_simp_default_core_exp_simp; val armcm0_simp = birs_simp_default_armcm0_gen false; +val riscv_simp = birs_simp_default_riscv_gen false; +val riscv_storestore_simp = birs_simp_default_riscv_gen true; +val bexp_stores = `` (BExp_Store + (BExp_Store + (BExp_Store + (BExp_Store + (BExp_Store + (BExp_Store + (BExp_Den + (BVar "sy_MEM8" + (BType_Mem Bit64 Bit8))) + (BExp_BinExp BIExp_Plus + (BExp_BinExp BIExp_Minus + (BExp_Den + (BVar "sy_x2" + (BType_Imm Bit64))) + (BExp_Const (Imm64 32w))) + (BExp_Const (Imm64 24w))) + BEnd_LittleEndian + (BExp_Den + (BVar "sy_x1" + (BType_Imm Bit64)))) + (BExp_BinExp BIExp_Plus + (BExp_BinExp BIExp_Minus + (BExp_Den + (BVar "sy_x2" + (BType_Imm Bit64))) + (BExp_Const (Imm64 32w))) + (BExp_Const (Imm64 16w))) + BEnd_LittleEndian + (BExp_Den + (BVar "sy_x8" + (BType_Imm Bit64)))) + (BExp_BinExp BIExp_Minus + (BExp_BinExp BIExp_Minus + (BExp_Den + (BVar "sy_x2" + (BType_Imm Bit64))) + (BExp_Const (Imm64 0w))) + (BExp_Const (Imm64 20w))) + BEnd_LittleEndian + (BExp_Cast BIExp_LowCast + (BExp_Const (Imm64 1w)) Bit32)) + (BExp_BinExp BIExp_Plus + (BExp_BinExp BIExp_Minus + (BExp_Den + (BVar "sy_x2" + (BType_Imm Bit64))) + (BExp_Const (Imm64 64w))) + (BExp_Const (Imm64 24w))) + BEnd_LittleEndian + (BExp_BinExp BIExp_Minus + (BExp_Den + (BVar "sy_x2" (BType_Imm Bit64))) + (BExp_Const (Imm64 0w)))) + (BExp_BinExp BIExp_Minus + (BExp_BinExp BIExp_Minus + (BExp_Den + (BVar "sy_x2" (BType_Imm Bit64))) + (BExp_Const (Imm64 32w))) + (BExp_Const (Imm64 24w))) + BEnd_LittleEndian (BExp_Const (Imm64 3w))) + (BExp_BinExp BIExp_Minus + (BExp_BinExp BIExp_Minus + (BExp_Den + (BVar "sy_x2" (BType_Imm Bit64))) + (BExp_Const (Imm64 32w))) + (BExp_Const (Imm64 28w))) + BEnd_LittleEndian + (BExp_Cast BIExp_LowCast + (BExp_Const (Imm64 7w)) Bit32)) +``; val test_cases = [ (default_exp_simp, @@ -54,7 +126,277 @@ val test_cases = [ (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) (BExp_Const (Imm64 4w))) (BExp_Const (Imm64 3w)))``, ``(BExp_BinExp BIExp_Plus (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) - (BExp_Const (Imm64 (4w + 3w))))``) + (BExp_Const (Imm64 (4w + 3w))))``), + + (riscv_simp, + ``(BExp_Const (Imm1 1w))``, + ``BExp_Cast BIExp_SignedCast + (BExp_Cast BIExp_LowCast + (BExp_Cast BIExp_SignedCast + (BExp_Cast BIExp_LowCast + (BExp_BinExp BIExp_Plus + (BExp_Cast BIExp_SignedCast + (BExp_Cast BIExp_LowCast + (BExp_Const (Imm64 3w)) Bit32) + Bit64) + (BExp_Cast BIExp_SignedCast + (BExp_Cast BIExp_LowCast + (BExp_Const (Imm64 7w)) Bit32) + Bit64)) Bit32) Bit64) Bit32) Bit64``, + ``BExp_Const (Imm64 (3w + 7w))``), + + (riscv_simp, + ``(BExp_Const (Imm1 1w))``, + ``BExp_Cast BIExp_SignedCast + (BExp_Cast BIExp_LowCast + (BExp_Cast BIExp_SignedCast + (BExp_Cast BIExp_LowCast + (BExp_BinExp BIExp_Plus + (BExp_Cast BIExp_SignedCast + (BExp_Cast BIExp_LowCast + (BExp_Const (Imm64 3w)) Bit32) + Bit64) + (BExp_Cast BIExp_SignedCast + (BExp_Cast + BIExp_LowCast + (BExp_Const + (Imm64 1w)) + Bit32) Bit64)) + Bit32) Bit64) Bit32) Bit64``, + ``BExp_Const (Imm64 (3w + 1w))``), + + (riscv_simp, + ``BExp_BinExp BIExp_And + (BExp_BinPred BIExp_Equal + (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) + (BExp_Const (Imm64 pre_x2))) + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_And + (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) + (BExp_Const (Imm64 7w))) + (BExp_Const (Imm64 0w))) + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual + (BExp_Const (Imm64 4096w)) + (BExp_Den (BVar "sy_x2" (BType_Imm Bit64)))) + (BExp_BinPred BIExp_LessThan + (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) + (BExp_Const (Imm64 0x100000000w)))))``, + ``(BExp_Load + (BExp_Store + (BExp_Den (BVar "sy_MEM8" (BType_Mem Bit64 Bit8))) + (BExp_BinExp BIExp_Minus + (BExp_BinExp BIExp_Minus + (BExp_Den + (BVar "sy_x2" (BType_Imm Bit64))) + (BExp_Const (Imm64 32w))) + (BExp_Const (Imm64 28w))) + BEnd_LittleEndian + (BExp_Cast BIExp_LowCast + (BExp_Const (Imm64 7w)) Bit32)) + (BExp_BinExp BIExp_Minus + (BExp_BinExp BIExp_Minus + (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) + (BExp_Const (Imm64 32w))) + (BExp_Const (Imm64 28w))) BEnd_LittleEndian + Bit32)``, + ``BExp_Cast BIExp_LowCast (BExp_Const (Imm64 7w)) Bit32``), + + (riscv_simp, + ``BExp_BinExp BIExp_And + (BExp_BinPred BIExp_Equal + (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) + (BExp_Const (Imm64 pre_x2))) + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_And + (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) + (BExp_Const (Imm64 7w))) + (BExp_Const (Imm64 0w))) + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual + (BExp_Const (Imm64 4096w)) + (BExp_Den (BVar "sy_x2" (BType_Imm Bit64)))) + (BExp_BinPred BIExp_LessThan + (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) + (BExp_Const (Imm64 0x100000000w)))))``, + ``(BExp_Load + ^bexp_stores + (BExp_BinExp BIExp_Minus + (BExp_BinExp BIExp_Minus + (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) + (BExp_Const (Imm64 32w))) + (BExp_Const (Imm64 28w))) BEnd_LittleEndian + Bit32)``, + ``BExp_Cast BIExp_LowCast (BExp_Const (Imm64 7w)) Bit32``), + + (riscv_simp, + ``BExp_BinExp BIExp_And + (BExp_BinPred BIExp_Equal + (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) + (BExp_Const (Imm64 pre_x2))) + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_And + (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) + (BExp_Const (Imm64 7w))) + (BExp_Const (Imm64 0w))) + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual + (BExp_Const (Imm64 4096w)) + (BExp_Den (BVar "sy_x2" (BType_Imm Bit64)))) + (BExp_BinPred BIExp_LessThan + (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) + (BExp_Const (Imm64 0x100000000w)))))``, + ``BExp_Cast BIExp_SignedCast + (BExp_Load + (BExp_Store + (BExp_Store + (BExp_Store + (BExp_Store + (BExp_Store + (BExp_Store + (BExp_Den + (BVar "sy_MEM8" + (BType_Mem Bit64 Bit8))) + (BExp_BinExp BIExp_Plus + (BExp_BinExp BIExp_Minus + (BExp_Den + (BVar "sy_x2" + (BType_Imm Bit64))) + (BExp_Const (Imm64 32w))) + (BExp_Const (Imm64 24w))) + BEnd_LittleEndian + (BExp_Den + (BVar "sy_x1" + (BType_Imm Bit64)))) + (BExp_BinExp BIExp_Plus + (BExp_BinExp BIExp_Minus + (BExp_Den + (BVar "sy_x2" + (BType_Imm Bit64))) + (BExp_Const (Imm64 32w))) + (BExp_Const (Imm64 16w))) + BEnd_LittleEndian + (BExp_Den + (BVar "sy_x8" + (BType_Imm Bit64)))) + (BExp_BinExp BIExp_Minus + (BExp_BinExp BIExp_Minus + (BExp_Den + (BVar "sy_x2" + (BType_Imm Bit64))) + (BExp_Const (Imm64 0w))) + (BExp_Const (Imm64 20w))) + BEnd_LittleEndian + (BExp_Cast BIExp_LowCast + (BExp_Const (Imm64 1w)) Bit32)) + (BExp_BinExp BIExp_Plus + (BExp_BinExp BIExp_Minus + (BExp_Den + (BVar "sy_x2" + (BType_Imm Bit64))) + (BExp_Const (Imm64 64w))) + (BExp_Const (Imm64 24w))) + BEnd_LittleEndian + (BExp_BinExp BIExp_Minus + (BExp_Den + (BVar "sy_x2" (BType_Imm Bit64))) + (BExp_Const (Imm64 0w)))) + (BExp_BinExp BIExp_Minus + (BExp_BinExp BIExp_Minus + (BExp_Den + (BVar "sy_x2" (BType_Imm Bit64))) + (BExp_Const (Imm64 32w))) + (BExp_Const (Imm64 24w))) + BEnd_LittleEndian (BExp_Const (Imm64 3w))) + (BExp_BinExp BIExp_Minus + (BExp_BinExp BIExp_Minus + (BExp_Den + (BVar "sy_x2" (BType_Imm Bit64))) + (BExp_Const (Imm64 32w))) + (BExp_Const (Imm64 28w))) + BEnd_LittleEndian + (BExp_Cast BIExp_LowCast + (BExp_Const (Imm64 7w)) Bit32)) + (BExp_BinExp BIExp_Minus + (BExp_BinExp BIExp_Minus + (BExp_Den (BVar "sy_x2" (BType_Imm Bit64))) + (BExp_Const (Imm64 32w))) + (BExp_Const (Imm64 28w))) BEnd_LittleEndian + Bit32) Bit64``, + ``BExp_Cast BIExp_SignedCast + (BExp_Cast BIExp_LowCast (BExp_Const (Imm64 7w)) Bit32) Bit64``), + + (armcm0_simp, + ``(BExp_BinPred BIExp_Equal + (BExp_Cast BIExp_UnsignedCast + (BExp_Cast BIExp_LowCast + (BExp_BinExp BIExp_RightShift + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))) + (BExp_Const (Imm32 31w))) Bit8) Bit32) + (BExp_Const (Imm32 0w)))``, + ``BExp_IfThenElse + (BExp_BinPred BIExp_Equal + (BExp_Cast BIExp_UnsignedCast + (BExp_Cast BIExp_LowCast + (BExp_BinExp BIExp_RightShift + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))) + (BExp_Const (Imm32 31w))) Bit8) Bit32) + (BExp_Const (Imm32 0w))) + (BExp_BinExp BIExp_Plus + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 19w))) (BExp_Const (Imm64 3w))) + (BExp_BinExp BIExp_Plus + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 19w))) (BExp_Const (Imm64 1w)))``, + ``BExp_BinExp BIExp_Plus (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 (19w + 3w)))``), + + (default_exp_simp, + ``(BExp_Const (Imm1 1w))``, + `` + BExp_BinExp BIExp_Plus + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "abcd" (BType_Imm Bit64))) + (BExp_Const (Imm64 22w))) + (BExp_Const (Imm64 14w))``, + ``BExp_BinExp BIExp_Plus (BExp_Den (BVar "abcd" (BType_Imm Bit64))) + (BExp_Const (Imm64 (22w + 14w)))``), + + (default_exp_simp, + `` + BExp_BinPred BIExp_Equal + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))) + (BExp_Const (Imm32 35w))``, + `` + BExp_IfThenElse + (BExp_BinPred BIExp_LessThan + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))) + (BExp_Const (Imm32 31w))) + (BExp_Const (Imm64 19w)) + (BExp_Const (Imm64 77w))``, + ``BExp_Const (Imm64 77w)``), + + (default_exp_simp, + `` + BExp_BinPred BIExp_Equal + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))) + (BExp_Const (Imm32 35w)) + ``, + `` + BExp_BinExp BIExp_Minus + (BExp_IfThenElse + (BExp_BinPred BIExp_LessThan + (BExp_Den (BVar "sy_R0" (BType_Imm Bit32))) + (BExp_Const (Imm32 31w))) + (BExp_Const (Imm64 19w)) + (BExp_Const (Imm64 77w))) + (BExp_Const (Imm64 2w))``, + ``BExp_BinExp BIExp_Minus (BExp_Const (Imm64 77w)) (BExp_Const (Imm64 2w))``) ]; (* @@ -65,9 +407,9 @@ fun test (simp_fun, pcond, bexp, expected) = let val simp_tm = birs_simp_gen_term pcond bexp; (*val _ = print_term simp_tm;*) - val expected_thm_concl = subst [``symbexp':bir_exp_t`` |-> expected] simp_tm; val res_thm = simp_fun simp_tm; (*val _ = print_thm res_thm;*) + val expected_thm_concl = subst [``symbexp':bir_exp_t`` |-> expected] simp_tm; val is_expected = identical expected_thm_concl (concl res_thm); val _ = if is_expected then () else ( From 7915fd535740f00330b1bdaeee08389d05c3ec4f Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Wed, 16 Oct 2024 17:43:18 +0200 Subject: [PATCH 78/95] Fix simplifications --- .../tools/symbexec/bir_symb_simpScript.sml | 33 +++++++++++++++++++ src/tools/symbexec/birs_simpLib.sml | 14 ++++++-- src/tools/symbexec/birs_simp_instancesLib.sml | 5 ++- src/tools/symbexec/examples/test-simps.sml | 12 +++---- 4 files changed, 54 insertions(+), 10 deletions(-) diff --git a/src/theory/tools/symbexec/bir_symb_simpScript.sml b/src/theory/tools/symbexec/bir_symb_simpScript.sml index d03b077be..6df187619 100644 --- a/src/theory/tools/symbexec/bir_symb_simpScript.sml +++ b/src/theory/tools/symbexec/bir_symb_simpScript.sml @@ -470,6 +470,17 @@ Proof birs_simp_const_TAC QED +Theorem birs_simplification_Minus_Const64_thm: + !pcond w1 w2. + (birs_simplification pcond + (BExp_BinExp BIExp_Minus + (BExp_Const (Imm64 w1)) + (BExp_Const (Imm64 w2))) + (BExp_Const (Imm64 (w1 - w2)))) +Proof + birs_simp_const_TAC +QED + Theorem birs_simplification_Plus_Plus_Const64_thm: !pcond be w1 w2. (type_of_bir_exp be = SOME (BType_Imm Bit64)) ==> @@ -534,6 +545,28 @@ Proof birs_simp_const_TAC QED +Theorem birs_simplification_Plus_Const32_thm: + !pcond w1 w2. + (birs_simplification pcond + (BExp_BinExp BIExp_Plus + (BExp_Const (Imm32 w1)) + (BExp_Const (Imm32 w2))) + (BExp_Const (Imm32 (w1 + w2)))) +Proof + birs_simp_const_TAC +QED + +Theorem birs_simplification_Minus_Const32_thm: + !pcond w1 w2. + (birs_simplification pcond + (BExp_BinExp BIExp_Minus + (BExp_Const (Imm32 w1)) + (BExp_Const (Imm32 w2))) + (BExp_Const (Imm32 (w1 - w2)))) +Proof + birs_simp_const_TAC +QED + Theorem birs_simplification_Plus_Plus_Const32_thm: !pcond be w1 w2. (type_of_bir_exp be = SOME (BType_Imm Bit32)) ==> diff --git a/src/tools/symbexec/birs_simpLib.sml b/src/tools/symbexec/birs_simpLib.sml index fafff22bd..0903e24ad 100644 --- a/src/tools/symbexec/birs_simpLib.sml +++ b/src/tools/symbexec/birs_simpLib.sml @@ -253,9 +253,17 @@ birs_simp_try_inst simp_t simp_inst_tm; simp_try_inst_gen (get_op, get_op); - fun birs_simp_try_plain h_thm simp_tm = - Option.mapPartial birs_simp_try_fix_assumptions (birs_simp_try_inst h_thm simp_tm); - val birs_simp_try_plain = fn h_thm => simp_try_make_option_fun (birs_simp_try_plain h_thm); + fun birs_simp_try_plain postconv_o h_thm simp_tm = + let + val thm_o = Option.mapPartial birs_simp_try_fix_assumptions (birs_simp_try_inst h_thm simp_tm); + val postfun = + case postconv_o of + NONE => I + | SOME postconv => Option.map (CONV_RULE (RAND_CONV postconv)); + in + postfun thm_o + end; + val birs_simp_try_plain = fn postconv_o => fn h_thm => simp_try_make_option_fun (birs_simp_try_plain postconv_o h_thm); (* val simp_inst_tm = birs_simp_gen_term pcond bexp; val abc = simp_try_fold_gen birs_simp_try_plain birs_simp_exp_plain_thms (simp_inst_tm, NONE); diff --git a/src/tools/symbexec/birs_simp_instancesLib.sml b/src/tools/symbexec/birs_simp_instancesLib.sml index 6e4faa4b8..295f20812 100644 --- a/src/tools/symbexec/birs_simp_instancesLib.sml +++ b/src/tools/symbexec/birs_simp_instancesLib.sml @@ -124,7 +124,7 @@ fun birs_simp_store_cheater simp_tm = *) fun birs_simp_try_direct (plain_thms, pcond_thms) = simp_try_list_gen [ - simp_try_fold_gen birs_simp_try_plain plain_thms, + simp_try_fold_gen (birs_simp_try_plain (SOME EVAL)) plain_thms, simp_try_fold_gen birs_simp_try_pcond pcond_thms ]; @@ -215,6 +215,9 @@ fun birs_simp_store_cheater simp_tm = else [])@ [birs_simplification_Plus_Const64_thm, + birs_simplification_Minus_Const64_thm, + birs_simplification_Plus_Const32_thm, + birs_simplification_Minus_Const32_thm, birs_simplification_UnsignedCast_LowCast_Twice_thm]; fun pcond_thms mem_64 mem_32 riscv cm0 = diff --git a/src/tools/symbexec/examples/test-simps.sml b/src/tools/symbexec/examples/test-simps.sml index 133d96df3..295e380d0 100644 --- a/src/tools/symbexec/examples/test-simps.sml +++ b/src/tools/symbexec/examples/test-simps.sml @@ -126,7 +126,7 @@ val test_cases = [ (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) (BExp_Const (Imm64 4w))) (BExp_Const (Imm64 3w)))``, ``(BExp_BinExp BIExp_Plus (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) - (BExp_Const (Imm64 (4w + 3w))))``), + (BExp_Const (Imm64 (7w))))``), (riscv_simp, ``(BExp_Const (Imm1 1w))``, @@ -143,7 +143,7 @@ val test_cases = [ (BExp_Cast BIExp_LowCast (BExp_Const (Imm64 7w)) Bit32) Bit64)) Bit32) Bit64) Bit32) Bit64``, - ``BExp_Const (Imm64 (3w + 7w))``), + ``BExp_Const (Imm64 (10w))``), (riscv_simp, ``(BExp_Const (Imm1 1w))``, @@ -163,7 +163,7 @@ val test_cases = [ (Imm64 1w)) Bit32) Bit64)) Bit32) Bit64) Bit32) Bit64``, - ``BExp_Const (Imm64 (3w + 1w))``), + ``BExp_Const (Imm64 (4w))``), (riscv_simp, ``BExp_BinExp BIExp_And @@ -354,7 +354,7 @@ val test_cases = [ (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) (BExp_Const (Imm64 19w))) (BExp_Const (Imm64 1w)))``, ``BExp_BinExp BIExp_Plus (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) - (BExp_Const (Imm64 (19w + 3w)))``), + (BExp_Const (Imm64 (22w)))``), (default_exp_simp, ``(BExp_Const (Imm1 1w))``, @@ -365,7 +365,7 @@ val test_cases = [ (BExp_Const (Imm64 22w))) (BExp_Const (Imm64 14w))``, ``BExp_BinExp BIExp_Plus (BExp_Den (BVar "abcd" (BType_Imm Bit64))) - (BExp_Const (Imm64 (22w + 14w)))``), + (BExp_Const (Imm64 (36w)))``), (default_exp_simp, `` @@ -396,7 +396,7 @@ val test_cases = [ (BExp_Const (Imm64 19w)) (BExp_Const (Imm64 77w))) (BExp_Const (Imm64 2w))``, - ``BExp_BinExp BIExp_Minus (BExp_Const (Imm64 77w)) (BExp_Const (Imm64 2w))``) + ``BExp_Const (Imm64 75w)``) ]; (* From 4959ee2f80ed396c0c7ca08236c50cce0f86251c Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Thu, 17 Oct 2024 20:01:30 +0200 Subject: [PATCH 79/95] Add core functionality to enable the reuse of previous execution results --- src/tools/symbexec/birs_composeLib.sml | 10 +- src/tools/symbexec/birs_driveLib.sml | 142 +++++++++++++------------ 2 files changed, 78 insertions(+), 74 deletions(-) diff --git a/src/tools/symbexec/birs_composeLib.sml b/src/tools/symbexec/birs_composeLib.sml index 4f5e6ddf1..29f5ddd3e 100644 --- a/src/tools/symbexec/birs_composeLib.sml +++ b/src/tools/symbexec/birs_composeLib.sml @@ -63,10 +63,10 @@ in val _ = birs_symb_exec_check_compatible step_A_thm step_B_thm; val prep_thm = - HO_MATCH_MP (HO_MATCH_MP birs_rule_SEQ_thm step_A_thm) step_B_thm; + Profile.profile "birs_rule_SEQ_fun_1_match" (HO_MATCH_MP (HO_MATCH_MP birs_rule_SEQ_thm step_A_thm)) step_B_thm; val freesymbols_tm = (fst o dest_imp o concl) prep_thm; - val freesymbols_thm = birs_rule_SEQ_INTER_freesymbs_fun freesymbols_tm; + val freesymbols_thm = Profile.profile "birs_rule_SEQ_fun_2_freesymbols" birs_rule_SEQ_INTER_freesymbs_fun freesymbols_tm; val _ = print "finished to proof free symbols altogether\n"; val bprog_composed_thm = @@ -74,9 +74,10 @@ in val _ = print "composed\n"; (* tidy up set operations to not accumulate (in both, post state set and label set) *) - val bprog_fixed_thm = CONV_RULE + val bprog_fixed_thm = + Profile.profile "birs_rule_SEQ_fun_3_tidyupsets" (CONV_RULE (birs_Pi_CONV birs_state_DIFF_UNION_CONV THENC - birs_L_CONV labelset_UNION_CONV) + birs_L_CONV labelset_UNION_CONV)) bprog_composed_thm handle e => (print "\n\n"; print_thm bprog_composed_thm; print "tidy up Pi and labelset failed\n"; raise e); @@ -86,6 +87,7 @@ in in bprog_fixed_thm end; + val birs_rule_SEQ_fun = fn x => fn y => Profile.profile "birs_rule_SEQ_fun" (birs_rule_SEQ_fun x y); end (* local *) diff --git a/src/tools/symbexec/birs_driveLib.sml b/src/tools/symbexec/birs_driveLib.sml index 68a9d8b0f..f519c20af 100644 --- a/src/tools/symbexec/birs_driveLib.sml +++ b/src/tools/symbexec/birs_driveLib.sml @@ -17,16 +17,7 @@ open birs_auxTheory; in (* local *) -(* -val tm = ``<|bsst_pc := a; - bsst_environ :=b; - bsst_status := BST_AssertionViolated; - bsst_pcond := c|>``; -val tm = ``<|bsst_pc := a; - bsst_environ :=b; - bsst_status := BST_Running; - bsst_pcond := c|>``; -*) +(* TODO: move to syntax, move something else from syntax to utils *) fun birs_get_pc tm = let val (pc, _, _, _) = dest_birs_state tm; @@ -60,7 +51,7 @@ fun reduce_tree SEQ_fun_spec (Symb_Node (symbex_A_thm, [])) = symbex_A_thm end; - +(* TODO: move this function somewhere else (stepLib,execLib,composeLib) *) (* val SUBST_thm = birs_rule_SUBST_thm; val STEP_SEQ_thm = birs_rule_STEP_SEQ_thm; @@ -87,6 +78,35 @@ fun birs_rule_STEP_SEQ_fun STEP_SEQ_thm symbex_A_thm = end; val birs_rule_STEP_SEQ_fun = fn x => Profile.profile "birs_rule_STEP_SEQ_fun" (birs_rule_STEP_SEQ_fun x); +fun not_stop_lbl stop_lbls st = + not (List.exists (identical (birs_get_pc st)) stop_lbls); + + + fun take_step exec_funs st = + let + (*val _ = print ("Executing one more step @(" ^ (term_to_string (birs_get_pc st)) ^ ")\n");*) + val (fetch, _, step, _) = exec_funs; + in + case fetch st of + SOME x => (print "fetched a theorem\n"; x) + | NONE => step st + end + handle ex => (print_term st; raise ex); + fun take_step_SING exec_funs contfun (st, thm) = + let + (*val _ = print ("START sequential composition with singleton mid_state set\n");*) + val (fetch, step_SING, _, _) = exec_funs; + fun fetch_w tm = + fetch tm + handle ex => (print_term tm; raise ex); + fun step_SING_w t = + step_SING t + handle ex => (print_thm t; raise ex); + in + case fetch_w st of + SOME x => (print "fetched a theorem\n"; Symb_Node (thm, [contfun x])) + | NONE => contfun (step_SING_w thm) + end; (* val STEP_fun_spec = birs_rule_STEP_fun_spec; @@ -96,87 +116,63 @@ val STEP_SEQ_fun_spec = birs_rule_STEP_SEQ_fun_spec; val symbex_A_thm = single_step_A_thm; val stop_lbls = birs_stop_lbls; *) -fun build_tree (STEP_fun_spec, SEQ_fun_spec, STEP_SEQ_fun_spec) symbex_A_thm stop_lbls = +(* PROCESS: give first thm, filter Pi with stop function, first try fetch for all Pi, + if something is left and it is the only state in Pi overall just step with SING_Pi, + otherwise go over the rest with step from term + NOTE: function is not end-recursive (this is to avoid needing to apply the expensive composition right away; and to reiterate the tree)! *) +fun build_tree_rec exec_funs thm = let val _ = print ("\n"); - val (_, _, Pi_A_tm) = (symb_sound_struct_get_sysLPi_fun o concl) symbex_A_thm; + val (_, _, Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) thm; + val (_, _, _, is_continue) = exec_funs; fun is_executable st = - birs_is_running st andalso (not (List.exists (identical (birs_get_pc st)) stop_lbls)); + birs_is_running st andalso + is_continue st; - val birs_states_mid = symb_sound_struct_Pi_to_birstatelist_fun Pi_A_tm; + val sts = symb_sound_struct_Pi_to_birstatelist_fun Pi_tm; + val sts_exec = List.filter is_executable sts; (* - val birs_states_mid_running = List.filter birs_is_running birs_states_mid; - *) - val birs_states_mid_executable = List.filter is_executable birs_states_mid; - (* - val _ = print ("- have " ^ (Int.toString (length birs_states_mid)) ^ " states\n"); - val _ = print (" (" ^ (Int.toString (length birs_states_mid_running)) ^ " running)\n"); - val _ = print (" (" ^ (Int.toString (length birs_states_mid_executable)) ^ " executable)\n"); + val _ = print ("- have " ^ (Int.toString (length sts)) ^ " states\n"); + val _ = print (" (" ^ (Int.toString (length sts_exec)) ^ " executable)\n"); *) - fun take_step birs_state_mid = - let - val _ = print ("Executing one more step @(" ^ (term_to_string (birs_get_pc birs_state_mid)) ^ ")\n"); - val single_step_B_thm = STEP_fun_spec birs_state_mid; - in - single_step_B_thm - end - handle ex => (print_term birs_state_mid; raise ex); in (* stop condition (no more running states, or reached the stop_lbls) *) - if List.length birs_states_mid_executable = 0 then + if List.null sts_exec then (print "no executable states left, terminating here\n"; - (Symb_Node (symbex_A_thm,[]))) + (Symb_Node (thm,[]))) else (* safety check *) - if List.length birs_states_mid < 1 then - raise Fail "build_tree_until_branch::this can't happen" + if List.null sts then + raise ERR "build_tree_rec" "this can't happen" (* carry out a sequential composition with singleton mid_state set *) - else if List.length birs_states_mid = 1 then - let - - val _ = print ("START sequential composition with singleton mid_state set\n"); - - (* - val birs_state_mid = hd birs_states_mid; - val timer_exec_step_P1 = holba_miscLib.timer_start 0; - val single_step_B_thm = take_step birs_state_mid; - val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n>>> executed a whole step in " ^ delta_s ^ "\n")) timer_exec_step_P1; - *) - val timer_exec_step_P2 = holba_miscLib.timer_start 0; - val bprog_composed_thm = STEP_SEQ_fun_spec symbex_A_thm; - val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n>>> FINISH took and sequentially composed a step in " ^ delta_s ^ "\n")) timer_exec_step_P2; - - in - build_tree (STEP_fun_spec, SEQ_fun_spec, STEP_SEQ_fun_spec) bprog_composed_thm stop_lbls - end + else if List.length sts = 1 then + take_step_SING exec_funs (build_tree_rec exec_funs) (hd sts, thm) (* continue with executing one step on each branch point... *) else let val _ = print ("continuing only with the executable states\n"); - (* - val birs_state_mid = hd birs_states_mid_executable; - *) - fun buildsubtree birs_state_mid = - let - val _ = print ("starting a branch\n"); - val single_step_B_thm = take_step birs_state_mid; - in - build_tree (STEP_fun_spec, SEQ_fun_spec, STEP_SEQ_fun_spec) single_step_B_thm stop_lbls - end + fun buildsubtree st = + (print ("starting a branch\n"); + build_tree_rec exec_funs (take_step exec_funs st)); in - Symb_Node (symbex_A_thm, List.map buildsubtree birs_states_mid_executable) + Symb_Node (thm, List.map buildsubtree sts_exec) end end; -fun exec_until (STEP_fun_spec, SEQ_fun_spec, STEP_SEQ_fun_spec) symbex_A_thm stop_lbls = +fun build_tree exec_funs st = let - val tree = Profile.profile "build_tree" (build_tree (STEP_fun_spec, SEQ_fun_spec, STEP_SEQ_fun_spec) symbex_A_thm) stop_lbls; + val _ = if birs_state_is_normform_gen false st then () else + raise ERR "build_tree" "state is not in standard form with birs_gen_env"; in - Profile.profile "reduce_tree" (reduce_tree SEQ_fun_spec) tree + build_tree_rec exec_funs (take_step exec_funs st) end; +fun exec_until exec_funs comp_fun = + (Profile.profile "reduce_tree" (reduce_tree comp_fun)) o + (Profile.profile "build_tree" (build_tree exec_funs)); + fun bir_symb_exec_to (bprog_tm, birs_post_step_fun) birs_end_lbls birs_state = let val _ = if birs_state_is_normform_gen false birs_state then () else @@ -184,14 +180,13 @@ fun bir_symb_exec_to (bprog_tm, birs_post_step_fun) birs_end_lbls birs_state = open birs_execLib; - val birs_rule_STEP_thm = birs_rule_STEP_prog_fun (bir_prog_has_no_halt_fun bprog_tm); + val birs_rule_STEP_thm = birs_rule_STEP_prog_fun (Profile.profile "bir_prog_has_no_halt_fun" bir_prog_has_no_halt_fun bprog_tm); val birs_rule_STEP_fun_spec = (birs_post_step_fun o birs_rule_STEP_fun birs_rule_STEP_thm); (* now the composition *) val birs_rule_SEQ_thm = birs_rule_SEQ_prog_fun bprog_tm; val birs_rule_SEQ_fun_spec = birs_rule_SEQ_fun birs_rule_SEQ_thm; - val single_step_A_thm = birs_rule_STEP_fun_spec birs_state; (*val _ = print_thm single_step_A_thm;*) (* and also the sequential composition *) val birs_rule_STEP_SEQ_thm = MATCH_MP @@ -200,12 +195,18 @@ fun bir_symb_exec_to (bprog_tm, birs_post_step_fun) birs_end_lbls birs_state = val birs_rule_STEP_SEQ_fun_spec = (birs_post_step_fun o birs_rule_STEP_SEQ_fun birs_rule_STEP_SEQ_thm); + + val fetch = fn _ => NONE; + (*val fetch = fn _ => SOME TRUTH;*) + (*val fetch = fn x => SOME (birs_rule_STEP_fun_spec x);*) + val is_continue = not_stop_lbl birs_end_lbls; val _ = print "now reducing it to one sound structure\n"; val timer = holba_miscLib.timer_start 0; val result = exec_until - (birs_rule_STEP_fun_spec, birs_rule_SEQ_fun_spec, birs_rule_STEP_SEQ_fun_spec) - single_step_A_thm birs_end_lbls + (fetch, birs_rule_STEP_SEQ_fun_spec, birs_rule_STEP_fun_spec, is_continue) + birs_rule_SEQ_fun_spec + birs_state handle e => (Profile.print_profile_results (Profile.results ()); raise e); val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n======\n > exec_until took " ^ delta_s ^ "\n")) timer; @@ -219,6 +220,7 @@ fun bir_symb_exec_to (bprog_tm, birs_post_step_fun) birs_end_lbls birs_state = in result end; +val bir_symb_exec_to = fn x => fn y => Profile.profile "bir_symb_exec_to" (bir_symb_exec_to x y); end (* local *) From 83dd54c16f32ca5bbce2d794b3954d7fff7042f7 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Fri, 18 Oct 2024 00:20:05 +0200 Subject: [PATCH 80/95] Refactoring cleanup --- src/tools/symbexec/birsSyntax.sml | 15 +- src/tools/symbexec/birs_driveLib.sml | 312 ++++++++----------- src/tools/symbexec/birs_execLib.sml | 428 +++++++++------------------ src/tools/symbexec/birs_simpLib.sml | 41 +-- src/tools/symbexec/birs_utilsLib.sml | 58 +++- 5 files changed, 342 insertions(+), 512 deletions(-) diff --git a/src/tools/symbexec/birsSyntax.sml b/src/tools/symbexec/birsSyntax.sml index 75bd89c2e..a68aa6264 100644 --- a/src/tools/symbexec/birsSyntax.sml +++ b/src/tools/symbexec/birsSyntax.sml @@ -56,6 +56,7 @@ end; local open birs_rulesTheory; fun syntax_fns n d m = HolKernel.syntax_fns {n = n, dest = d, make = m} "birs_rules" + val syntax_fns1 = syntax_fns 1 HolKernel.dest_monop HolKernel.mk_monop; val syntax_fns2 = syntax_fns 2 HolKernel.dest_binop HolKernel.mk_binop; val syntax_fns1_set = syntax_fns 2 HolKernel.dest_monop HolKernel.mk_monop; val syntax_fns2_set = syntax_fns 3 HolKernel.dest_binop HolKernel.mk_binop; @@ -63,6 +64,7 @@ in val (birs_symb_exec_tm, mk_birs_symb_exec, dest_birs_symb_exec, is_birs_symb_exec) = syntax_fns2 "birs_symb_exec"; val (birs_symb_symbols_set_tm, mk_birs_symb_symbols_set, dest_birs_symb_symbols_set, is_birs_symb_symbols_set) = syntax_fns1_set "birs_symb_symbols_set"; val (birs_freesymbs_tm, mk_birs_freesymbs, dest_birs_freesymbs, is_birs_freesymbs) = syntax_fns2_set "birs_freesymbs"; + val (birs_pcondinf_tm, mk_birs_pcondinf, dest_birs_pcondinf, is_birs_pcondinf) = syntax_fns1 "birs_pcondinf"; end; local @@ -114,6 +116,17 @@ in TypeBase.mk_record (birs_state_t_ty, l) end handle e => raise wrap_exn "mk_birs_state" e; + val dest_birs_state_pc = + ((fn (x,_,_,_) => x) o dest_birs_state); + val dest_birs_state_env = + ((fn (_,x,_,_) => x) o dest_birs_state); + val dest_birs_state_status = + ((fn (_,_,x,_) => x) o dest_birs_state); + val dest_birs_state_pcond = + ((fn (_,_,_,x) => x) o dest_birs_state); + +val birs_state_is_running = identical bir_programSyntax.BST_Running_tm o dest_birs_state_status; + (* val (_tm, mk_, dest_, is_) = syntax_fns2_set "";*) end @@ -184,7 +197,7 @@ fun dest_IMAGE_birs_symb_to_symbst Pi = fun is_normform_bir_senv_GEN_list env = is_bir_senv_GEN_list env; - val (_, env, _, _) = dest_birs_state tm; + val env = dest_birs_state_env tm; in is_normform_birs_gen_env env orelse if not is_start then false else diff --git a/src/tools/symbexec/birs_driveLib.sml b/src/tools/symbexec/birs_driveLib.sml index f519c20af..05ce52baa 100644 --- a/src/tools/symbexec/birs_driveLib.sml +++ b/src/tools/symbexec/birs_driveLib.sml @@ -3,12 +3,10 @@ struct local -open HolKernel Parse boolLib bossLib; + open HolKernel Parse boolLib bossLib; -open birsSyntax; -open birs_stepLib; -open birs_composeLib; -open birs_auxTheory; + open birsSyntax; + open birs_composeLib; (* error handling *) val libname = "birs_driveLib" @@ -17,74 +15,28 @@ open birs_auxTheory; in (* local *) -(* TODO: move to syntax, move something else from syntax to utils *) -fun birs_get_pc tm = - let - val (pc, _, _, _) = dest_birs_state tm; - in - pc - end; -fun birs_is_running tm = - let - val (_, _, status, _) = dest_birs_state tm; - in - identical status bir_programSyntax.BST_Running_tm - end; - -datatype symbexec_tree_t = - Symb_Node of (thm * (symbexec_tree_t list)); - -fun reduce_tree SEQ_fun_spec (Symb_Node (symbex_A_thm, [])) = symbex_A_thm - | reduce_tree SEQ_fun_spec (Symb_Node (symbex_A_thm, (symbex_B_subtree::symbex_B_subtrees))) = - let - val symbex_B_thm = reduce_tree SEQ_fun_spec symbex_B_subtree; - val symbex_A_thm_new = SEQ_fun_spec symbex_A_thm symbex_B_thm - handle ex => - (print "\n=========================\n\n"; - (print_term o concl) symbex_A_thm; - print "\n\n"; - (print_term o concl) symbex_B_thm; - print "\n\n=========================\n"; - raise ex); - in - reduce_tree SEQ_fun_spec (Symb_Node (symbex_A_thm_new, symbex_B_subtrees)) - end; - - -(* TODO: move this function somewhere else (stepLib,execLib,composeLib) *) -(* -val SUBST_thm = birs_rule_SUBST_thm; -val STEP_SEQ_thm = birs_rule_STEP_SEQ_thm; -val symbex_A_thm = single_step_A_thm; -*) -fun birs_rule_STEP_SEQ_fun STEP_SEQ_thm symbex_A_thm = - let - val step1_thm = MATCH_MP STEP_SEQ_thm symbex_A_thm; - val step2_thm = REWRITE_RULE [bir_symbTheory.birs_state_t_accessors, bir_symbTheory.birs_state_t_accfupds, combinTheory.K_THM] step1_thm; - - (* - val timer_exec_step_p3 = holba_miscLib.timer_start 0; - *) - - val (step3_conv_thm, extra_info) = birs_exec_step_CONV_fun (concl step2_thm); - val step3_thm = EQ_MP step3_conv_thm step2_thm; - - (* - val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n>>>>>> STEP_SEQ in " ^ delta_s ^ "\n")) timer_exec_step_p3; - *) - val step4_thm = (* (birs_rule_SUBST_trysimp_fun SUBST_thm o birs_rule_tryjustassert_fun true) *) step3_thm; - in - (step4_thm, extra_info) - end; -val birs_rule_STEP_SEQ_fun = fn x => Profile.profile "birs_rule_STEP_SEQ_fun" (birs_rule_STEP_SEQ_fun x); - -fun not_stop_lbl stop_lbls st = - not (List.exists (identical (birs_get_pc st)) stop_lbls); + datatype symbexec_tree_t = + Symb_Node of (thm * (symbexec_tree_t list)); + fun reduce_tree SEQ_fun_spec (Symb_Node (symbex_A_thm, [])) = symbex_A_thm + | reduce_tree SEQ_fun_spec (Symb_Node (symbex_A_thm, (symbex_B_subtree::symbex_B_subtrees))) = + let + val symbex_B_thm = reduce_tree SEQ_fun_spec symbex_B_subtree; + val symbex_A_thm_new = SEQ_fun_spec symbex_A_thm symbex_B_thm + handle ex => + (print "\n=========================\n\n"; + (print_term o concl) symbex_A_thm; + print "\n\n"; + (print_term o concl) symbex_B_thm; + print "\n\n=========================\n"; + raise ex); + in + reduce_tree SEQ_fun_spec (Symb_Node (symbex_A_thm_new, symbex_B_subtrees)) + end; fun take_step exec_funs st = let - (*val _ = print ("Executing one more step @(" ^ (term_to_string (birs_get_pc st)) ^ ")\n");*) + (*val _ = print ("Executing one more step @(" ^ (term_to_string (dest_birs_state_pc st)) ^ ")\n");*) val (fetch, _, step, _) = exec_funs; in case fetch st of @@ -92,6 +44,7 @@ fun not_stop_lbl stop_lbls st = | NONE => step st end handle ex => (print_term st; raise ex); + fun take_step_SING exec_funs contfun (st, thm) = let (*val _ = print ("START sequential composition with singleton mid_state set\n");*) @@ -108,119 +61,116 @@ fun not_stop_lbl stop_lbls st = | NONE => contfun (step_SING_w thm) end; -(* -val STEP_fun_spec = birs_rule_STEP_fun_spec; -val SEQ_fun_spec = birs_rule_SEQ_fun_spec; -val STEP_SEQ_fun_spec = birs_rule_STEP_SEQ_fun_spec; - -val symbex_A_thm = single_step_A_thm; -val stop_lbls = birs_stop_lbls; -*) -(* PROCESS: give first thm, filter Pi with stop function, first try fetch for all Pi, - if something is left and it is the only state in Pi overall just step with SING_Pi, - otherwise go over the rest with step from term - NOTE: function is not end-recursive (this is to avoid needing to apply the expensive composition right away; and to reiterate the tree)! *) -fun build_tree_rec exec_funs thm = - let - val _ = print ("\n"); - val (_, _, Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) thm; - - val (_, _, _, is_continue) = exec_funs; - fun is_executable st = - birs_is_running st andalso - is_continue st; - - val sts = symb_sound_struct_Pi_to_birstatelist_fun Pi_tm; - val sts_exec = List.filter is_executable sts; - (* - val _ = print ("- have " ^ (Int.toString (length sts)) ^ " states\n"); - val _ = print (" (" ^ (Int.toString (length sts_exec)) ^ " executable)\n"); - *) - - in - (* stop condition (no more running states, or reached the stop_lbls) *) - if List.null sts_exec then - (print "no executable states left, terminating here\n"; - (Symb_Node (thm,[]))) - else - (* safety check *) - if List.null sts then - raise ERR "build_tree_rec" "this can't happen" - (* carry out a sequential composition with singleton mid_state set *) - else if List.length sts = 1 then - take_step_SING exec_funs (build_tree_rec exec_funs) (hd sts, thm) - (* continue with executing one step on each branch point... *) + (* PROCESS: give first thm, filter Pi with stop function, first try fetch for all Pi, + if something is left and it is the only state in Pi overall just step with SING_Pi, + otherwise go over the rest with step from term + NOTE: function is not end-recursive (this is to avoid needing to apply the expensive composition right away; and to reiterate the tree)! *) + fun build_tree_rec exec_funs thm = + let + val _ = print ("\n"); + val (_, _, Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) thm; + + val (_, _, _, is_continue) = exec_funs; + fun is_executable st = + birs_state_is_running st andalso + is_continue st; + + val sts = symb_sound_struct_Pi_to_birstatelist_fun Pi_tm; + val sts_exec = List.filter is_executable sts; + (* + val _ = print ("- have " ^ (Int.toString (length sts)) ^ " states\n"); + val _ = print (" (" ^ (Int.toString (length sts_exec)) ^ " executable)\n"); + *) + + in + (* stop condition (no more running states, or reached the stop_lbls) *) + if List.null sts_exec then + (print "no executable states left, terminating here\n"; + (Symb_Node (thm,[]))) else - let - val _ = print ("continuing only with the executable states\n"); - fun buildsubtree st = - (print ("starting a branch\n"); - build_tree_rec exec_funs (take_step exec_funs st)); - in - Symb_Node (thm, List.map buildsubtree sts_exec) - end - end; - -fun build_tree exec_funs st = - let - val _ = if birs_state_is_normform_gen false st then () else - raise ERR "build_tree" "state is not in standard form with birs_gen_env"; - in - build_tree_rec exec_funs (take_step exec_funs st) - end; - -fun exec_until exec_funs comp_fun = - (Profile.profile "reduce_tree" (reduce_tree comp_fun)) o - (Profile.profile "build_tree" (build_tree exec_funs)); - -fun bir_symb_exec_to (bprog_tm, birs_post_step_fun) birs_end_lbls birs_state = - let - val _ = if birs_state_is_normform_gen false birs_state then () else - raise ERR "bir_symb_exec_to" "state is not in standard form with birs_gen_env"; - - open birs_execLib; - - val birs_rule_STEP_thm = birs_rule_STEP_prog_fun (Profile.profile "bir_prog_has_no_halt_fun" bir_prog_has_no_halt_fun bprog_tm); - val birs_rule_STEP_fun_spec = - (birs_post_step_fun o - birs_rule_STEP_fun birs_rule_STEP_thm); - (* now the composition *) - val birs_rule_SEQ_thm = birs_rule_SEQ_prog_fun bprog_tm; - val birs_rule_SEQ_fun_spec = birs_rule_SEQ_fun birs_rule_SEQ_thm; - (*val _ = print_thm single_step_A_thm;*) - (* and also the sequential composition *) - val birs_rule_STEP_SEQ_thm = MATCH_MP - birs_rulesTheory.birs_rule_STEP_SEQ_gen_thm - (bir_prog_has_no_halt_fun bprog_tm); - val birs_rule_STEP_SEQ_fun_spec = - (birs_post_step_fun o - birs_rule_STEP_SEQ_fun birs_rule_STEP_SEQ_thm); - - val fetch = fn _ => NONE; - (*val fetch = fn _ => SOME TRUTH;*) - (*val fetch = fn x => SOME (birs_rule_STEP_fun_spec x);*) - val is_continue = not_stop_lbl birs_end_lbls; - - val _ = print "now reducing it to one sound structure\n"; - val timer = holba_miscLib.timer_start 0; - val result = exec_until - (fetch, birs_rule_STEP_SEQ_fun_spec, birs_rule_STEP_fun_spec, is_continue) - birs_rule_SEQ_fun_spec - birs_state - handle e => (Profile.print_profile_results (Profile.results ()); raise e); - val _ = holba_miscLib.timer_stop - (fn delta_s => print ("\n======\n > exec_until took " ^ delta_s ^ "\n")) timer; - - (* - Profile.reset_all () - Profile.print_profile_results (Profile.results ()) - Profile.output_profile_results (iostream) (Profile.results ()) - *) - val _ = Profile.print_profile_results (Profile.results ()); - in - result - end; -val bir_symb_exec_to = fn x => fn y => Profile.profile "bir_symb_exec_to" (bir_symb_exec_to x y); + (* safety check *) + if List.null sts then + raise ERR "build_tree_rec" "this can't happen" + (* carry out a sequential composition with singleton mid_state set *) + else if List.length sts = 1 then + take_step_SING exec_funs (build_tree_rec exec_funs) (hd sts, thm) + (* continue with executing one step on each branch point... *) + else + let + val _ = print ("continuing only with the executable states\n"); + fun buildsubtree st = + (print ("starting a branch\n"); + build_tree_rec exec_funs (take_step exec_funs st)); + in + Symb_Node (thm, List.map buildsubtree sts_exec) + end + end; + + fun build_tree exec_funs st = + let + val _ = if birs_state_is_normform_gen false st then () else + raise ERR "build_tree" "state is not in standard form with birs_gen_env"; + in + build_tree_rec exec_funs (take_step exec_funs st) + end; + + fun exec_until exec_funs comp_fun = + (Profile.profile "reduce_tree" (reduce_tree comp_fun)) o + (Profile.profile "build_tree" (build_tree exec_funs)); + + (* ----------------------------------------------------------------------------- *) + + fun not_stop_lbl stop_lbls st = + not (List.exists (identical (dest_birs_state_pc st)) stop_lbls); + + fun bir_symb_exec_to (bprog_tm, birs_post_step_fun) birs_end_lbls birs_state = + let + val _ = if birs_state_is_normform_gen false birs_state then () else + raise ERR "bir_symb_exec_to" "state is not in standard form with birs_gen_env"; + + open birs_execLib; + + val birs_rule_STEP_thm = birs_rule_STEP_prog_fun (Profile.profile "bir_prog_has_no_halt_fun" bir_prog_has_no_halt_fun bprog_tm); + val birs_rule_STEP_fun_spec = + (birs_post_step_fun o + birs_rule_STEP_fun birs_rule_STEP_thm); + (* now the composition *) + val birs_rule_SEQ_thm = birs_rule_SEQ_prog_fun bprog_tm; + val birs_rule_SEQ_fun_spec = birs_rule_SEQ_fun birs_rule_SEQ_thm; + (*val _ = print_thm single_step_A_thm;*) + (* and also the sequential composition *) + val birs_rule_STEP_SEQ_thm = MATCH_MP + birs_rulesTheory.birs_rule_STEP_SEQ_gen_thm + (bir_prog_has_no_halt_fun bprog_tm); + val birs_rule_STEP_SEQ_fun_spec = + (birs_post_step_fun o + birs_rule_STEP_SEQ_fun birs_rule_STEP_SEQ_thm); + + val fetch = fn _ => NONE; + (*val fetch = fn _ => SOME TRUTH;*) + (*val fetch = fn x => SOME (birs_rule_STEP_fun_spec x);*) + val is_continue = not_stop_lbl birs_end_lbls; + + val _ = print "now reducing it to one sound structure\n"; + val timer = holba_miscLib.timer_start 0; + val result = exec_until + (fetch, birs_rule_STEP_SEQ_fun_spec, birs_rule_STEP_fun_spec, is_continue) + birs_rule_SEQ_fun_spec + birs_state + handle e => (Profile.print_profile_results (Profile.results ()); raise e); + val _ = holba_miscLib.timer_stop + (fn delta_s => print ("\n======\n > exec_until took " ^ delta_s ^ "\n")) timer; + + (* + Profile.reset_all () + Profile.print_profile_results (Profile.results ()) + Profile.output_profile_results (iostream) (Profile.results ()) + *) + val _ = Profile.print_profile_results (Profile.results ()); + in + result + end; + val bir_symb_exec_to = fn x => fn y => Profile.profile "bir_symb_exec_to" (bir_symb_exec_to x y); end (* local *) diff --git a/src/tools/symbexec/birs_execLib.sml b/src/tools/symbexec/birs_execLib.sml index 979f5f679..c1f5ab908 100644 --- a/src/tools/symbexec/birs_execLib.sml +++ b/src/tools/symbexec/birs_execLib.sml @@ -5,9 +5,9 @@ local open HolKernel Parse boolLib bossLib; open birsSyntax; + open birs_utilsLib; open birs_stepLib; - (* error handling *) val libname = "bir_execLib" val ERR = Feedback.mk_HOL_ERR libname @@ -15,300 +15,128 @@ local in + (* halt free programs *) + (* ----------------------------------------------- *) + fun bir_prog_has_no_halt_fun bprog_tm = + prove(``bir_prog_has_no_halt ^bprog_tm``, EVAL_TAC); -(* halt free programs *) -(* ----------------------------------------------- *) -(* -val bprog_tm = bprog; -*) -fun bir_prog_has_no_halt_fun bprog_tm = - let - (* prep step rule to be used *) - (* - val bir_prog_has_no_halt_prog_thm = store_thm( - "bir_prog_has_no_halt_prog_thm", *) - val bir_prog_has_no_halt_prog_thm = prove(`` - bir_prog_has_no_halt ^bprog_tm - ``, - EVAL_TAC - ); - in - bir_prog_has_no_halt_prog_thm - end; + fun birs_rule_STEP_prog_fun no_halt_thm = + MATCH_MP birs_rulesTheory.birs_rule_STEP_gen2_thm no_halt_thm; -(* -val bprog_tm = bprog; -val no_halt_thm = (bir_prog_has_no_halt_fun bprog_tm) -*) -fun birs_rule_STEP_prog_fun no_halt_thm = - let - val prep_thm = - MATCH_MP birs_rulesTheory.birs_rule_STEP_gen2_thm no_halt_thm; -(* - val _ = (print_term o concl) prep_thm; -*) - in - prep_thm - end; - -(* plugging in the execution of steps to obtain sound structure *) -(* ----------------------------------------------- *) -local - open birs_auxTheory; -in -fun birs_rule_STEP_fun birs_rule_STEP_thm bstate_tm = - let - val step1_thm = SPEC bstate_tm birs_rule_STEP_thm; - val (step2_thm, extra_info) = birs_exec_step_CONV_fun (concl step1_thm); - val birs_exec_thm = EQ_MP step2_thm step1_thm; + (* plugging in the execution of steps to obtain sound structure *) + (* ----------------------------------------------- *) + local + open birs_auxTheory; - val timer_exec_step_p3 = holba_miscLib.timer_start 0; - (* TODO: optimize *) - val single_step_prog_thm = + val exec_step_postproc_fun = REWRITE_RULE - [bir_symbTheory.recordtype_birs_state_t_seldef_bsst_pc_def, - bir_symbTheory.birs_state_t_accfupds, combinTheory.K_THM] - birs_exec_thm; - - val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n>>>>>> STEP in " ^ delta_s ^ "\n")) timer_exec_step_p3; - - (*val _ = print_thm single_step_prog_thm;*) - val _ = if symb_sound_struct_is_normform (concl single_step_prog_thm) then () else - (print_term (concl single_step_prog_thm); - raise ERR "birs_rule_STEP_fun" "something is not right, the produced theorem is not evaluated enough"); + [bir_symbTheory.recordtype_birs_state_t_seldef_bsst_pc_def, + (*bir_symbTheory.birs_state_t_accessors,*) + bir_symbTheory.birs_state_t_accfupds, combinTheory.K_THM]; in - (single_step_prog_thm, extra_info) - end; -end; -val birs_rule_STEP_fun = fn x => Profile.profile "birs_rule_STEP_fun" (birs_rule_STEP_fun x); - - - -(* TODO: justify the second branch of assert is infeasible (need precondition for this) *) -(* TODO: simplify path condition in poststate to get rid of the implied and not accumulate it *) -(* TODO: clean up environment after assignment to not accumulate useless mappings *) -(* TODO: maybe have a specialized assert/assignment step function? (optimization to detect this situation directly, maybe better as separate function?) *) - -(* -val pcond_tm = `` - BExp_BinExp BIExp_And - (BExp_BinPred BIExp_LessOrEqual - (BExp_Den (BVar "countw" (BType_Imm Bit64))) - (BExp_Const (Imm64 0xFFFFFFFFFFFFFF00w))) - (BExp_UnaryExp BIExp_Not - (BExp_BinPred BIExp_LessOrEqual - (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) - (BExp_Const (Imm64 0xFFFFFFFFFFFFFFFEw)))) -``; -*) - -(* stepping a sound structure, try to justify assert *) -(* ----------------------------------------------- *) -(* -val bstate_tm = birs_state_init_tm; -*) -local - open birs_auxTheory; - - open birs_rulesTheory; - - open bir_smtLib; - - fun justify_assumption_EVAL t = - if (not o is_imp o concl) t then - raise ERR "justify_assumption_EVAL" "not an implication" - else + fun birs_rule_STEP_fun birs_rule_STEP_thm bstate_tm = let - val assmpt = (fst o dest_imp o concl) t; - val assmpt_thm = (EVAL) assmpt; - - val assmpt_new = (snd o dest_eq o concl) assmpt_thm; + val step1_thm = SPEC bstate_tm birs_rule_STEP_thm; + val (step2_thm, extra_info) = birs_exec_step_CONV_fun (concl step1_thm); + val birs_exec_thm = EQ_MP step2_thm step1_thm; - (* raise exception when the assumption turns out to be false *) - val _ = if not (identical assmpt_new F) then () else - raise ERR "justify_assumption_EVAL" "assumption does not hold"; + val single_step_prog_thm = Profile.profile "birs_rule_STEP_fun_overhead" exec_step_postproc_fun birs_exec_thm; - val _ = if identical assmpt_new T then () else - raise ERR "justify_assumption_EVAL" ("failed to fix the assumption: " ^ (term_to_string assmpt)); + (*val _ = print_thm single_step_prog_thm;*) + val _ = if symb_sound_struct_is_normform (concl single_step_prog_thm) then () else + (print_term (concl single_step_prog_thm); + raise ERR "birs_rule_STEP_fun" "something is not right, the produced theorem is not evaluated enough"); in - (REWRITE_RULE [assmpt_thm] t) + (single_step_prog_thm, extra_info) end; + val birs_rule_STEP_fun = fn x => Profile.profile "birs_rule_STEP_fun" (birs_rule_STEP_fun x); - val birs_pcondinf_tm = ``birs_pcondinf``; -in -fun birs_rule_tryjustassert_fun force_assert_justify single_step_prog_thm = - let - (* - val single_step_prog_thm = birs_rule_STEP_fun birs_rule_STEP_thm bprog_tm bstate_tm; - *) - val continue_thm_o_1 = - SOME (MATCH_MP assert_spec_thm single_step_prog_thm) - handle _ => NONE; - val continue_thm_o_2 = - Option.map (justify_assumption_EVAL) continue_thm_o_1 - handle _ => NONE; - in - (* val SOME continue_thm = continue_thm_o; *) - case continue_thm_o_2 of - SOME continue_thm => - let - val timer_exec_step_p3 = holba_miscLib.timer_start 0; - val pcond_tm = (snd o dest_comb o snd o dest_comb o fst o dest_comb o concl) continue_thm; - (*val _ = print_term pcond_tm;*) - val pcond_is_contr = bir_smt_check_unsat false pcond_tm; - val _ = if (not force_assert_justify) orelse pcond_is_contr then () else - (print "\n\n\n<<<<<<<<<<<< ASSERTION MAY FAIL <<<<<<<<<<<< \n"; - print_term (concl single_step_prog_thm); - print ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>\n\n"; - raise ERR "birs_rule_tryjustassert_fun" "can't prove assertion to hold"); - val pcond_thm_o = - if pcond_is_contr then - SOME (mk_oracle_thm "BIRS_CONTR_Z3" ([], mk_comb (birs_pcondinf_tm, pcond_tm))) - else - NONE; - val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n>>>>>> tryassert in " ^ delta_s ^ "\n")) timer_exec_step_p3; - in - (* val SOME pcond_thm = pcond_thm_o; *) - case pcond_thm_o of - SOME pcond_thm => MP continue_thm pcond_thm - | _ => single_step_prog_thm - end - | _ => single_step_prog_thm - end; -val birs_rule_tryjustassert_fun = fn x => Profile.profile "birs_rule_tryjustassert_fun" (birs_rule_tryjustassert_fun x); - -fun birs_rule_tryprune_fun prune_thm single_step_prog_thm = - let - (* val _ = print "try prune now \n"; *) - val continue_thm_o_1 = - SOME (MATCH_MP prune_thm single_step_prog_thm) - handle _ => NONE; - val continue_thm_o_2 = - Option.map (fn t => (print "going into pruning\n"; (*print_thm t; *)justify_assumption_EVAL t)) continue_thm_o_1 - handle _ => NONE; - in - case continue_thm_o_2 of - SOME continue_thm => - let - val timer_exec_step_p3 = holba_miscLib.timer_start 0; - val pcond_tm = (snd o dest_comb o snd o dest_comb o fst o dest_comb o concl) continue_thm; - (* val _ = print_term pcond_tm; *) - val pcond_is_contr = bir_smt_check_unsat false pcond_tm; - val _ = if pcond_is_contr then print "can prune" else (); - val pcond_thm_o = - if pcond_is_contr then - SOME (mk_oracle_thm "BIRS_CONTR_Z3" ([], mk_comb (birs_pcondinf_tm, pcond_tm))) - else - NONE; - val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n>>>>>> tryprune2 in " ^ delta_s ^ "\n")) timer_exec_step_p3; - in - case pcond_thm_o of - SOME pcond_thm => - let - val res = MP continue_thm pcond_thm; - val _ = print "pruning finished\n"; - (*val _ = print_thm res;*) - in - res - end - | _ => single_step_prog_thm - end - | _ => single_step_prog_thm - end; -end; -val birs_rule_tryprune_fun = fn x => Profile.profile "birs_rule_tryprune_fun" (birs_rule_tryprune_fun x); - - -(* stepping a sound structure, try to simplify after assignment *) -(* ----------------------------------------------- *) -(* first prepare the SUBST rule for prog *) -fun birs_rule_SUBST_prog_fun bprog_tm = - let - open birs_rulesTheory; - val prog_type = (hd o snd o dest_type o type_of) bprog_tm; - (* - val symbols_f_sound_thm = INST_TYPE [Type.alpha |-> prog_type] bir_symb_soundTheory.birs_symb_symbols_f_sound_thm; - val birs_symb_symbols_f_sound_prog_thm = - (SPEC (bprog_tm) symbols_f_sound_thm); - val ARB_val_sound_thm = INST_TYPE [Type.alpha |-> prog_type] bir_symb_soundTheory.birs_symb_ARB_val_sound_thm; - val birs_symb_ARB_val_sound_prog_thm = - (SPEC (bprog_tm) ARB_val_sound_thm); - - val prep_thm = - MATCH_MP - (MATCH_MP symb_rule_SUBST_SING_thm birs_symb_symbols_f_sound_prog_thm) - birs_symb_ARB_val_sound_prog_thm; - - val inst_thm = prove(`` - !sys L lbl envl status pcond vn symbexp symbexp'. - symb_hl_step_in_L_sound (bir_symb_rec_sbir ^bprog_tm) (sys,L,IMAGE birs_symb_to_symbst { - <|bsst_pc := lbl; - bsst_environ := birs_gen_env ((vn, symbexp)::envl); - bsst_status := status; - bsst_pcond := pcond|>}) ==> - birs_simplification pcond symbexp symbexp' ==> - symb_hl_step_in_L_sound (bir_symb_rec_sbir ^bprog_tm) (sys,L,IMAGE birs_symb_to_symbst { - <|bsst_pc := lbl; - bsst_environ := birs_gen_env ((vn, symbexp')::envl); - bsst_status := status; - bsst_pcond := pcond|>}) - ``, - cheat (* TODO: connect this with prep_thm from above *) - );*) - val inst_thm1 = SIMP_RULE std_ss [] ((SPEC bprog_tm o INST_TYPE [Type.alpha |-> prog_type]) birs_rule_SUBST_thm); - val inst_thm2 = SIMP_RULE std_ss [] ((SPEC bprog_tm o INST_TYPE [Type.alpha |-> prog_type]) birs_rule_SUBST_spec_thm); - (*val _ = (print_term o concl) inst_thm;*) - in - (inst_thm1,inst_thm2) - end; - - -(* -val thm = result; -*) -fun birs_rule_SUBST_trysimp_SING_fun (_,birs_rule_SUBST_thm) birs_simp_fun thm = - let - val assignment_thm_o = - SOME (MATCH_MP birs_rule_SUBST_thm thm) - handle _ => NONE; - - val simp_t_o = Option.mapPartial (fn assignment_thm => + (* optimization: take steps if Pi is a singleton set, + this way we save to compute free symbols and operate on + Pi sets over and over for the non-branching sequences *) + (* ----------------------------------------------- *) + fun birs_rule_STEP_SEQ_fun STEP_SEQ_thm symbex_A_thm = let - val simp_tm = (fst o dest_imp o (*snd o strip_binder (SOME boolSyntax.universal) o*) concl o Q.SPEC `symbexp'`) assignment_thm; - (*val _ = print_term simp_tm;*) - val timer_exec_step_p3 = holba_miscLib.timer_start 0; - val simp_t = birs_simp_fun simp_tm; - (* TODO: need to remove the following line later and enable the simp function above *) - (*val simp_t_o = NONE;*) - val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n>>>>>> SUBST in " ^ delta_s ^ "\n")) timer_exec_step_p3; - in - SOME (simp_t, assignment_thm) - end) assignment_thm_o; - in - case simp_t_o of - SOME (simp_t, assignment_thm) => MATCH_MP assignment_thm simp_t - | NONE => thm - end; -val birs_rule_SUBST_trysimp_SING_fun = fn x => Profile.profile "birs_rule_SUBST_trysimp_SING_fun" (birs_rule_SUBST_trysimp_SING_fun x); - -fun birs_rule_SUBST_trysimp_first_fun (birs_rule_SUBST_thm,_) birs_simp_fun thm = - let - val assignment_thm_o = - SOME (MATCH_MP birs_rule_SUBST_thm thm) - handle _ => NONE; + val step1_thm = MATCH_MP STEP_SEQ_thm symbex_A_thm; + val step2_thm = Profile.profile "birs_rule_STEP_SEQ_fun_overhead" exec_step_postproc_fun step1_thm; - val simp_t_o = Option.mapPartial (fn assignment_thm => - let - val simp_tm = (fst o dest_imp o (*snd o strip_binder (SOME boolSyntax.universal) o*) concl o Q.SPEC `symbexp'`) assignment_thm; - (*val _ = print_term simp_tm;*) - val timer_exec_step_p3 = holba_miscLib.timer_start 0; - val simp_t = birs_simp_fun simp_tm; - (* TODO: need to remove the following line later and enable the simp function above *) - (*val simp_t_o = NONE;*) - val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n>>>>>> SUBST in " ^ delta_s ^ "\n")) timer_exec_step_p3; + val (step3_conv_thm, extra_info) = birs_exec_step_CONV_fun (concl step2_thm); + val step3_thm = EQ_MP step3_conv_thm step2_thm; in - SOME (simp_t, assignment_thm) - end) assignment_thm_o; + (step3_thm, extra_info) + end; + val birs_rule_STEP_SEQ_fun = fn x => Profile.profile "birs_rule_STEP_SEQ_fun" (birs_rule_STEP_SEQ_fun x); + end + + (* ============================================================================ *) + + (* try to prune, or remove assert branching and the associated pathcondition blowup *) + (* ----------------------------------------------- *) + fun birs_try_prune opstring failaction prune_thm single_step_prog_thm = + let + val continue_thm_o_1 = + SOME (MATCH_MP prune_thm single_step_prog_thm) + handle _ => NONE; + val continue_thm_o_2 = + Option.mapPartial (prove_assumptions false EVAL) continue_thm_o_1 + handle _ => NONE; + in + case continue_thm_o_2 of + SOME continue_thm => + let + val pcondinf_tm = (fst o dest_imp o concl) continue_thm; + val timer_exec_step_p3 = holba_miscLib.timer_start 0; + val pcond_thm_o = check_pcondinf_tm pcondinf_tm; + val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n>>>>>> " ^ opstring ^ " in " ^ delta_s ^ "\n")) timer_exec_step_p3; + (* val _ = print_term pcondinf_tm; *) + val pcond_is_contr = isSome pcond_thm_o; + val _ = if (not (isSome failaction)) orelse pcond_is_contr then () else + (valOf failaction) (); + in + case pcond_thm_o of + SOME pcond_thm => MP continue_thm pcond_thm + | _ => single_step_prog_thm + end + | _ => single_step_prog_thm + end; + + fun birs_rule_tryjustassert_fun force thm = + birs_try_prune + "tryassert" + (if force then + SOME (fn () => ( + print "\n\n\n<<<<<<<<<<<< ASSERTION MAY FAIL <<<<<<<<<<<< \n"; + print_thm thm; + print ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>\n\n"; + raise ERR "birs_rule_tryjustassert_fun" "can't prove assertion to hold")) + else + NONE) + birs_rulesTheory.assert_spec_thm + thm; + val birs_rule_tryjustassert_fun = fn x => Profile.profile "birs_rule_tryjustassert_fun" (birs_rule_tryjustassert_fun x); + + fun birs_rule_tryprune_fun prune_thm thm = + birs_try_prune "tryprune" NONE prune_thm thm; + val birs_rule_tryprune_fun = fn x => Profile.profile "birs_rule_tryprune_fun" (birs_rule_tryprune_fun x); + + (* ============================================================================ *) + + (* mapped environment expression simplifications (for example after assignments) + NOTE: it is faster to run the simplification function on theorems with singleton Pi + (because then there is no need to run set operations afterwards) *) + (* ----------------------------------------------- *) + (* first prepare the SUBST rule for prog *) + fun birs_rule_SUBST_prog_fun bprog_tm = + let + open birs_rulesTheory; + val inst_thm1 = SIMP_RULE std_ss [] (ISPEC bprog_tm birs_rule_SUBST_thm); + val inst_thm2 = SIMP_RULE std_ss [] (ISPEC bprog_tm birs_rule_SUBST_spec_thm); + in + (inst_thm1, inst_thm2) + end; + + local + val symbexp_prim_tm = ``symbexp':bir_exp_t``; (* Pi is "bs2' INSERT (Pi DELETE bs2)"*) val cleanup_Pi_conv = let @@ -317,16 +145,36 @@ fun birs_rule_SUBST_trysimp_first_fun (birs_rule_SUBST_thm,_) birs_simp_fun thm in RAND_CONV (DELETE_CONV birs_state_EQ_CONV) end; - val cleanup_RULE = CONV_RULE (birs_utilsLib.birs_Pi_CONV cleanup_Pi_conv); + val cleanup_RULE = CONV_RULE (birs_Pi_CONV cleanup_Pi_conv); + fun birs_rule_SUBST_trysimp_first_fun (SUBST_thm,SUBST_SING_thm) birs_simp_fun thm = + let + val is_sing = (get_birs_Pi_length o concl) thm = 1; + val birs_rule_SUBST_thm = if is_sing then SUBST_SING_thm else SUBST_thm; + val postproc = if is_sing then I else cleanup_RULE; + + val assignment_thm_o = + SOME (MATCH_MP birs_rule_SUBST_thm thm) + handle _ => NONE; + + val simp_t_o = Option.mapPartial (fn assignment_thm => + let + val simp_tm = (fst o dest_imp o concl o SPEC symbexp_prim_tm) assignment_thm; + (*val timer_exec_step_p3 = holba_miscLib.timer_start 0;*) + val simp_t = birs_simp_fun simp_tm; + (*val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n>>>>>> SUBST in " ^ delta_s ^ "\n")) timer_exec_step_p3;*) + in + SOME (simp_t, assignment_thm) + end) assignment_thm_o; + in + case simp_t_o of + SOME (simp_t, assignment_thm) => + postproc (MATCH_MP assignment_thm simp_t) + | NONE => thm + end; + val birs_rule_SUBST_trysimp_first_fun = fn x => fn y => Profile.profile "birs_rule_SUBST_trysimp_first_fun" (birs_rule_SUBST_trysimp_first_fun x y); in - case simp_t_o of - SOME (simp_t, assignment_thm) => cleanup_RULE (MATCH_MP assignment_thm simp_t) - | NONE => thm - end; -val birs_rule_SUBST_trysimp_first_fun = fn x => Profile.profile "birs_rule_SUBST_trysimp_first_fun" (birs_rule_SUBST_trysimp_first_fun x); - -(* TODO: check if there is performance difference between this version and the one that applies the single item case, probably don't need special case... *) -fun birs_rule_SUBST_trysimp_fun x y = birs_utilsLib.birs_Pi_each_RULE (birs_rule_SUBST_trysimp_first_fun x y); + fun birs_rule_SUBST_trysimp_fun x y = birs_Pi_each_RULE (birs_rule_SUBST_trysimp_first_fun x y); + end end (* local *) diff --git a/src/tools/symbexec/birs_simpLib.sml b/src/tools/symbexec/birs_simpLib.sml index 0903e24ad..155d3638e 100644 --- a/src/tools/symbexec/birs_simpLib.sml +++ b/src/tools/symbexec/birs_simpLib.sml @@ -157,49 +157,12 @@ val instd_thm = ASSUME `` birs_simp_try_fix_assumptions instd_thm; *) - fun birs_simp_try_justify_assumption assmpt = - let - val type_ofbirexp_CONV = type_of_bir_exp_CONV; - val assmpt_thm = (type_ofbirexp_CONV THENC EVAL) assmpt; - - val assmpt_new = (snd o dest_eq o concl) assmpt_thm; - - (* raise exception when the assumption turns out to be false *) - val _ = if not (identical assmpt_new F) then () else - raise ERR "birs_simp_try_justify_assumption" "assumption does not hold"; - - val _ = if identical assmpt_new T then () else - raise ERR "birs_simp_try_justify_assumption" ("failed to fix the assumption: " ^ (term_to_string assmpt)); - in - if identical assmpt_new T then - SOME (EQ_MP (GSYM assmpt_thm) TRUTH) - else - NONE - end - handle _ => NONE; - val birs_simp_try_justify_assumption = aux_moveawayLib.wrap_cache_result Term.compare birs_simp_try_justify_assumption; - (* need to handle typecheck, IS_SOME typecheck *) - fun birs_simp_try_justify_assumptions NONE = NONE - | birs_simp_try_justify_assumptions (SOME t) = - if (not o is_imp o concl) t then - SOME t - else - let - val assmpt = (fst o dest_imp o concl) t; - val assmpt_thm_o = birs_simp_try_justify_assumption assmpt; - in - case assmpt_thm_o of - NONE => NONE - | SOME assmpt_thm => - birs_simp_try_justify_assumptions - (SOME (MP t assmpt_thm)) - end; - + val birs_simp_try_justify_assumptions = birs_utilsLib.prove_assumptions true (type_of_bir_exp_CONV THENC EVAL); fun birs_simp_try_fix_assumptions instd_thm = let (* now try to check the assumptions *) - val final_thm_o = birs_simp_try_justify_assumptions (SOME instd_thm); + val final_thm_o = birs_simp_try_justify_assumptions instd_thm; val _ = if isSome final_thm_o andalso (birsSyntax.is_birs_simplification o concl) (valOf final_thm_o) then () else raise ERR "birs_simp_try_fix_assumptions" "this should not happen"; in diff --git a/src/tools/symbexec/birs_utilsLib.sml b/src/tools/symbexec/birs_utilsLib.sml index 430a88397..9b5a3fe72 100644 --- a/src/tools/symbexec/birs_utilsLib.sml +++ b/src/tools/symbexec/birs_utilsLib.sml @@ -196,7 +196,63 @@ in (* local *) else NONE end; - val check_imp_tm = aux_moveawayLib.wrap_cache_result Term.compare check_imp_tm; + val check_imp_tm = aux_moveawayLib.wrap_cache_result Term.compare check_imp_tm; + + fun check_pcondinf_tm pcondinf_tm = + if not (is_birs_pcondinf pcondinf_tm) then raise ERR "check_pcondinf_tm" "term needs to be birs_pcondinf" else + let + val pcond_tm = dest_birs_pcondinf pcondinf_tm; + val pcond_is_contr = bir_smtLib.bir_smt_check_unsat false pcond_tm; + in + if pcond_is_contr then + SOME (mk_oracle_thm "BIRS_CONTR_Z3" ([], pcondinf_tm)) + else + NONE + end; + val check_pcondinf_tm = aux_moveawayLib.wrap_cache_result Term.compare check_pcondinf_tm; + + local + fun try_prove_assumption conv assmpt = + let + val assmpt_thm = conv assmpt; + + val assmpt_new = (snd o dest_eq o concl) assmpt_thm; + + (* raise exception when the assumption turns out to be false *) + val _ = if not (identical assmpt_new F) then () else + raise ERR "try_prove_assumption" "assumption does not hold"; + + val _ = if identical assmpt_new T then () else + raise ERR "try_prove_assumption" ("failed to fix the assumption: " ^ (term_to_string assmpt)); + in + if identical assmpt_new T then + SOME (EQ_MP (GSYM assmpt_thm) TRUTH) + else + NONE + end + handle _ => NONE; + val try_prove_assumption = fn conv => aux_moveawayLib.wrap_cache_result Term.compare (try_prove_assumption conv); + + fun try_prove_assumptions remove_all conv NONE = NONE + | try_prove_assumptions remove_all conv (SOME t) = + if (not o is_imp o concl) t then + SOME t + else + let + val assmpt = (fst o dest_imp o concl) t; + val assmpt_thm_o = try_prove_assumption conv assmpt; + in + case assmpt_thm_o of + NONE => if remove_all then NONE else SOME t + | SOME assmpt_thm => + try_prove_assumptions + remove_all + conv + (SOME (MP t assmpt_thm)) + end; + in + fun prove_assumptions remove_all conv thm = try_prove_assumptions remove_all conv (SOME thm); + end (* general path condition weakening with z3 (to throw away path condition conjuncts (to remove branch path condition conjuncts)) *) fun birs_Pi_first_pcond_RULE pcond_new thm = From 42ac97a719dfe293e3bc61a080034e0ddf91f753 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Fri, 18 Oct 2024 10:06:19 +0200 Subject: [PATCH 81/95] Fix --- examples/riscv/aes/test-aes.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/examples/riscv/aes/test-aes.sml b/examples/riscv/aes/test-aes.sml index 57cc842ca..dfd473a1e 100644 --- a/examples/riscv/aes/test-aes.sml +++ b/examples/riscv/aes/test-aes.sml @@ -12,7 +12,7 @@ open aes_symb_execTheory; (* for now we just have a leightweight check; this is to include aes into the test *) val _ = print "checking aes_symb_analysis_thm:\n"; -val _ = if term_size (concl aes_symb_analysis_thm) = 23403 then () else +val _ = if term_size (concl aes_symb_analysis_thm) = 23173 then () else raise Fail "term size of aes symbolic execution theorem is not as expected"; val triple_tm = ((snd o dest_comb o concl) aes_symb_analysis_thm); From 0f849e31abfc86ac25c45617739d863ac24699e5 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Fri, 18 Oct 2024 14:59:53 +0200 Subject: [PATCH 82/95] Big refactoring --- examples/riscv/perftest/simpstress.sml | 6 +- .../tutorial/8-symbexec/test-symbexec.sml | 2 +- src/tools/symbexec/aux_setLib.sml | 27 +- src/tools/symbexec/bir_symbLib.sml | 4 +- src/tools/symbexec/birsSyntax.sml | 349 +++++++++------ src/tools/symbexec/birs_composeLib.sml | 7 +- src/tools/symbexec/birs_driveLib.sml | 96 ++-- src/tools/symbexec/birs_execLib.sml | 5 +- src/tools/symbexec/birs_instantiationLib.sml | 12 +- src/tools/symbexec/birs_intervalLib.sml | 12 +- src/tools/symbexec/birs_mergeLib.sml | 36 +- src/tools/symbexec/birs_stepLib.sml | 46 +- src/tools/symbexec/birs_utilsLib.sml | 418 +++++++----------- .../symbexec/examples/test-birs_compose.sml | 3 +- .../symbexec/examples/test-birs_transfer.sml | 2 +- 15 files changed, 488 insertions(+), 537 deletions(-) diff --git a/examples/riscv/perftest/simpstress.sml b/examples/riscv/perftest/simpstress.sml index 578cd0ded..199488a51 100644 --- a/examples/riscv/perftest/simpstress.sml +++ b/examples/riscv/perftest/simpstress.sml @@ -7136,7 +7136,7 @@ val state2_simpd_thm = birs_rule_STEP_fun_spec state2; val _ = holba_miscLib.timer_stop (fn delta_s => print ("time to simplify large store sequence: " ^ delta_s ^ "\n")) timer; val state2_simpd = let - val (_, _, Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) state2_simpd_thm; + val (_, _, Pi_tm) = (get_birs_sysLPi o concl) state2_simpd_thm; in (hd o symb_sound_struct_Pi_to_birstatelist_fun) Pi_tm end; @@ -7149,9 +7149,9 @@ val timer = holba_miscLib.timer_start 0; val state3_thm = birs_rule_STEP_fun_spec state2_simpd; val state3 = let - val (_, _, Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) state3_thm; + val (_, _, Pi_tm) = (get_birs_sysLPi o concl) state3_thm; in - (hd o symb_sound_struct_Pi_to_birstatelist_fun) Pi_tm + (hd o get_birs_Pi_list) Pi_tm end; val (_, state3_env, _, _) = dest_birs_state state3; val _ = holba_miscLib.timer_stop (fn delta_s => print ("time to step with simplifications and pruning: " ^ delta_s ^ "\n")) timer; diff --git a/examples/tutorial/8-symbexec/test-symbexec.sml b/examples/tutorial/8-symbexec/test-symbexec.sml index 2f0fb7cc7..eaa4e0195 100644 --- a/examples/tutorial/8-symbexec/test-symbexec.sml +++ b/examples/tutorial/8-symbexec/test-symbexec.sml @@ -97,7 +97,7 @@ val _ = print_thm symb_analysis_thm; (* ============================================================= *) (* check leafs *) -val (sys_i, L_s, Pi_f) = (symb_sound_struct_get_sysLPi_fun o concl) symb_analysis_thm; +val (sys_i, L_s, Pi_f) = (get_birs_sysLPi o concl) symb_analysis_thm; val leafs = (pred_setSyntax.strip_set o snd o dest_comb) Pi_f; val _ = print "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n" val _ = print "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n" diff --git a/src/tools/symbexec/aux_setLib.sml b/src/tools/symbexec/aux_setLib.sml index bdcec0156..0122ad5da 100644 --- a/src/tools/symbexec/aux_setLib.sml +++ b/src/tools/symbexec/aux_setLib.sml @@ -3,25 +3,26 @@ struct local -open HolKernel Parse boolLib bossLib; + open HolKernel Parse boolLib bossLib; -open pred_setTheory; + open pred_setTheory; -open bir_symbTheory; + open bir_symbTheory; -open birs_auxTheory; + open birs_auxTheory; -open HolBACoreSimps; + open HolBACoreSimps; -val birs_state_ss = rewrites (type_rws ``:birs_state_t``); + open birsSyntax; + open birs_utilsLib; + + val birs_state_ss = rewrites (type_rws ``:birs_state_t``); (* error handling *) val libname = "aux_setLib" val ERR = Feedback.mk_HOL_ERR libname val wrap_exn = Feedback.wrap_exn libname - - in (* local *) (* ---------------------------------------------------------------------------------- *) @@ -246,8 +247,8 @@ in (* local *) fun birs_gen_env_check_eq env1 env2 = let - val mappings1 = birs_utilsLib.get_env_mappings env1; - val mappings2 = birs_utilsLib.get_env_mappings env2; + val mappings1 = get_env_mappings env1; + val mappings2 = get_env_mappings env2; in birs_utilsLib.list_eq_contents (fn (x,y) => pair_eq identical identical x y) mappings1 mappings2 end; @@ -273,9 +274,9 @@ in (* local *) (fn tm => let val (bsys1_tm, bsys2_tm) = dest_eq tm; - val _ = if birsSyntax.birs_state_is_normform_gen false bsys1_tm andalso - birsSyntax.birs_state_is_normform_gen false bsys2_tm then () else - raise ERR "birs_state_EQ_CONV" "need two states with birs_gen_env environments"; + (* need two states with birs_gen_env environments *) + val _ = birs_check_state_norm ("birs_state_EQ_CONV", ": 1") bsys1_tm; + val _ = birs_check_state_norm ("birs_state_EQ_CONV", ": 2") bsys2_tm; val get_state_env = (fn (_,env,_,_) => env) o birsSyntax.dest_birs_state; val is_eq = birs_gen_env_check_eq (get_state_env bsys1_tm) (get_state_env bsys2_tm); diff --git a/src/tools/symbexec/bir_symbLib.sml b/src/tools/symbexec/bir_symbLib.sml index 8b5a45579..a2e01c79b 100644 --- a/src/tools/symbexec/bir_symbLib.sml +++ b/src/tools/symbexec/bir_symbLib.sml @@ -168,7 +168,7 @@ fun bir_symb_transfer ``birs_state_init_pre_GEN ^bir_state_init_lbl_tm ^birenvtyl_tm (mk_bsysprecond ^bspec_pre_tm ^birenvtyl_tm)``; - val (sys_i, L_s, Pi_f) = (symb_sound_struct_get_sysLPi_fun o concl) symb_analysis_thm; + val (sys_i, L_s, Pi_f) = (get_birs_sysLPi o concl) symb_analysis_thm; val analysis_L_NOTIN_thm = prove (``^birs_state_end_lbl_tm NOTIN ^L_s``, EVAL_TAC); @@ -436,7 +436,7 @@ fun bir_symb_transfer_two ``birs_state_init_pre_GEN ^bir_state_init_lbl_tm ^birenvtyl_tm (mk_bsysprecond ^bspec_pre_tm ^birenvtyl_tm)``; - val (sys_i, L_s, Pi_f) = (symb_sound_struct_get_sysLPi_fun o concl) symb_analysis_thm; + val (sys_i, L_s, Pi_f) = (get_birs_sysLPi o concl) symb_analysis_thm; val analysis_L_NOTIN_thm_1 = prove (``^birs_state_end_lbl_1_tm NOTIN ^L_s``, EVAL_TAC); val analysis_L_NOTIN_thm_2 = prove (``^birs_state_end_lbl_2_tm NOTIN ^L_s``, EVAL_TAC); diff --git a/src/tools/symbexec/birsSyntax.sml b/src/tools/symbexec/birsSyntax.sml index a68aa6264..eb1db8c8f 100644 --- a/src/tools/symbexec/birsSyntax.sml +++ b/src/tools/symbexec/birsSyntax.sml @@ -3,10 +3,7 @@ struct local -open HolKernel Parse boolLib bossLib; - -open symb_recordTheory; -open birs_auxTheory; + open HolKernel Parse boolLib bossLib; (* error handling *) val libname = "birSyntax" @@ -15,6 +12,41 @@ open birs_auxTheory; in (* local *) + fun check_CONV f (sfun, smsg) tm = + ((if f tm then () else + (print_term tm; + raise ERR sfun smsg)); + REFL tm); + + fun check_raise f (sfun, smsg) x = + if f x then () else + raise ERR sfun smsg; + +(* ---------------------------------------------------------------------------------------- *) + + (* turn bir conjunction into list of conjuncts (care should be taken because this is only meaningful if the type of expression is indeed bit1) *) + fun dest_bandl x = + let + open bir_exp_immSyntax; + open bir_expSyntax; + fun is_BExp_And tm = is_BExp_BinExp tm andalso (is_BIExp_And o (fn (x,_,_) => x) o dest_BExp_BinExp) tm; + fun dest_BExp_And tm = ((fn (_,x,y) => (x,y)) o dest_BExp_BinExp) tm; + + (* could add a typecheck of x here, to make sure that tm is indeed a Bit1 bir expression *) + fun dest_bandl_r [] acc = acc + | dest_bandl_r (tm::tms) acc = + if not (is_BExp_And tm) then dest_bandl_r tms (tm::acc) else + let + val (tm1,tm2) = dest_BExp_And tm; + in + dest_bandl_r (tm1::tm2::tms) acc + end; + in + List.rev (dest_bandl_r [x] []) + end; + +(* ---------------------------------------------------------------------------------------- *) + local fun syntax_fns n d m = HolKernel.syntax_fns {n = n, dest = d, make = m} "option" val syntax_fns2 = syntax_fns 2 HolKernel.dest_binop HolKernel.mk_binop; @@ -32,6 +64,7 @@ end; (* local + open symb_recordTheory; fun syntax_fns n d m = HolKernel.syntax_fns {n = n, dest = d, make = m} "symb_record" val syntax_fns2 = syntax_fns 2 HolKernel.dest_binop HolKernel.mk_binop; in @@ -40,6 +73,7 @@ end; *) local + open birs_auxTheory; fun syntax_fns n d m = HolKernel.syntax_fns {n = n, dest = d, make = m} "birs_aux" val syntax_fns1 = syntax_fns 1 HolKernel.dest_monop HolKernel.mk_monop; val syntax_fns1_env = syntax_fns 2 HolKernel.dest_monop HolKernel.mk_monop; @@ -148,144 +182,185 @@ in val (birs_exp_imp_tm, mk_birs_exp_imp, dest_birs_exp_imp, is_birs_exp_imp) = syntax_fns2 "birs_exp_imp"; end -(* -fun is_IMAGE_birs_symb_to_symbst Pi = pred_setSyntax.is_image Pi andalso (identical birs_symb_to_symbst_tm o fst o pred_setSyntax.dest_image) Pi; -fun dest_IMAGE_birs_symb_to_symbst Pi = - let - val (im_fun_tm, im_set_tm) = (pred_setSyntax.dest_image) Pi; - val _ = if identical birs_symb_to_symbst_tm im_fun_tm then () else - raise ERR "dest_IMAGE_birs_symb_to_symbst" "image function has to be birs_symb_to_symbst"; - in - im_set_tm - end; - *) - (* ====================================================================================== *) -(* helpers to check if sound structure terms (and subterms) are in normalform *) -(* ----------------------------------------------- *) - (* - val bir_state_init = ``<|bsst_pc := <|bpc_label := BL_Address (Imm32 2824w); bpc_index := 0|>; - bsst_environ := - birs_gen_env - [("x15",BExp_Den (BVar "sy_x15" (BType_Imm Bit64))); - ("x13",BExp_Den (BVar "sy_x13" (BType_Imm Bit64))); - ("x14",BExp_Den (BVar "sy_x14" (BType_Imm Bit64))); - ("x10",BExp_Den (BVar "sy_x10" (BType_Imm Bit64))); - ("MEM8", - BExp_Den (BVar "sy_MEM8" (BType_Mem Bit64 Bit8))); - ("x2",BExp_Den (BVar "sy_x2" (BType_Imm Bit64))); - ("x1",BExp_Den (BVar "sy_x1" (BType_Imm Bit64)))]; - bsst_status := BST_Running; - bsst_pcond := - BExp_BinExp BIExp_And - (BExp_BinExp BIExp_And - (BExp_BinPred BIExp_LessOrEqual (BExp_Const (Imm64 0xFFFFFFw)) - (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32)))) - (BExp_Aligned Bit32 2 - (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))))) - (BExp_BinPred BIExp_LessOrEqual - (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) - (BExp_Const (Imm64 0xFFFFFFFFFFFFFF00w)))|>``; - *) - fun birs_state_is_normform_gen is_start tm = - is_birs_state tm andalso - let - fun is_normform_birs_gen_env env = - is_birs_gen_env env andalso - (can listSyntax.dest_list o dest_birs_gen_env) env; - fun is_normform_bir_senv_GEN_list env = - is_bir_senv_GEN_list env; - - val env = dest_birs_state_env tm; - in - is_normform_birs_gen_env env orelse - if not is_start then false else - is_normform_bir_senv_GEN_list env - end; - - val birs_state_is_normform = birs_state_is_normform_gen false; - - fun is_a_normform_set tm = - can pred_setSyntax.strip_set tm; - - fun birs_states_are_normform tm = - is_a_normform_set tm andalso - ((List.all birs_state_is_normform o pred_setSyntax.strip_set) tm - handle _ => false); - - - fun birs_state_is_normform_CONV sfun bstate_tm = - (if (birs_state_is_normform) bstate_tm then () else - (print_term bstate_tm; - raise ERR (sfun^"::birs_state_is_normform_CONV") "something is not right, the input state is not as expected"); - REFL bstate_tm); - - fun birs_states_are_normform_CONV sfun bstates_tm = - (if (birs_states_are_normform) bstates_tm then () else - (print_term bstates_tm; - raise ERR (sfun^"::birs_states_are_normform_CONV") "something is not right, the produced theorem is not evaluated enough"); - REFL bstates_tm); - - fun birs_states_are_normform_CONV_with_start sfun bstate_tm bstates_tm = - birs_states_are_normform_CONV sfun bstates_tm - handle e => (print "\n[[[[\n"; print_term bstate_tm; print "\n]]]]\n"; raise e); - - - -(* extract information from a sound structure *) -(* ----------------------------------------------- *) -fun mk_sysLPi (sys_tm, L_tm, Pi_tm) = - pairSyntax.list_mk_pair [sys_tm, L_tm, Pi_tm]; -fun dest_sysLPi tm = - case pairSyntax.strip_pair tm of - [sys_tm, L_tm, Pi_tm] => (sys_tm, L_tm, Pi_tm) - | _ => raise ERR "dest_sysLPi" "unexpected structure triple"; -fun symb_sound_struct_get_sysLPi_fun tm = - let - val _ = if is_birs_symb_exec tm then () else - raise ERR "symb_sound_struct_get_sysLPi_fun" "term must be a birs_symb_exec"; - val sysLPi_tm = - (snd o dest_birs_symb_exec) tm; - in - dest_sysLPi sysLPi_tm - end; + (* extract terms from a sound structure *) + (* ----------------------------------------------- *) + fun mk_sysLPi (sys_tm, L_tm, Pi_tm) = + pairSyntax.list_mk_pair [sys_tm, L_tm, Pi_tm]; + + fun dest_sysLPi tm = + case pairSyntax.strip_pair tm of + [sys_tm, L_tm, Pi_tm] => (sys_tm, L_tm, Pi_tm) + | _ => raise ERR "dest_sysLPi" "unexpected structure, should be triple"; + + fun get_birs_prog tm = + let + val _ = if is_birs_symb_exec tm then () else + raise ERR "get_birs_prog" "term must be a birs_symb_exec"; + in + (fst o dest_birs_symb_exec) tm + end; + + fun get_birs_sysLPi tm = + let + val _ = if is_birs_symb_exec tm then () else + raise ERR "get_birs_sysLPi" "term must be a birs_symb_exec"; + in + (dest_sysLPi o snd o dest_birs_symb_exec) tm + end; + +(* ---------------------------------------------------------------------------------------- *) + + (* function to get the initial state *) + fun get_birs_sys tm = + let + val (sys_tm,_,_) = get_birs_sysLPi tm; + in + sys_tm + end; + + (* function to get the set Pi *) + fun get_birs_Pi tm = + let + val (_,_,Pi_tm) = get_birs_sysLPi tm; + in + Pi_tm + end; + + (* function to get Pi as list *) + val get_birs_Pi_list = + (pred_setSyntax.strip_set o get_birs_Pi); + + (* function to get the length of Pi *) + val get_birs_Pi_length = + (length o get_birs_Pi_list); + + (* function to get the first Pi state *) + val get_birs_Pi_first = + (fst o pred_setSyntax.dest_insert o get_birs_Pi); + + (* get env mappings *) + val get_env_mappings = + (List.map pairSyntax.dest_pair o fst o listSyntax.dest_list o dest_birs_gen_env); + + (* get top env mapping *) + fun get_env_top_mapping env = + let + val env_mappings = get_env_mappings env; + val _ = if not (List.null env_mappings) then () else + raise ERR "get_env_top_mapping" "need at least one mapping in the environment"; + in + hd env_mappings + end; -(* -val Pi_tm = Pi_A_tm; -*) -fun symb_sound_struct_Pi_to_birstatelist_fun Pi_tm = - pred_setSyntax.strip_set Pi_tm; + (* function to get the top env mapping of the first Pi state *) + fun get_birs_Pi_first_env_top_mapping tm = + let + val Pi_sys_tm = get_birs_Pi_first tm; + val (_,env,_,_) = dest_birs_state Pi_sys_tm; + in + get_env_top_mapping env + end; + + (* function to get the pcond of the first Pi state *) + fun get_birs_Pi_first_pcond tm = + let + val Pi_sys_tm = get_birs_Pi_first tm; + val (_,_,_,pcond) = dest_birs_state Pi_sys_tm; + in + pcond + end; + + (* function to get the pcond of the first Pi state *) + fun get_birs_sys_pcond tm = + let + val sys_tm = get_birs_sys tm; + val (_,_,_,pcond) = dest_birs_state sys_tm; + in + pcond + end; -(* check if sound structure term is in normalform *) +(* ---------------------------------------------------------------------------------------- *) + +(* helpers to check if sound structure terms (and subterms) are in normalform *) (* ----------------------------------------------- *) -fun symb_sound_struct_is_normform tm = - let - val (sys, L, Pi) = symb_sound_struct_get_sysLPi_fun tm - handle _ => raise ERR "symb_sound_struct_is_normform" "unexpected term, should be a birs_symb_exec with a triple as structure"; - - val sys_ok = birs_state_is_normform_gen false sys; - val L_ok = is_a_normform_set L; - val Pi_ok = birs_states_are_normform Pi; - in - sys_ok andalso L_ok andalso Pi_ok - end; - -(* check if two structures are in normform and use the same program *) -fun birs_symb_exec_check_compatible A_thm B_thm = - let - val _ = if (symb_sound_struct_is_normform o concl) A_thm then () else - raise ERR "birs_symb_exec_compatible" "theorem A is not a standard birs_symb_exec"; - val _ = if (symb_sound_struct_is_normform o concl) B_thm then () else - raise ERR "birs_symb_exec_compatible" "theorem B is not a standard birs_symb_exec"; - - val (bprog_A_tm,_) = (dest_birs_symb_exec o concl) A_thm; - val (bprog_B_tm,_) = (dest_birs_symb_exec o concl) B_thm; - val _ = if identical bprog_A_tm bprog_B_tm then () else - raise ERR "birs_symb_exec_compatible" "the programs of A and B have to match"; - in - () - end; + (* + val bir_state_init = ``<|bsst_pc := <|bpc_label := BL_Address (Imm32 2824w); bpc_index := 0|>; + bsst_environ := + birs_gen_env + [("x15",BExp_Den (BVar "sy_x15" (BType_Imm Bit64))); + ("x13",BExp_Den (BVar "sy_x13" (BType_Imm Bit64))); + ("x14",BExp_Den (BVar "sy_x14" (BType_Imm Bit64))); + ("x10",BExp_Den (BVar "sy_x10" (BType_Imm Bit64))); + ("MEM8", + BExp_Den (BVar "sy_MEM8" (BType_Mem Bit64 Bit8))); + ("x2",BExp_Den (BVar "sy_x2" (BType_Imm Bit64))); + ("x1",BExp_Den (BVar "sy_x1" (BType_Imm Bit64)))]; + bsst_status := BST_Running; + bsst_pcond := + BExp_BinExp BIExp_And + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual (BExp_Const (Imm64 0xFFFFFFw)) + (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32)))) + (BExp_Aligned Bit32 2 + (BExp_Den (BVar "sy_SP_process" (BType_Imm Bit32))))) + (BExp_BinPred BIExp_LessOrEqual + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 0xFFFFFFFFFFFFFF00w)))|>``; + *) + fun birs_env_is_norm env = + is_birs_gen_env env andalso + (can listSyntax.dest_list o dest_birs_gen_env) env; + + fun birs_state_is_norm tm = + is_birs_state tm andalso + birs_env_is_norm (dest_birs_state_env tm); + + fun pred_set_is_norm tm = + can pred_setSyntax.strip_set tm; + + fun birs_states_is_norm tm = + pred_set_is_norm tm andalso + (List.all birs_state_is_norm o pred_setSyntax.strip_set) tm; + + (* check if sound structure term is in normalform *) + fun birs_is_norm tm = + let + val (sys, L, Pi) = + get_birs_sysLPi tm + handle _ => raise ERR "birs_is_norm" "unexpected term, should be a birs_symb_exec with a triple as structure"; + in + birs_state_is_norm sys andalso + pred_set_is_norm L andalso + birs_states_is_norm Pi + end + handle _ => false; + +(* ---------------------------------------------------------------------------------------- *) + + fun birs_check_norm_thm (sfun, smsg) = + check_raise (birs_is_norm o concl) (sfun, "theorem is not norm" ^ smsg); + + fun birs_check_state_norm (sfun, smsg) = + check_raise (birs_state_is_norm) (sfun, "state is not norm" ^ smsg); + + fun birs_check_min_Pi_thm m (sfun) = + check_raise ((fn x => x >= m) o get_birs_Pi_length o concl) (sfun, "Pi has to have at least "^(Int.toString m)^" states"); + + (* check if two structures are in normform and use the same program *) + fun birs_check_compatible A_thm B_thm = + let + val _ = birs_check_norm_thm ("birs_check_compatible", ": A") A_thm; + val _ = birs_check_norm_thm ("birs_check_compatible", ": B") A_thm; + + val bprog_A_tm = (get_birs_prog o concl) A_thm; + val bprog_B_tm = (get_birs_prog o concl) B_thm; + val _ = if identical bprog_A_tm bprog_B_tm then () else + raise ERR "birs_check_compatible" "the programs of A and B have to match"; + in + () + end; end (* local *) diff --git a/src/tools/symbexec/birs_composeLib.sml b/src/tools/symbexec/birs_composeLib.sml index 29f5ddd3e..e4c078ad5 100644 --- a/src/tools/symbexec/birs_composeLib.sml +++ b/src/tools/symbexec/birs_composeLib.sml @@ -60,7 +60,7 @@ in *) fun birs_rule_SEQ_fun birs_rule_SEQ_thm step_A_thm step_B_thm = let - val _ = birs_symb_exec_check_compatible step_A_thm step_B_thm; + val _ = birs_check_compatible step_A_thm step_B_thm; val prep_thm = Profile.profile "birs_rule_SEQ_fun_1_match" (HO_MATCH_MP (HO_MATCH_MP birs_rule_SEQ_thm step_A_thm)) step_B_thm; @@ -81,9 +81,8 @@ in bprog_composed_thm handle e => (print "\n\n"; print_thm bprog_composed_thm; print "tidy up Pi and labelset failed\n"; raise e); - val _ = if symb_sound_struct_is_normform (concl bprog_fixed_thm) then () else - (print_term (concl bprog_fixed_thm); - raise ERR "birs_rule_SEQ_fun" "something is not right, the produced theorem is not evaluated enough"); + val _ = birs_check_norm_thm ("birs_rule_SEQ_fun", "") bprog_fixed_thm + handle e => (print_term (concl bprog_fixed_thm); raise e); in bprog_fixed_thm end; diff --git a/src/tools/symbexec/birs_driveLib.sml b/src/tools/symbexec/birs_driveLib.sml index 05ce52baa..f43950d95 100644 --- a/src/tools/symbexec/birs_driveLib.sml +++ b/src/tools/symbexec/birs_driveLib.sml @@ -68,14 +68,13 @@ in (* local *) fun build_tree_rec exec_funs thm = let val _ = print ("\n"); - val (_, _, Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) thm; val (_, _, _, is_continue) = exec_funs; fun is_executable st = birs_state_is_running st andalso is_continue st; - val sts = symb_sound_struct_Pi_to_birstatelist_fun Pi_tm; + val sts = (get_birs_Pi_list o concl) thm; val sts_exec = List.filter is_executable sts; (* val _ = print ("- have " ^ (Int.toString (length sts)) ^ " states\n"); @@ -107,12 +106,8 @@ in (* local *) end; fun build_tree exec_funs st = - let - val _ = if birs_state_is_normform_gen false st then () else - raise ERR "build_tree" "state is not in standard form with birs_gen_env"; - in - build_tree_rec exec_funs (take_step exec_funs st) - end; + (birs_check_state_norm ("build_tree", "") st; + build_tree_rec exec_funs (take_step exec_funs st)); fun exec_until exec_funs comp_fun = (Profile.profile "reduce_tree" (reduce_tree comp_fun)) o @@ -125,50 +120,49 @@ in (* local *) fun bir_symb_exec_to (bprog_tm, birs_post_step_fun) birs_end_lbls birs_state = let - val _ = if birs_state_is_normform_gen false birs_state then () else - raise ERR "bir_symb_exec_to" "state is not in standard form with birs_gen_env"; - - open birs_execLib; - - val birs_rule_STEP_thm = birs_rule_STEP_prog_fun (Profile.profile "bir_prog_has_no_halt_fun" bir_prog_has_no_halt_fun bprog_tm); - val birs_rule_STEP_fun_spec = - (birs_post_step_fun o - birs_rule_STEP_fun birs_rule_STEP_thm); - (* now the composition *) - val birs_rule_SEQ_thm = birs_rule_SEQ_prog_fun bprog_tm; - val birs_rule_SEQ_fun_spec = birs_rule_SEQ_fun birs_rule_SEQ_thm; - (*val _ = print_thm single_step_A_thm;*) - (* and also the sequential composition *) - val birs_rule_STEP_SEQ_thm = MATCH_MP - birs_rulesTheory.birs_rule_STEP_SEQ_gen_thm - (bir_prog_has_no_halt_fun bprog_tm); - val birs_rule_STEP_SEQ_fun_spec = - (birs_post_step_fun o - birs_rule_STEP_SEQ_fun birs_rule_STEP_SEQ_thm); - - val fetch = fn _ => NONE; - (*val fetch = fn _ => SOME TRUTH;*) - (*val fetch = fn x => SOME (birs_rule_STEP_fun_spec x);*) - val is_continue = not_stop_lbl birs_end_lbls; - - val _ = print "now reducing it to one sound structure\n"; - val timer = holba_miscLib.timer_start 0; - val result = exec_until - (fetch, birs_rule_STEP_SEQ_fun_spec, birs_rule_STEP_fun_spec, is_continue) - birs_rule_SEQ_fun_spec - birs_state - handle e => (Profile.print_profile_results (Profile.results ()); raise e); - val _ = holba_miscLib.timer_stop - (fn delta_s => print ("\n======\n > exec_until took " ^ delta_s ^ "\n")) timer; - - (* - Profile.reset_all () - Profile.print_profile_results (Profile.results ()) - Profile.output_profile_results (iostream) (Profile.results ()) - *) - val _ = Profile.print_profile_results (Profile.results ()); + val _ = birs_check_state_norm ("bir_symb_exec_to", "") birs_state; + + open birs_execLib; + + val birs_rule_STEP_thm = birs_rule_STEP_prog_fun (Profile.profile "bir_prog_has_no_halt_fun" bir_prog_has_no_halt_fun bprog_tm); + val birs_rule_STEP_fun_spec = + (birs_post_step_fun o + birs_rule_STEP_fun birs_rule_STEP_thm); + (* now the composition *) + val birs_rule_SEQ_thm = birs_rule_SEQ_prog_fun bprog_tm; + val birs_rule_SEQ_fun_spec = birs_rule_SEQ_fun birs_rule_SEQ_thm; + (*val _ = print_thm single_step_A_thm;*) + (* and also the sequential composition *) + val birs_rule_STEP_SEQ_thm = MATCH_MP + birs_rulesTheory.birs_rule_STEP_SEQ_gen_thm + (bir_prog_has_no_halt_fun bprog_tm); + val birs_rule_STEP_SEQ_fun_spec = + (birs_post_step_fun o + birs_rule_STEP_SEQ_fun birs_rule_STEP_SEQ_thm); + + val fetch = fn _ => NONE; + (*val fetch = fn _ => SOME TRUTH;*) + (*val fetch = fn x => SOME (birs_rule_STEP_fun_spec x);*) + val is_continue = not_stop_lbl birs_end_lbls; + + val _ = print "now reducing it to one sound structure\n"; + val timer = holba_miscLib.timer_start 0; + val result = exec_until + (fetch, birs_rule_STEP_SEQ_fun_spec, birs_rule_STEP_fun_spec, is_continue) + birs_rule_SEQ_fun_spec + birs_state + handle e => (Profile.print_profile_results (Profile.results ()); raise e); + val _ = holba_miscLib.timer_stop + (fn delta_s => print ("\n======\n > exec_until took " ^ delta_s ^ "\n")) timer; + + (* + Profile.reset_all () + Profile.print_profile_results (Profile.results ()) + Profile.output_profile_results (iostream) (Profile.results ()) + *) + val _ = Profile.print_profile_results (Profile.results ()); in - result + result end; val bir_symb_exec_to = fn x => fn y => Profile.profile "bir_symb_exec_to" (bir_symb_exec_to x y); diff --git a/src/tools/symbexec/birs_execLib.sml b/src/tools/symbexec/birs_execLib.sml index c1f5ab908..b75e493a8 100644 --- a/src/tools/symbexec/birs_execLib.sml +++ b/src/tools/symbexec/birs_execLib.sml @@ -43,9 +43,8 @@ in val single_step_prog_thm = Profile.profile "birs_rule_STEP_fun_overhead" exec_step_postproc_fun birs_exec_thm; (*val _ = print_thm single_step_prog_thm;*) - val _ = if symb_sound_struct_is_normform (concl single_step_prog_thm) then () else - (print_term (concl single_step_prog_thm); - raise ERR "birs_rule_STEP_fun" "something is not right, the produced theorem is not evaluated enough"); + val _ = birs_check_norm_thm ("birs_rule_STEP_fun", "") single_step_prog_thm + handle e => (print_term (concl single_step_prog_thm); raise e); in (single_step_prog_thm, extra_info) end; diff --git a/src/tools/symbexec/birs_instantiationLib.sml b/src/tools/symbexec/birs_instantiationLib.sml index f0e1a7280..ad456c435 100644 --- a/src/tools/symbexec/birs_instantiationLib.sml +++ b/src/tools/symbexec/birs_instantiationLib.sml @@ -36,9 +36,6 @@ in (* local *) (* TODO later (instantiate): rename all variables *) fun birs_sound_rename_all_RULE thm = let - val _ = if (symb_sound_struct_is_normform o concl) thm then () else - raise ERR "birs_sound_rename_all_RULE" "theorem is not a standard birs_symb_exec"; - (* collect what to rename from the initial environment mapping, should be all just variables, skip renaming of the pathcondition *) in () @@ -98,8 +95,7 @@ in (* local *) (* the instantiation function *) fun birs_sound_symb_inst_RULE symb_exp_map thm = let - val _ = if (symb_sound_struct_is_normform o concl) thm then () else - raise ERR "birs_sound_symb_inst_RULE" "theorem is not a standard birs_symb_exec"; + val _ = birs_check_norm_thm ("birs_sound_symb_inst_RULE", "") thm; (* for now a function that does all at once and cheats, either sml substitution (for simplicity and speed, double-check the documentation to make sure that it is an "all-at-once substitution") or bir expression substitution and EVAL *) val s = List.map (fn (bv_symb,exp) => ((bslSyntax.bden bv_symb) |-> exp)) symb_exp_map; @@ -115,7 +111,7 @@ in (* local *) *) fun birs_sound_inst_SEQ_RULE birs_rule_SEQ_thm bv_syp_gen A_thm B_thm = let - val _ = birs_symb_exec_check_compatible A_thm B_thm; + val _ = birs_check_compatible A_thm B_thm; val A_Pi_sys_tm = (get_birs_Pi_first o concl) A_thm; val (_,_,_,A_pcond) = dest_birs_state A_Pi_sys_tm; val len_of_thm_Pi = get_birs_Pi_length o concl; @@ -145,8 +141,8 @@ in (* local *) raise ERR "birs_sound_inst_SEQ_RULE" "summaries can only contain 1 state currently"; (* cleanup Pi path conditions (probably only need to consider one for starters) to only preserve non-summary conjunct (as the step before), but preserve also the intervals *) val B_Pi_pcond = (get_birs_Pi_first_pcond o concl) B_thm_inst_sys; - val B_Pi_pcond_intervals = List.filter (is_BExp_IntervalPred) (dest_band B_Pi_pcond); - val B_pcondl_new = B_Pi_pcond_intervals@(list_minus term_id_eq (dest_band A_pcond) B_Pi_pcond_intervals); + val B_Pi_pcond_intervals = List.filter (is_BExp_IntervalPred) (dest_bandl B_Pi_pcond); + val B_pcondl_new = B_Pi_pcond_intervals@(list_minus term_id_eq (dest_bandl A_pcond) B_Pi_pcond_intervals); val B_Pi_pcond_new = bslSyntax.bandl (B_pcondl_new); (* val _ = print_term (bslSyntax.bandl B_Pi_pcond_intervals_); diff --git a/src/tools/symbexec/birs_intervalLib.sml b/src/tools/symbexec/birs_intervalLib.sml index 8812bac55..587f7d6d1 100644 --- a/src/tools/symbexec/birs_intervalLib.sml +++ b/src/tools/symbexec/birs_intervalLib.sml @@ -58,7 +58,7 @@ local val _ = if (is_BExp_Den env_exp) andalso (((fn x => x = vn_symb vn) o fst o dest_BVar_string o dest_BExp_Den) env_exp) then () else raise ERR "interval_from_state" ("unexpected, the expression should be just the syi_ symbol: " ^ (term_to_string env_exp)); val env_symbol = dest_BExp_Den env_exp; - val pcondl = dest_band pcond; + val pcondl = dest_bandl pcond; val pcond_intervaltms = List.filter (is_binterval env_symbol) pcondl; val pcondl_filtd = List.filter (not o is_binterval env_symbol) pcondl; val _ = if length pcond_intervaltms = 1 then () else @@ -207,8 +207,7 @@ in (* local *) (* this has to be used after an instantiation and after an execution (which in turn is either from an initial state, or from after a merge operation), and before a bounds operation below *) fun birs_intervals_Pi_first_unify_RULE vn thm = let - val _ = if (symb_sound_struct_is_normform o concl) thm then () else - raise ERR "birs_intervals_Pi_first_unify_RULE" "theorem is not a standard birs_symb_exec"; + val _ = birs_check_norm_thm ("birs_intervals_Pi_first_unify_RULE", "") thm; val _ = if not debug_mode then () else print "starting to unify interval for one Pi state\n"; @@ -234,7 +233,7 @@ in (* local *) (* need to operate on the path condition *) val pcond = (get_birs_Pi_first_pcond o concl) thm1; - val pcondl = dest_band pcond; + val pcondl = dest_bandl pcond; (* search for related simple equality, or for an interval *) val pcond_eqtms = List.filter (is_beq_left env_symbol) pcondl; @@ -312,8 +311,7 @@ in (* local *) (* this has to be used after a unify operation above, and before the actual merging to be able to keep the interval in the path condition and the symbol reference in the environment mapping *) fun birs_intervals_Pi_bounds_RULE vn thm = let - val _ = if (symb_sound_struct_is_normform o concl) thm then () else - raise ERR "birs_intervals_Pi_bounds_RULE" "theorem is not a standard birs_symb_exec"; + val _ = birs_check_norm_thm ("birs_intervals_Pi_bounds_RULE", "") thm; val Pi_len = (get_birs_Pi_length o concl) thm; in if Pi_len < 2 then thm else @@ -330,7 +328,7 @@ in (* local *) val _ = if (is_BExp_Den env_exp) andalso (((fn x => x = vn_symb vn) o fst o dest_BVar_string o dest_BExp_Den) env_exp) then () else raise ERR "birs_intervals_Pi_bounds_RULE" ("unexpected, the expression should be just the syi_ symbol: " ^ (term_to_string env_exp)); val env_symbol = dest_BExp_Den env_exp; - val pcondl = dest_band pcond; + val pcondl = dest_bandl pcond; val pcond_intervaltms = List.filter (is_binterval env_symbol) pcondl; val pcondl_filtd = List.filter (not o is_binterval env_symbol) pcondl; val _ = if length pcond_intervaltms = 1 then () else diff --git a/src/tools/symbexec/birs_mergeLib.sml b/src/tools/symbexec/birs_mergeLib.sml index 4fa78c67e..d4891ca31 100644 --- a/src/tools/symbexec/birs_mergeLib.sml +++ b/src/tools/symbexec/birs_mergeLib.sml @@ -48,8 +48,7 @@ in (* local *) (* TODO: this is maybe too crude: just replace the given expression anywhere in the currently mapped expression *) fun birs_Pi_first_freesymb_RULE symbname exp_tm thm = let - val _ = if (symb_sound_struct_is_normform o concl) thm then () else - raise ERR "birs_Pi_first_freesymb_RULE" "theorem is not a standard birs_symb_exec"; + val _ = birs_check_norm_thm ("birs_Pi_first_freesymb_RULE", "") thm; (* get the previously mapped expression *) val (p_tm, tri_tm) = (dest_birs_symb_exec o concl) thm; @@ -261,13 +260,12 @@ in (* local *) (* the merge function for the first two Pi states *) fun birs_Pi_merge_2_RULE thm = let + val _ = birs_check_norm_thm ("birs_Pi_merge_2_RULE", "") thm; + val _ = if not debug_mode then () else print "merging the first two in Pi\n"; val timer = holba_miscLib.timer_start 0; - val _ = if (symb_sound_struct_is_normform o concl) thm then () else - raise ERR "birs_Pi_merge_2_RULE" "theorem is not a standard birs_symb_exec"; (* assumes that Pi has at least two states *) - val (_,_,Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) thm; - val Pi_tms = pred_setSyntax.strip_set Pi_tm; + val Pi_tms = (get_birs_Pi_list o concl) thm; val num_Pi_el = length Pi_tms; val _ = if num_Pi_el > 1 then () else raise ERR "birs_Pi_merge_2_RULE" "Pi has to have at least two states"; @@ -305,8 +303,8 @@ in (* local *) val pcond2 = (get_birs_Pi_first_pcond o concl) thm1; (* get conjuncts as list *) - val pcond1l = dest_band pcond1; - val pcond2l = dest_band pcond2; + val pcond1l = dest_bandl pcond1; + val pcond2l = dest_bandl pcond2; (* find the common conjuncts by greedily collecting what is identical in both *) val pcond_commonl = list_commons term_id_eq pcond1l pcond2l; @@ -335,26 +333,20 @@ in (* local *) (* merging of all states in Pi *) fun birs_Pi_merge_RULE_ thm = - let - val _ = if (symb_sound_struct_is_normform o concl) thm then () else - raise ERR "birs_Pi_merge_RULE_" "theorem is not a standard birs_symb_exec"; - val (_,_,Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) thm; - val num_Pi_el = (length o pred_setSyntax.strip_set) Pi_tm; - in - (* recursion, go over all the Pi states until there is only one left *) - if num_Pi_el < 2 then - thm - else - birs_Pi_merge_RULE_ (birs_Pi_merge_2_RULE thm) - end; + (* recursion, go over all the Pi states until there is only one left *) + if (get_birs_Pi_length o concl) thm < 2 then + thm + else + birs_Pi_merge_RULE_ (birs_Pi_merge_2_RULE thm); fun birs_Pi_merge_RULE thm = let + val _ = birs_check_norm_thm ("birs_Pi_merge_RULE", "") thm; val merged_thm = birs_Pi_merge_RULE_ thm; (* check that the path condition has only changed in ways we want *) - val pcond_sysl = (dest_band o get_birs_sys_pcond o concl) merged_thm; - val pcond_Pifl = (dest_band o get_birs_Pi_first_pcond o concl) merged_thm; + val pcond_sysl = (dest_bandl o get_birs_sys_pcond o concl) merged_thm; + val pcond_Pifl = (dest_bandl o get_birs_Pi_first_pcond o concl) merged_thm; val pcond_sys_extral = list_minus term_id_eq pcond_sysl pcond_Pifl; val pcond_Pif_extral = list_minus term_id_eq pcond_Pifl pcond_sysl; fun check_extra extra = diff --git a/src/tools/symbexec/birs_stepLib.sml b/src/tools/symbexec/birs_stepLib.sml index 3a3761989..a9197a94f 100644 --- a/src/tools/symbexec/birs_stepLib.sml +++ b/src/tools/symbexec/birs_stepLib.sml @@ -1000,29 +1000,29 @@ fun birs_exec_step_CONV_fun tm = val last_pc = ref T; val last_stmt = ref T; val birs_step_thm = - GEN_match_conv -(is_birs_exec_step) -(fn bstate_tm => ( - RAND_CONV (birs_state_is_normform_CONV "birs_exec_step_CONV_fun") THENC - - (fn tm_i => - let - val (bprog_tm, st_i) = dest_birs_exec_step tm_i; - val (pc, _, _, _) = dest_birs_state st_i; - val _ = last_pc := pc; - val _ = last_stmt := (snd o dest_eq o concl o pc_lookup_fun) (bprog_tm, pc); (* TODO: avoid pc_lookup_fun twice *) - val timer_exec_step = holba_miscLib.timer_start 0; - (* TODO: optimize *) - val birs_exec_thm = birs_exec_step_CONV tm_i; - val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n>>>>>> executed step in " ^ delta_s ^ "\n")) timer_exec_step; - in - birs_exec_thm - end) THENC - - birs_states_are_normform_CONV_with_start "birs_exec_step_CONV_fun" bstate_tm - ) bstate_tm -) -tm; + GEN_match_conv + (is_birs_exec_step) + (fn exec_tm => ( + RAND_CONV (check_CONV birs_state_is_norm ("birs_exec_step_CONV_fun", "the state is not as expected")) THENC + + (fn tm_i => + let + val (bprog_tm, st_i) = dest_birs_exec_step tm_i; + val (pc, _, _, _) = dest_birs_state st_i; + val _ = last_pc := pc; + val _ = last_stmt := (snd o dest_eq o concl o pc_lookup_fun) (bprog_tm, pc); (* TODO: avoid pc_lookup_fun twice *) + val timer_exec_step = holba_miscLib.timer_start 0; + (* TODO: optimize *) + val birs_exec_thm = birs_exec_step_CONV tm_i; + val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n>>>>>> executed step in " ^ delta_s ^ "\n")) timer_exec_step; + in + birs_exec_thm + end) THENC + + (check_CONV birs_states_is_norm ("birs_exec_step_CONV_fun", "the produced theorem is not evaluated enough") + handle e => (print "\n[[[[\n"; print_term exec_tm; print "\n]]]]\n"; raise e)) + ) exec_tm) + tm; in (birs_step_thm, (!last_pc, !last_stmt)) end; diff --git a/src/tools/symbexec/birs_utilsLib.sml b/src/tools/symbexec/birs_utilsLib.sml index 9b5a3fe72..f9555dea8 100644 --- a/src/tools/symbexec/birs_utilsLib.sml +++ b/src/tools/symbexec/birs_utilsLib.sml @@ -14,6 +14,7 @@ local in (* local *) + (* TODO: move the generic list functions somewhere else *) fun list_distinct _ [] = true | list_distinct eq_fun (x::xs) = if all (fn y => (not o eq_fun) (x, y)) xs then list_distinct eq_fun xs else false; @@ -54,136 +55,55 @@ in (* local *) (* ---------------------------------------------------------------------------------------- *) - (* turn bir conjunction into list of conjuncts (care should be taken because this is only meaningful if the type of expression is indeed bit1) *) - fun dest_band x = + (* get all mapped variable names *) + fun birs_env_varnames birs_tm = let - open bir_exp_immSyntax; - open bir_expSyntax; - fun is_BExp_And tm = is_BExp_BinExp tm andalso (is_BIExp_And o (fn (x,_,_) => x) o dest_BExp_BinExp) tm; - fun dest_BExp_And tm = ((fn (_,x,y) => (x,y)) o dest_BExp_BinExp) tm; + val _ = birs_check_state_norm ("birs_env_varnames", "") birs_tm; - (* could add a typecheck of x here, to make sure that tm is indeed a Bit1 bir expression *) - fun dest_band_r [] acc = acc - | dest_band_r (tm::tms) acc = - if not (is_BExp_And tm) then dest_band_r tms (tm::acc) else - let - val (tm1,tm2) = dest_BExp_And tm; - in - dest_band_r (tm1::tm2::tms) acc - end; + val env = dest_birs_state_env birs_tm; + val mappings = get_env_mappings env; + val varname_tms = List.map fst mappings; + val varnames = List.map stringSyntax.fromHOLstring varname_tms; + (* now that we have the mappings, also check that varnames is distinct *) + val _ = if list_distinct gen_eq varnames then () else + raise ERR "birs_env_varnames" "state has one variable mapped twice"; in - dest_band_r [x] [] + varnames end; (* ---------------------------------------------------------------------------------------- *) - (* function to get the initial state *) - fun get_birs_sys tm = - let - val (_, tri_tm) = dest_birs_symb_exec tm; - val (sys_tm,_,_) = dest_sysLPi tri_tm; - in - sys_tm - end; - - (* function to get the set Pi *) - fun get_birs_Pi tm = - let - val (_, tri_tm) = dest_birs_symb_exec tm; - val (_,_,Pi_tm) = dest_sysLPi tri_tm; - in - Pi_tm - end; - - (* function to get the length of Pi *) - val get_birs_Pi_length = - (length o pred_setSyntax.strip_set o get_birs_Pi); - - (* function to get the first Pi state *) - val get_birs_Pi_first = - (fst o pred_setSyntax.dest_insert o get_birs_Pi); - - (* get env mappings *) - val get_env_mappings = - (List.map pairSyntax.dest_pair o fst o listSyntax.dest_list o dest_birs_gen_env); + local + open pred_setSyntax; + open pred_setTheory; + val rotate_first_INSERTs_thm = prove(`` + !x1 x2 xs. + (x1 INSERT x2 INSERT xs) = (x2 INSERT x1 INSERT xs) + ``, + fs [EXTENSION] >> + metis_tac [] + ); + fun is_two_INSERTs tm = (is_insert tm) andalso ((is_insert o snd o dest_insert) tm); + in + fun rotate_two_INSERTs_conv tm = + let + val _ = if is_two_INSERTs tm then () else + raise ERR "rotate_two_INSERTs_conv" "need to be a term made up of two inserts"; + val (x1_tm, x2xs_tm) = dest_insert tm; + val (x2_tm, xs_tm) = dest_insert x2xs_tm; + val inst_thm = ISPECL [x1_tm, x2_tm, xs_tm] rotate_first_INSERTs_thm; + in + inst_thm + end; - (* get top env mapping *) - fun get_env_top_mapping env = - let - val env_mappings = get_env_mappings env; - val _ = if not (List.null env_mappings) then () else - raise ERR "get_env_top_mapping" "need at least one mapping in the environment"; - in - hd env_mappings - end; - - (* function to get the top env mapping of the first Pi state *) - fun get_birs_Pi_first_env_top_mapping tm = - let - val Pi_sys_tm = get_birs_Pi_first tm; - val (_,env,_,_) = dest_birs_state Pi_sys_tm; - in - get_env_top_mapping env - end; - - (* function to get the pcond of the first Pi state *) - fun get_birs_Pi_first_pcond tm = - let - val Pi_sys_tm = get_birs_Pi_first tm; - val (_,_,_,pcond) = dest_birs_state Pi_sys_tm; - in - pcond - end; - - (* function to get the pcond of the first Pi state *) - fun get_birs_sys_pcond tm = - let - val sys_tm = get_birs_sys tm; - val (_,_,_,pcond) = dest_birs_state sys_tm; - in - pcond - end; + fun rotate_INSERTs_conv tm = + (if not (is_two_INSERTs tm) then REFL else + (rotate_two_INSERTs_conv THENC + RAND_CONV rotate_INSERTs_conv)) tm; + end (* ---------------------------------------------------------------------------------------- *) - val birs_exp_imp_DROP_R_thm = prove(`` - !be1 be2. - birs_exp_imp (BExp_BinExp BIExp_And be1 be2) be1 - ``, - (* maybe only true for expressions of type Bit1 *) - cheat - ); - val birs_exp_imp_DROP_L_thm = prove(`` - !be1 be2. - birs_exp_imp (BExp_BinExp BIExp_And be1 be2) be2 - ``, - (* maybe only true for expressions of type Bit1 *) - cheat - ); - - fun is_DROP_R_imp imp_tm = - (SOME (UNCHANGED_CONV (REWRITE_CONV [birs_exp_imp_DROP_R_thm]) imp_tm) - handle _ => NONE); - - fun is_DROP_L_imp imp_tm = - (SOME (UNCHANGED_CONV (REWRITE_CONV [birs_exp_imp_DROP_L_thm]) imp_tm) - handle _ => NONE); - - fun is_conjunct_inclusion_imp imp_tm = - let - val (pcond1, pcond2) = dest_birs_exp_imp imp_tm; - val pcond1l = dest_band pcond1; - val pcond2l = dest_band pcond2; - - (* find the common conjuncts by greedily collecting what is identical in both *) - val imp_is_ok = list_inclusion term_id_eq pcond2l pcond1l; - in - if imp_is_ok then - SOME (mk_oracle_thm "BIRS_CONJ_INCL_IMP" ([], imp_tm)) - else - NONE - end; - fun check_imp_tm imp_tm = if not (is_birs_exp_imp imp_tm) then raise ERR "check_imp_tm" "term needs to be birs_exp_imp" else let @@ -254,11 +174,50 @@ in (* local *) fun prove_assumptions remove_all conv thm = try_prove_assumptions remove_all conv (SOME thm); end +(* ---------------------------------------------------------------------------------------- *) + + val birs_exp_imp_DROP_R_thm = prove(`` + !be1 be2. + birs_exp_imp (BExp_BinExp BIExp_And be1 be2) be1 + ``, + (* maybe only true for expressions of type Bit1 *) + cheat + ); + val birs_exp_imp_DROP_L_thm = prove(`` + !be1 be2. + birs_exp_imp (BExp_BinExp BIExp_And be1 be2) be2 + ``, + (* maybe only true for expressions of type Bit1 *) + cheat + ); + + fun is_DROP_R_imp imp_tm = + (SOME (UNCHANGED_CONV (REWRITE_CONV [birs_exp_imp_DROP_R_thm]) imp_tm) + handle _ => NONE); + + fun is_DROP_L_imp imp_tm = + (SOME (UNCHANGED_CONV (REWRITE_CONV [birs_exp_imp_DROP_L_thm]) imp_tm) + handle _ => NONE); + + fun is_conjunct_inclusion_imp imp_tm = + let + val (pcond1, pcond2) = dest_birs_exp_imp imp_tm; + val pcond1l = dest_bandl pcond1; + val pcond2l = dest_bandl pcond2; + + (* find the common conjuncts by greedily collecting what is identical in both *) + val imp_is_ok = list_inclusion term_id_eq pcond2l pcond1l; + in + if imp_is_ok then + SOME (mk_oracle_thm "BIRS_CONJ_INCL_IMP" ([], imp_tm)) + else + NONE + end; + (* general path condition weakening with z3 (to throw away path condition conjuncts (to remove branch path condition conjuncts)) *) fun birs_Pi_first_pcond_RULE pcond_new thm = let - val _ = if (symb_sound_struct_is_normform o concl) thm then () else - raise ERR "birs_Pi_first_pcond_RULE" "theorem is not a standard birs_symb_exec"; + val _ = birs_check_norm_thm ("birs_Pi_first_pcond_RULE", "") thm; val (p_tm, tri_tm) = (dest_birs_symb_exec o concl) thm; val (sys_tm,L_tm,Pi_old_tm) = dest_sysLPi tri_tm; @@ -289,32 +248,28 @@ in (* local *) fun birs_Pi_first_pcond_drop drop_right thm = let - val Pi_sys_tm_free = (get_birs_Pi_first o concl) thm; - val (_,_,_,pcond_old) = dest_birs_state Pi_sys_tm_free; - val sel_fun = + open bir_expSyntax; + open bir_exp_immSyntax; + val Pi_sys_tm = (get_birs_Pi_first o concl) thm; + val pcond = dest_birs_state_pcond Pi_sys_tm; + val _ = if is_BExp_BinExp pcond then () else + raise ERR "birs_Pi_first_pcond_drop" "pcond must be a BinExp"; + val (bop,be1,be2) = dest_BExp_BinExp pcond; + val _ = if is_BIExp_And bop then () else + raise ERR "birs_Pi_first_pcond_drop" "pcond must be an And"; + val pcond_new = if drop_right then - (snd o dest_comb o fst o dest_comb) + be1 else - (snd o dest_comb); - val pcond_new = sel_fun pcond_old; - - (* debug printout *) - (*val _ = print_thm thm;*) - (* - val _ = print "\npcond before: \n"; - val _ = print_term pcond_old; - val _ = print "\npcond after: \n"; - val _ = print_term pcond_new; - *) + be2; in birs_Pi_first_pcond_RULE pcond_new thm end; - (* TODO later (instantiate): general path condition strengthening with z3 *) + (* general path condition strengthening with z3 *) fun birs_sys_pcond_RULE pcond_new thm = let - val _ = if (symb_sound_struct_is_normform o concl) thm then () else - raise ERR "birs_sys_pcond_RULE" "theorem is not a standard birs_symb_exec"; + val _ = birs_check_norm_thm ("birs_sys_pcond_RULE", "") thm; val (p_tm, tri_tm) = (dest_birs_symb_exec o concl) thm; val (sys_old_tm,L_tm,Pi_tm) = dest_sysLPi tri_tm; @@ -339,58 +294,6 @@ in (* local *) (* ---------------------------------------------------------------------------------------- *) - (* get all mapped variable names *) - fun birs_env_varnames birs_tm = - let - val _ = if birs_state_is_normform birs_tm then () else - raise ERR "birs_env_varnames" "symbolic bir state is not in standard form"; - - val (_, env, _, _) = dest_birs_state birs_tm; - val mappings = (fst o listSyntax.dest_list o dest_birs_gen_env) env; - val varname_tms = List.map (fst o pairSyntax.dest_pair) mappings; - val varnames = List.map stringSyntax.fromHOLstring varname_tms; - (* make sure that varnames is distinct *) - val _ = if list_distinct gen_eq varnames then () else - raise ERR "birs_env_varnames" "state has one variable mapped twice"; - in - varnames - end; - - (* modify the environment *) - fun birs_env_CONV is_start conv birs_tm = - let - val _ = if birs_state_is_normform_gen is_start birs_tm then () else - raise ERR "birs_env_CONV" "symbolic bir state is not in standard form"; - - val (pc, env, status, pcond) = dest_birs_state birs_tm; - val env_new_thm = conv env; - in - REWRITE_CONV [env_new_thm] birs_tm - end - - (* move a certain mapping to the top *) - fun birs_env_var_top_CONV varname birs_tm = - (* TODO: should use birs_env_CONV false *) - let - val _ = if birs_state_is_normform birs_tm then () else - raise ERR "birs_env_var_top_CONV" "symbolic bir state is not in standard form"; - - val (pc, env, status, pcond) = dest_birs_state birs_tm; - val (mappings, mappings_ty) = (listSyntax.dest_list o dest_birs_gen_env) env; - val is_m_for_varname = (fn x => x = varname) o stringSyntax.fromHOLstring o fst o pairSyntax.dest_pair; - fun get_exp_if m = - if is_m_for_varname m then SOME m else NONE; - val m_o = List.foldl (fn (m, acc) => case acc of SOME x => SOME x | NONE => get_exp_if m) NONE mappings; - val m = valOf m_o handle _ => raise ERR "birs_env_var_top_CONV" "variable name not mapped in bir state"; - val mappings_new = m::(List.filter (not o is_m_for_varname) mappings); - - val env_new = (mk_birs_gen_env o listSyntax.mk_list) (mappings_new, mappings_ty); - val birs_new_tm = mk_birs_state (pc, env_new, status, pcond); - in - mk_oracle_thm "BIRS_ENVVARTOP" ([], mk_eq (birs_tm, birs_new_tm)) - end - handle _ => raise ERR "birs_env_var_top_CONV" "something uncaught"; - local val struct_CONV = RAND_CONV; @@ -404,35 +307,6 @@ in (* local *) LAND_CONV; fun second_CONV conv = RAND_CONV (first_CONV conv); - - local - open pred_setSyntax; - open pred_setTheory; - val rotate_first_INSERTs_thm = prove(`` - !x1 x2 xs. - (x1 INSERT x2 INSERT xs) = (x2 INSERT x1 INSERT xs) - ``, - fs [EXTENSION] >> - metis_tac [] - ); - fun is_two_INSERTs tm = (is_insert tm) andalso ((is_insert o snd o dest_insert) tm); - in - fun rotate_two_INSERTs_conv tm = - let - val _ = if is_two_INSERTs tm then () else - raise ERR "rotate_two_INSERTs_conv" "need to be a term made up of two inserts"; - val (x1_tm, x2xs_tm) = dest_insert tm; - val (x2_tm, xs_tm) = dest_insert x2xs_tm; - val inst_thm = ISPECL [x1_tm, x2_tm, xs_tm] rotate_first_INSERTs_thm; - in - inst_thm - end; - - fun rotate_INSERTs_conv tm = - (if not (is_two_INSERTs tm) then REFL else - (rotate_two_INSERTs_conv THENC - RAND_CONV rotate_INSERTs_conv)) tm; - end in (* apply state transformer to sys *) fun birs_sys_CONV conv tm = @@ -443,63 +317,86 @@ in (* local *) (struct_CONV (sys_CONV conv)) tm end; - (* apply state transformer to Pi *) - fun birs_Pi_CONV conv tm = + (* apply state transformer to L *) + fun birs_L_CONV conv tm = let val _ = if is_birs_symb_exec tm then () else - raise ERR "birs_Pi_CONV" "cannot handle term"; + raise ERR "birs_L_CONV" "cannot handle term"; in - (struct_CONV (Pi_CONV conv)) tm + struct_CONV (L_CONV conv) tm end; - (* apply state transformer to L *) - fun birs_L_CONV conv tm = + (* apply state transformer to Pi *) + fun birs_Pi_CONV conv tm = let val _ = if is_birs_symb_exec tm then () else - raise ERR "birs_L_CONV" "cannot handle term"; + raise ERR "birs_Pi_CONV" "cannot handle term"; in - struct_CONV (L_CONV conv) tm + (struct_CONV (Pi_CONV conv)) tm end; (* apply state transformer to first state in Pi *) + (* TODO: should check the number of states in Pi *) fun birs_Pi_first_CONV conv = birs_Pi_CONV (first_CONV conv); fun birs_Pi_second_CONV conv = birs_Pi_CONV (second_CONV conv); + end - (* swap the first two states in Pi *) - fun birs_Pi_rotate_two_RULE thm = - let - (*val _ = print "rotating first two in Pi\n";*) - val _ = if (symb_sound_struct_is_normform o concl) thm then () else - raise ERR "birs_Pi_rotate_two_RULE" "theorem is not a standard birs_symb_exec"; - val (_,_,Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) thm; - val num_Pi_el = (length o pred_setSyntax.strip_set) Pi_tm; - val _ = if num_Pi_el > 1 then () else - raise ERR "birs_Pi_rotate_two_RULE" "Pi has to have at least two states"; - - val res_thm = CONV_RULE (struct_CONV (Pi_CONV (rotate_two_INSERTs_conv))) thm; - (*val _ = print "finished rotating\n";*) - in - res_thm - end; + (* modify the environment *) + fun birs_env_CONV conv birs_tm = + let + val _ = birs_check_state_norm ("birs_env_CONV", "") birs_tm; + val env_new_thm = conv (dest_birs_state_env birs_tm); + in + (* better use EQ_MP? *) + REWRITE_CONV [env_new_thm] birs_tm + end - fun birs_Pi_rotate_RULE thm = - let - (*val _ = print "rotating elements of Pi\n";*) - val _ = if (symb_sound_struct_is_normform o concl) thm then () else - raise ERR "birs_Pi_rotate_RULE" "theorem is not a standard birs_symb_exec"; - val (_,_,Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) thm; - val num_Pi_el = (length o pred_setSyntax.strip_set) Pi_tm; - val _ = if num_Pi_el > 1 then () else - raise ERR "birs_Pi_rotate_RULE" "Pi has to have at least two states"; - - val res_thm = CONV_RULE (struct_CONV (Pi_CONV (rotate_INSERTs_conv))) thm; - (*val _ = print "finished rotating\n";*) - in - res_thm - end; - end + (* move a certain mapping to the top *) + fun birs_env_var_top_CONV varname birs_tm = + (* TODO: should use birs_env_CONV *) + let + val _ = birs_check_state_norm ("birs_env_var_top_CONV", "") birs_tm; + + val (pc, env, status, pcond) = dest_birs_state birs_tm; + val (mappings, mappings_ty) = (listSyntax.dest_list o dest_birs_gen_env) env; + val is_m_for_varname = (fn x => x = varname) o stringSyntax.fromHOLstring o fst o pairSyntax.dest_pair; + fun get_exp_if m = + if is_m_for_varname m then SOME m else NONE; + val m_o = List.foldl (fn (m, acc) => case acc of SOME x => SOME x | NONE => get_exp_if m) NONE mappings; + val m = valOf m_o handle _ => raise ERR "birs_env_var_top_CONV" "variable name not mapped in bir state"; + val mappings_new = m::(List.filter (not o is_m_for_varname) mappings); + + val env_new = (mk_birs_gen_env o listSyntax.mk_list) (mappings_new, mappings_ty); + val birs_new_tm = mk_birs_state (pc, env_new, status, pcond); + in + mk_oracle_thm "BIRS_ENVVARTOP" ([], mk_eq (birs_tm, birs_new_tm)) + end + handle _ => raise ERR "birs_env_var_top_CONV" "something uncaught"; + +(* ---------------------------------------------------------------------------------------- *) + + (* swap the first two states in Pi *) + fun birs_Pi_rotate_two_RULE thm = + let + val _ = birs_check_norm_thm ("birs_Pi_rotate_two_RULE", "") thm; + val _ = birs_check_min_Pi_thm 2 "birs_Pi_rotate_two_RULE" thm; + + val res_thm = CONV_RULE (birs_Pi_CONV (rotate_two_INSERTs_conv)) thm; + in + res_thm + end; + + fun birs_Pi_rotate_RULE thm = + let + val _ = birs_check_norm_thm ("birs_Pi_rotate_RULE", "") thm; + val _ = birs_check_min_Pi_thm 2 "birs_Pi_rotate_RULE" thm; + + val res_thm = CONV_RULE (birs_Pi_CONV (rotate_INSERTs_conv)) thm; + in + res_thm + end; (* goes through all Pi states and applies rule *) fun birs_Pi_each_RULE rule thm = @@ -518,6 +415,7 @@ in (* local *) end; (* ---------------------------------------------------------------------------------------- *) + local open bir_programSyntax; open optionSyntax; diff --git a/src/tools/symbexec/examples/test-birs_compose.sml b/src/tools/symbexec/examples/test-birs_compose.sml index 3a302d655..51bd40dcd 100644 --- a/src/tools/symbexec/examples/test-birs_compose.sml +++ b/src/tools/symbexec/examples/test-birs_compose.sml @@ -102,10 +102,9 @@ fun execute_two_steps bprog_tm birs_state_init_tm = (* first step *) val single_step_A_thm = birs_rule_STEP_fun_spec birs_state_init_tm; - val (_, _, Pi_A_tm) = (symb_sound_struct_get_sysLPi_fun o concl) single_step_A_thm; (* continue with a second step *) - val birs_states_mid = symb_sound_struct_Pi_to_birstatelist_fun Pi_A_tm; + val birs_states_mid = (get_birs_Pi_list o concl) single_step_A_thm; (* it would be better to find the running one, oh well *) val birs_state_mid = List.nth(birs_states_mid,0); diff --git a/src/tools/symbexec/examples/test-birs_transfer.sml b/src/tools/symbexec/examples/test-birs_transfer.sml index 9ff2ece9e..d9bd867de 100644 --- a/src/tools/symbexec/examples/test-birs_transfer.sml +++ b/src/tools/symbexec/examples/test-birs_transfer.sml @@ -100,7 +100,7 @@ val symb_analysis_thm = bir_symb_analysis bprog [birs_state_end_lbl] birs_state_init; val exec_thm = CONV_RULE (RAND_CONV (LAND_CONV (REWRITE_CONV [GSYM birs_env_thm]))) symb_analysis_thm; -val (sys_tm, L_tm, Pi_tm) = (symb_sound_struct_get_sysLPi_fun o concl) exec_thm; +val (sys_tm, L_tm, Pi_tm) = (get_birs_sysLPi o concl) exec_thm; (* ---------------------------------------------------------------------- *) From 2aed00182fcc83ce90573809a49edf596e5415cc Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Fri, 18 Oct 2024 21:48:44 +0200 Subject: [PATCH 83/95] Refactor symbolic execution and integration with, enabling refined symbolic execution (including handling of summaries) --- .../riscv/aes-unopt/aes_symb_execScript.sml | 4 +- examples/riscv/aes/aes_symb_execScript.sml | 6 +- examples/riscv/aes/test-aes.sml | 6 +- .../incr-mem/incr_mem_symb_execScript.sml | 6 +- .../incr-mem/incr_mem_symb_transfScript.sml | 2 +- examples/riscv/incr/incr_symb_execScript.sml | 6 +- .../riscv/incr/incr_symb_transfScript.sml | 3 +- .../riscv/isqrt/isqrt_symb_execScript.sml | 18 +-- .../riscv/isqrt/isqrt_symb_transfScript.sml | 6 +- .../mod2-mem/mod2_mem_symb_execScript.sml | 6 +- .../mod2-mem/mod2_mem_symb_transfScript.sml | 2 +- examples/riscv/mod2/mod2_symb_execScript.sml | 6 +- .../riscv/mod2/mod2_symb_transfScript.sml | 2 +- .../riscv/modexp/modexp_symb_execScript.sml | 2 +- .../riscv/motor/motor_symb_execScript.sml | 2 +- examples/riscv/swap/swap_symb_execScript.sml | 6 +- .../riscv/swap/swap_symb_transfScript.sml | 2 +- .../nestfunc_symb_execScript.sml | 2 +- .../storeload_symb_execScript.sml | 2 +- .../symbexec/bir_program_transfScript.sml | 20 +-- src/tools/symbexec/bir_symbLib.sig | 20 +-- src/tools/symbexec/bir_symbLib.sml | 119 +++++------------- src/tools/symbexec/birs_driveLib.sml | 114 ++++++++++++----- src/tools/symbexec/birs_strategiesLib.sml | 86 +++++++++++++ src/tools/symbexec/birs_transferLib.sml | 36 +++++- .../symbexec/examples/test-birs_transfer.sml | 22 +++- 26 files changed, 296 insertions(+), 210 deletions(-) create mode 100644 src/tools/symbexec/birs_strategiesLib.sml diff --git a/examples/riscv/aes-unopt/aes_symb_execScript.sml b/examples/riscv/aes-unopt/aes_symb_execScript.sml index 77bddf9f5..bbd2d3faa 100644 --- a/examples/riscv/aes-unopt/aes_symb_execScript.sml +++ b/examples/riscv/aes-unopt/aes_symb_execScript.sml @@ -20,9 +20,9 @@ val _ = birs_auxLib.prepare_program_lookups bir_lift_thm; (* --------------------------- *) (* turn on the store-store cheater *) -val _ = birs_simp_select := birs_simp_instancesLib.birs_simp_default_riscv_gen true; +val _ = birs_strategiesLib.birs_simp_select := birs_simp_instancesLib.birs_simp_default_riscv_gen true; -val (bsysprecond_thm, symb_analysis_thm) = +val symb_analysis_thm = bir_symb_analysis_thm bir_aes_prog_def aes_init_addr_def [aes_end_addr_def] diff --git a/examples/riscv/aes/aes_symb_execScript.sml b/examples/riscv/aes/aes_symb_execScript.sml index 6697f7ea8..59816d066 100644 --- a/examples/riscv/aes/aes_symb_execScript.sml +++ b/examples/riscv/aes/aes_symb_execScript.sml @@ -17,7 +17,7 @@ val _ = birs_auxLib.prepare_program_lookups bir_lift_thm; (* Symbolic analysis execution *) (* --------------------------- *) -val (bsysprecond_thm, symb_analysis_thm) = +val symb_analysis_thm = bir_symb_analysis_thm bir_aes_prog_def aes_init_addr_def [aes_end_addr_def] @@ -27,10 +27,6 @@ val (bsysprecond_thm, symb_analysis_thm) = val _ = show_tags := true; -val _ = Portable.pprint Tag.pp_tag (tag bsysprecond_thm); - -Theorem aes_bsysprecond_thm = bsysprecond_thm - val _ = Portable.pprint Tag.pp_tag (tag symb_analysis_thm); Theorem aes_symb_analysis_thm = symb_analysis_thm diff --git a/examples/riscv/aes/test-aes.sml b/examples/riscv/aes/test-aes.sml index dfd473a1e..339d23c17 100644 --- a/examples/riscv/aes/test-aes.sml +++ b/examples/riscv/aes/test-aes.sml @@ -12,7 +12,11 @@ open aes_symb_execTheory; (* for now we just have a leightweight check; this is to include aes into the test *) val _ = print "checking aes_symb_analysis_thm:\n"; -val _ = if term_size (concl aes_symb_analysis_thm) = 23173 then () else +val term_sz = term_size (concl aes_symb_analysis_thm); +val _ = print ("\nterm size = " ^ (Int.toString term_sz) ^ "\n\n"); +val expected_term_sz = 25198; + +val _ = if term_sz = expected_term_sz then () else raise Fail "term size of aes symbolic execution theorem is not as expected"; val triple_tm = ((snd o dest_comb o concl) aes_symb_analysis_thm); diff --git a/examples/riscv/incr-mem/incr_mem_symb_execScript.sml b/examples/riscv/incr-mem/incr_mem_symb_execScript.sml index 2c10fa054..0cf16d589 100644 --- a/examples/riscv/incr-mem/incr_mem_symb_execScript.sml +++ b/examples/riscv/incr-mem/incr_mem_symb_execScript.sml @@ -13,7 +13,7 @@ val _ = new_theory "incr_mem_symb_exec"; (* Symbolic analysis execution *) (* --------------------------- *) -val (bsysprecond_thm, symb_analysis_thm) = +val symb_analysis_thm = bir_symb_analysis_thm bir_incr_mem_prog_def incr_mem_init_addr_def [incr_mem_end_addr_def] @@ -21,10 +21,6 @@ val (bsysprecond_thm, symb_analysis_thm) = val _ = show_tags := true; -val _ = Portable.pprint Tag.pp_tag (tag bsysprecond_thm); - -Theorem incr_mem_bsysprecond_thm = bsysprecond_thm - val _ = Portable.pprint Tag.pp_tag (tag symb_analysis_thm); Theorem incr_mem_symb_analysis_thm = symb_analysis_thm diff --git a/examples/riscv/incr-mem/incr_mem_symb_transfScript.sml b/examples/riscv/incr-mem/incr_mem_symb_transfScript.sml index 3e0c578e2..aca8bc551 100644 --- a/examples/riscv/incr-mem/incr_mem_symb_transfScript.sml +++ b/examples/riscv/incr-mem/incr_mem_symb_transfScript.sml @@ -30,7 +30,7 @@ val bspec_cont_thm = bir_symb_transfer init_addr_tm end_addr_tm bspec_pre_tm bspec_post_tm bir_incr_mem_prog_def incr_mem_birenvtyl_def bspec_incr_mem_pre_def bspec_incr_mem_post_def incr_mem_prog_vars_list_def - incr_mem_symb_analysis_thm incr_mem_bsysprecond_thm incr_mem_prog_vars_thm; + incr_mem_symb_analysis_thm incr_mem_prog_vars_thm; Theorem bspec_cont_incr_mem: bir_cont bir_incr_mem_prog bir_exp_true diff --git a/examples/riscv/incr/incr_symb_execScript.sml b/examples/riscv/incr/incr_symb_execScript.sml index a1abec6b2..589e3aee1 100644 --- a/examples/riscv/incr/incr_symb_execScript.sml +++ b/examples/riscv/incr/incr_symb_execScript.sml @@ -13,7 +13,7 @@ val _ = new_theory "incr_symb_exec"; (* Symbolic analysis execution *) (* --------------------------- *) -val (bsysprecond_thm, symb_analysis_thm) = +val symb_analysis_thm = bir_symb_analysis_thm bir_incr_prog_def incr_init_addr_def [incr_end_addr_def] @@ -21,10 +21,6 @@ val (bsysprecond_thm, symb_analysis_thm) = val _ = show_tags := true; -val _ = Portable.pprint Tag.pp_tag (tag bsysprecond_thm); - -Theorem incr_bsysprecond_thm = bsysprecond_thm - val _ = Portable.pprint Tag.pp_tag (tag symb_analysis_thm); Theorem incr_symb_analysis_thm = symb_analysis_thm diff --git a/examples/riscv/incr/incr_symb_transfScript.sml b/examples/riscv/incr/incr_symb_transfScript.sml index 65bdaab1e..6ea5c5ec9 100644 --- a/examples/riscv/incr/incr_symb_transfScript.sml +++ b/examples/riscv/incr/incr_symb_transfScript.sml @@ -33,7 +33,6 @@ val bspec_pre_def = bspec_incr_pre_def; val bspec_post_def = bspec_incr_post_def; val prog_vars_list_def = incr_prog_vars_list_def; val symb_analysis_thm = incr_symb_analysis_thm; -val bsysprecond_thm = incr_bsysprecond_thm; val prog_vars_thm = incr_prog_vars_thm; *) @@ -41,7 +40,7 @@ val bspec_cont_thm = bir_symb_transfer init_addr_tm end_addr_tm bspec_pre_tm bspec_post_tm bir_incr_prog_def incr_birenvtyl_def bspec_incr_pre_def bspec_incr_post_def incr_prog_vars_list_def - incr_symb_analysis_thm incr_bsysprecond_thm incr_prog_vars_thm; + incr_symb_analysis_thm incr_prog_vars_thm; Theorem bspec_cont_incr: bir_cont bir_incr_prog bir_exp_true diff --git a/examples/riscv/isqrt/isqrt_symb_execScript.sml b/examples/riscv/isqrt/isqrt_symb_execScript.sml index fbf443413..4f0aee832 100644 --- a/examples/riscv/isqrt/isqrt_symb_execScript.sml +++ b/examples/riscv/isqrt/isqrt_symb_execScript.sml @@ -18,16 +18,12 @@ val _ = show_tags := true; (* before loop *) (* ----------- *) -val (bsysprecond_thm, symb_analysis_thm) = +val symb_analysis_thm = bir_symb_analysis_thm bir_isqrt_prog_def isqrt_init_addr_1_def [isqrt_end_addr_1_def] bspec_isqrt_pre_1_def isqrt_birenvtyl_def; -val _ = Portable.pprint Tag.pp_tag (tag bsysprecond_thm); - -Theorem isqrt_bsysprecond_1_thm = bsysprecond_thm - val _ = Portable.pprint Tag.pp_tag (tag symb_analysis_thm); Theorem isqrt_symb_analysis_1_thm = symb_analysis_thm @@ -36,16 +32,12 @@ Theorem isqrt_symb_analysis_1_thm = symb_analysis_thm (* loop body *) (* --------- *) -val (bsysprecond_thm, symb_analysis_thm) = +val symb_analysis_thm = bir_symb_analysis_thm bir_isqrt_prog_def isqrt_init_addr_2_def [isqrt_end_addr_2_def] bspec_isqrt_pre_2_def isqrt_birenvtyl_def; -val _ = Portable.pprint Tag.pp_tag (tag bsysprecond_thm); - -Theorem isqrt_bsysprecond_2_thm = bsysprecond_thm - val _ = Portable.pprint Tag.pp_tag (tag symb_analysis_thm); Theorem isqrt_symb_analysis_2_thm = symb_analysis_thm @@ -54,16 +46,12 @@ Theorem isqrt_symb_analysis_2_thm = symb_analysis_thm (* loop branch *) (* ----------- *) -val (bsysprecond_thm, symb_analysis_thm) = +val symb_analysis_thm = bir_symb_analysis_thm bir_isqrt_prog_def isqrt_init_addr_3_def [isqrt_end_addr_3_loop_def, isqrt_end_addr_3_ret_def] bspec_isqrt_pre_3_def isqrt_birenvtyl_def; -val _ = Portable.pprint Tag.pp_tag (tag bsysprecond_thm); - -Theorem isqrt_bsysprecond_3_thm = bsysprecond_thm - val _ = Portable.pprint Tag.pp_tag (tag symb_analysis_thm); Theorem isqrt_symb_analysis_3_thm = symb_analysis_thm diff --git a/examples/riscv/isqrt/isqrt_symb_transfScript.sml b/examples/riscv/isqrt/isqrt_symb_transfScript.sml index 902e5eb56..ca12fb5a1 100644 --- a/examples/riscv/isqrt/isqrt_symb_transfScript.sml +++ b/examples/riscv/isqrt/isqrt_symb_transfScript.sml @@ -23,7 +23,7 @@ val bspec_cont_1_thm = bir_isqrt_prog_def isqrt_init_addr_1_def isqrt_end_addr_1_def bspec_isqrt_pre_1_def bspec_isqrt_post_1_def isqrt_birenvtyl_def isqrt_prog_vars_list_def - isqrt_symb_analysis_1_thm isqrt_bsysprecond_1_thm isqrt_prog_vars_thm; + isqrt_symb_analysis_1_thm isqrt_prog_vars_thm; val init_addr_1_tm = (snd o dest_eq o concl) isqrt_init_addr_1_def; val end_addr_1_tm = (snd o dest_eq o concl) isqrt_end_addr_1_def; @@ -48,7 +48,7 @@ val bspec_cont_2_thm = bir_isqrt_prog_def isqrt_init_addr_2_def isqrt_end_addr_2_def bspec_isqrt_pre_2_def bspec_isqrt_post_2_def isqrt_birenvtyl_def isqrt_prog_vars_list_def - isqrt_symb_analysis_2_thm isqrt_bsysprecond_2_thm isqrt_prog_vars_thm; + isqrt_symb_analysis_2_thm isqrt_prog_vars_thm; val init_addr_2_tm = (snd o dest_eq o concl) isqrt_init_addr_2_def; val end_addr_2_tm = (snd o dest_eq o concl) isqrt_end_addr_2_def; @@ -74,7 +74,7 @@ val bspec_cont_3_thm = isqrt_init_addr_3_def isqrt_end_addr_3_loop_def isqrt_end_addr_3_ret_def bspec_isqrt_pre_3_def bspec_isqrt_post_3_loop_def bspec_isqrt_post_3_ret_def isqrt_birenvtyl_def isqrt_prog_vars_list_def - isqrt_symb_analysis_3_thm isqrt_bsysprecond_3_thm isqrt_prog_vars_thm; + isqrt_symb_analysis_3_thm isqrt_prog_vars_thm; val init_addr_tm = (snd o dest_eq o concl) isqrt_init_addr_3_def; val end_addr_1_tm = (snd o dest_eq o concl) isqrt_end_addr_3_loop_def; diff --git a/examples/riscv/mod2-mem/mod2_mem_symb_execScript.sml b/examples/riscv/mod2-mem/mod2_mem_symb_execScript.sml index a1a509706..b12378435 100644 --- a/examples/riscv/mod2-mem/mod2_mem_symb_execScript.sml +++ b/examples/riscv/mod2-mem/mod2_mem_symb_execScript.sml @@ -12,7 +12,7 @@ val _ = new_theory "mod2_mem_symb_exec"; (* Symbolic analysis execution *) (* --------------------------- *) -val (bsysprecond_thm, symb_analysis_thm) = +val symb_analysis_thm = bir_symb_analysis_thm bir_mod2_mem_prog_def mod2_mem_init_addr_def [mod2_mem_end_addr_def] @@ -20,10 +20,6 @@ val (bsysprecond_thm, symb_analysis_thm) = val _ = show_tags := true; -val _ = Portable.pprint Tag.pp_tag (tag bsysprecond_thm); - -Theorem mod2_mem_bsysprecond_thm = bsysprecond_thm - val _ = Portable.pprint Tag.pp_tag (tag symb_analysis_thm); Theorem mod2_mem_symb_analysis_thm = symb_analysis_thm diff --git a/examples/riscv/mod2-mem/mod2_mem_symb_transfScript.sml b/examples/riscv/mod2-mem/mod2_mem_symb_transfScript.sml index 7b26324e6..74d851de6 100644 --- a/examples/riscv/mod2-mem/mod2_mem_symb_transfScript.sml +++ b/examples/riscv/mod2-mem/mod2_mem_symb_transfScript.sml @@ -30,7 +30,7 @@ val bspec_cont_thm = bir_symb_transfer init_addr_tm end_addr_tm bspec_pre_tm bspec_post_tm bir_mod2_mem_prog_def mod2_mem_birenvtyl_def bspec_mod2_mem_pre_def bspec_mod2_mem_post_def mod2_mem_prog_vars_list_def - mod2_mem_symb_analysis_thm mod2_mem_bsysprecond_thm mod2_mem_prog_vars_thm; + mod2_mem_symb_analysis_thm mod2_mem_prog_vars_thm; Theorem bspec_cont_mod2_mem: bir_cont bir_mod2_mem_prog bir_exp_true diff --git a/examples/riscv/mod2/mod2_symb_execScript.sml b/examples/riscv/mod2/mod2_symb_execScript.sml index 0b58e52dd..3858aa2ce 100644 --- a/examples/riscv/mod2/mod2_symb_execScript.sml +++ b/examples/riscv/mod2/mod2_symb_execScript.sml @@ -12,7 +12,7 @@ val _ = new_theory "mod2_symb_exec"; (* Symbolic analysis execution *) (* --------------------------- *) -val (bsysprecond_thm, symb_analysis_thm) = +val symb_analysis_thm = bir_symb_analysis_thm bir_mod2_prog_def mod2_init_addr_def [mod2_end_addr_def] @@ -20,10 +20,6 @@ val (bsysprecond_thm, symb_analysis_thm) = val _ = show_tags := true; -val _ = Portable.pprint Tag.pp_tag (tag bsysprecond_thm); - -Theorem mod2_bsysprecond_thm = bsysprecond_thm - val _ = Portable.pprint Tag.pp_tag (tag symb_analysis_thm); Theorem mod2_symb_analysis_thm = symb_analysis_thm diff --git a/examples/riscv/mod2/mod2_symb_transfScript.sml b/examples/riscv/mod2/mod2_symb_transfScript.sml index 4b76df71d..06494b58d 100644 --- a/examples/riscv/mod2/mod2_symb_transfScript.sml +++ b/examples/riscv/mod2/mod2_symb_transfScript.sml @@ -30,7 +30,7 @@ val bspec_cont_thm = bir_symb_transfer init_addr_tm end_addr_tm bspec_pre_tm bspec_post_tm bir_mod2_prog_def mod2_birenvtyl_def bspec_mod2_pre_def bspec_mod2_post_def mod2_prog_vars_list_def - mod2_symb_analysis_thm mod2_bsysprecond_thm mod2_prog_vars_thm; + mod2_symb_analysis_thm mod2_prog_vars_thm; Theorem bspec_cont_mod2: bir_cont bir_mod2_prog bir_exp_true diff --git a/examples/riscv/modexp/modexp_symb_execScript.sml b/examples/riscv/modexp/modexp_symb_execScript.sml index 075c96426..27ff963a0 100644 --- a/examples/riscv/modexp/modexp_symb_execScript.sml +++ b/examples/riscv/modexp/modexp_symb_execScript.sml @@ -13,7 +13,7 @@ val _ = new_theory "modexp_symb_exec"; (* Symbolic analysis execution *) (* --------------------------- *) -val (bsysprecond_thm, symb_analysis_thm) = +val symb_analysis_thm = bir_symb_analysis_thm bir_modexp_prog_def modexp_init_addr_def [modexp_end_addr_def] diff --git a/examples/riscv/motor/motor_symb_execScript.sml b/examples/riscv/motor/motor_symb_execScript.sml index 691f53acd..5e5d8e7bd 100644 --- a/examples/riscv/motor/motor_symb_execScript.sml +++ b/examples/riscv/motor/motor_symb_execScript.sml @@ -20,7 +20,7 @@ val _ = birs_auxLib.prepare_program_lookups bir_lift_thm; (* Symbolic analysis execution *) (* --------------------------- *) -val (bsysprecond_thm, symb_analysis_thm) = +val symb_analysis_thm = bir_symb_analysis_thm bir_motor_prog_def motor_init_addr_def [motor_end_addr_def] diff --git a/examples/riscv/swap/swap_symb_execScript.sml b/examples/riscv/swap/swap_symb_execScript.sml index f2a338fbc..a193f86ad 100644 --- a/examples/riscv/swap/swap_symb_execScript.sml +++ b/examples/riscv/swap/swap_symb_execScript.sml @@ -13,7 +13,7 @@ val _ = new_theory "swap_symb_exec"; (* Symbolic analysis execution *) (* --------------------------- *) -val (bsysprecond_thm, symb_analysis_thm) = +val symb_analysis_thm = bir_symb_analysis_thm bir_swap_prog_def swap_init_addr_def [swap_end_addr_def] @@ -21,10 +21,6 @@ val (bsysprecond_thm, symb_analysis_thm) = val _ = show_tags := true; -val _ = Portable.pprint Tag.pp_tag (tag bsysprecond_thm); - -Theorem swap_bsysprecond_thm = bsysprecond_thm - val _ = Portable.pprint Tag.pp_tag (tag symb_analysis_thm); Theorem swap_symb_analysis_thm = symb_analysis_thm diff --git a/examples/riscv/swap/swap_symb_transfScript.sml b/examples/riscv/swap/swap_symb_transfScript.sml index c0883e173..051a217cc 100644 --- a/examples/riscv/swap/swap_symb_transfScript.sml +++ b/examples/riscv/swap/swap_symb_transfScript.sml @@ -30,7 +30,7 @@ val bspec_cont_thm = bir_symb_transfer init_addr_tm end_addr_tm bspec_pre_tm bspec_post_tm bir_swap_prog_def swap_birenvtyl_def bspec_swap_pre_def bspec_swap_post_def swap_prog_vars_list_def - swap_symb_analysis_thm swap_bsysprecond_thm swap_prog_vars_thm; + swap_symb_analysis_thm swap_prog_vars_thm; Theorem bspec_cont_swap: bir_cont bir_swap_prog bir_exp_true diff --git a/examples/riscv/symbexectests/nestfunc_symb_execScript.sml b/examples/riscv/symbexectests/nestfunc_symb_execScript.sml index e893ee0be..934643305 100644 --- a/examples/riscv/symbexectests/nestfunc_symb_execScript.sml +++ b/examples/riscv/symbexectests/nestfunc_symb_execScript.sml @@ -20,7 +20,7 @@ val _ = birs_auxLib.prepare_program_lookups bir_lift_thm; (* Symbolic analysis execution *) (* --------------------------- *) -val (bsysprecond_thm, symb_analysis_thm) = +val symb_analysis_thm = bir_symb_analysis_thm bir_nestfunc_prog_def nestfunc_init_addr_def [nestfunc_end_addr_def] diff --git a/examples/riscv/symbexectests/storeload_symb_execScript.sml b/examples/riscv/symbexectests/storeload_symb_execScript.sml index 4ef92984e..5c8b409d9 100644 --- a/examples/riscv/symbexectests/storeload_symb_execScript.sml +++ b/examples/riscv/symbexectests/storeload_symb_execScript.sml @@ -20,7 +20,7 @@ val _ = birs_auxLib.prepare_program_lookups bir_lift_thm; (* Symbolic analysis execution *) (* --------------------------- *) -val (bsysprecond_thm, symb_analysis_thm) = +val symb_analysis_thm = bir_symb_analysis_thm bir_storeload_prog_def storeload_init_addr_def [storeload_end_addr_def] diff --git a/src/tools/symbexec/bir_program_transfScript.sml b/src/tools/symbexec/bir_program_transfScript.sml index 3003624db..dd165ee56 100644 --- a/src/tools/symbexec/bir_program_transfScript.sml +++ b/src/tools/symbexec/bir_program_transfScript.sml @@ -1229,17 +1229,17 @@ Proof METIS_TAC [m0_mod_vars_def, bir_lifting_machinesTheory.m0_mod_bmr_vars_EVAL, bir_lifting_machinesTheory.m0_mod_bmr_temp_vars_EVAL] QED -Definition birenvtyl_def: - birenvtyl = MAP BVarToPair m0_mod_vars +Definition birenvtyl_armcm0_def: + birenvtyl_armcm0 = MAP BVarToPair m0_mod_vars End -(* birenvtyl = [("R7", BType_Imm Bit32); ("SP_process", BType_Imm Bit32); ("countw", BType_Imm Bit64)]*) +(* birenvtyl_armcm0 = [("R7", BType_Imm Bit32); ("SP_process", BType_Imm Bit32); ("countw", BType_Imm Bit64)]*) (* bir_lifting_machinesTheory.m0_mod_REGS_lifted_imms_LIST_def m0_mod_REGS_lifted_imms_LIST m0_mod_lifted_mem bir_lifting_machinesTheory.m0_mod_bmr_vars_EVAL *) -Theorem birenvtyl_EVAL_thm = (REWRITE_CONV [birenvtyl_def, m0_mod_vars_def, bir_lifting_machinesTheory.m0_mod_bmr_vars_EVAL, bir_lifting_machinesTheory.m0_mod_bmr_temp_vars_EVAL] THENC EVAL) ``birenvtyl`` +Theorem birenvtyl_armcm0_EVAL_thm = (REWRITE_CONV [birenvtyl_armcm0_def, m0_mod_vars_def, bir_lifting_machinesTheory.m0_mod_bmr_vars_EVAL, bir_lifting_machinesTheory.m0_mod_bmr_temp_vars_EVAL] THENC EVAL) ``birenvtyl_armcm0`` (* ---------------------------------------------------------------------------------------------------------------- *) (* ---------------------------------------------------------------------------------------------------------------- *) @@ -1269,7 +1269,7 @@ Theorem backlift_bir_m0_mod_EXISTS_thm: ?bs. ( (bmr_rel (m0_mod_bmr bmropt) bs ms) /\ (bs.bst_status = BST_Running) /\ - (bir_envty_list_b birenvtyl bs.bst_environ) + (bir_envty_list_b birenvtyl_armcm0 bs.bst_environ) ) Proof REPEAT STRIP_TAC >> @@ -1369,7 +1369,7 @@ Proof Q.UNABBREV_TAC `bs` >> FULL_SIMP_TAC (std_ss++holBACore_ss) [] >> - FULL_SIMP_TAC (std_ss) [birenvtyl_EVAL_thm, birs_auxTheory.bir_envty_list_b_thm] >> + FULL_SIMP_TAC (std_ss) [birenvtyl_armcm0_EVAL_thm, birs_auxTheory.bir_envty_list_b_thm] >> FULL_SIMP_TAC (std_ss) [birs_auxTheory.bir_envty_list_def] >> @@ -1419,7 +1419,7 @@ Definition backlift_bir_m0_mod_pre_abstr_def: (bmr_rel (m0_mod_bmr (F,T)) bs ms) ==> (pre ms) ==> (bs.bst_status = BST_Running) ==> - (bir_envty_list_b birenvtyl bs.bst_environ) ==> + (bir_envty_list_b birenvtyl_armcm0 bs.bst_environ) ==> (pre_bir bs) End @@ -1783,11 +1783,11 @@ REPEAT STRIP_TAC >> [alpha |-> Type`:bir_state_t`, beta |-> Type`:bir_label_t`, delta |-> Type`:word32`] backlift_contract_GEN_thm) >> - POP_ASSUM (ASSUME_TAC o Q.SPECL [`\ms bs. bs.bst_status = BST_Running /\ (bir_envty_list_b birenvtyl bs.bst_environ)`, `(\ms. \bs. (bmr_rel (m0_mod_bmr (F,T)) bs ms))`]) >> + POP_ASSUM (ASSUME_TAC o Q.SPECL [`\ms bs. bs.bst_status = BST_Running /\ (bir_envty_list_b birenvtyl_armcm0 bs.bst_environ)`, `(\ms. \bs. (bmr_rel (m0_mod_bmr (F,T)) bs ms))`]) >> FULL_SIMP_TAC std_ss [backlift_bir_m0_mod_EXISTS_thm] >> `!ms bs. - (bs.bst_status = BST_Running /\ bir_envty_list_b birenvtyl bs.bst_environ) ==> + (bs.bst_status = BST_Running /\ bir_envty_list_b birenvtyl_armcm0 bs.bst_environ) ==> bmr_rel (m0_mod_bmr (F,T)) bs ms ==> (bir_ts p).ctrl bs = (\l. BL_Address (Imm32 l)) (m0_mod_weak_model.ctrl ms)` by ( @@ -1799,7 +1799,7 @@ REPEAT STRIP_TAC >> bmr_rel (m0_mod_bmr (F,T)) bs ms ==> pre ms ==> bs.bst_status = BST_Running /\ - bir_envty_list_b birenvtyl bs.bst_environ ==> + bir_envty_list_b birenvtyl_armcm0 bs.bst_environ ==> pre_bir bs` by ( METIS_TAC [] ) >> diff --git a/src/tools/symbexec/bir_symbLib.sig b/src/tools/symbexec/bir_symbLib.sig index 142d94433..23bf310b9 100644 --- a/src/tools/symbexec/bir_symbLib.sig +++ b/src/tools/symbexec/bir_symbLib.sig @@ -3,31 +3,21 @@ sig include Abbrev; - val birs_simp_select : (term -> thm) ref; - - val pcond_gen_symb : term; - - val bir_symb_analysis_init_gen : term option -> term -> term -> thm -> term * thm * thm; - - val bir_symb_analysis : term -> term list -> term -> thm; - - val bir_symb_analysis_thm : thm -> thm -> thm list -> thm -> thm -> thm * thm; - - val bir_symb_analysis_thm_gen : term option -> thm -> thm -> thm list -> thm -> thm -> thm * thm; + val bir_symb_analysis_thm : thm -> thm -> thm list -> thm -> thm -> thm; val bir_symb_transfer : term -> term -> term -> term -> thm -> thm -> thm -> thm -> thm -> - thm -> thm -> thm -> + thm -> thm -> thm; val bir_symb_transfer_thm : thm -> thm -> thm -> thm -> thm -> thm -> thm -> - thm -> thm -> thm -> + thm -> thm -> thm; val bir_symb_transfer_two : @@ -35,7 +25,7 @@ sig term -> term -> term -> thm -> thm -> thm -> thm -> thm -> thm -> - thm -> thm -> thm -> + thm -> thm -> thm; val bir_symb_transfer_two_thm : @@ -43,7 +33,7 @@ sig thm -> thm -> thm -> thm -> thm -> thm -> thm -> thm -> - thm -> thm -> thm -> + thm -> thm -> thm; end diff --git a/src/tools/symbexec/bir_symbLib.sml b/src/tools/symbexec/bir_symbLib.sml index a2e01c79b..c1bf84841 100644 --- a/src/tools/symbexec/bir_symbLib.sml +++ b/src/tools/symbexec/bir_symbLib.sml @@ -13,77 +13,9 @@ local open bitTheory; open birs_auxTheory; open bir_immSyntax; - - local - open bir_programSyntax; - open optionSyntax; - fun is_SOME_BStmtB_BStmt_Assign t = is_some t andalso (is_BStmtB o dest_some) t andalso (is_BStmt_Assign o dest_BStmtB o dest_some) t; - in - fun apply_if_assign tm f = - if is_SOME_BStmtB_BStmt_Assign tm then - f - else - I; - end in -(* TODO: later make the whole post step function a parameter to the symb_analysis function *) -val birs_simp_select = ref birs_simp_instancesLib.birs_simp_default_riscv; - -val pcond_gen_symb = ``BVar "syp_gen" (BType_Imm Bit1)``; - -fun bir_symb_analysis_init_gen pcond_symb_o birs_state_init_lbl bspec_pre_tm birenvtyl_def = - let - val bprog_envtyl_tm = (fst o dest_eq o concl) birenvtyl_def; - - val bsysprecond_tm_f = Option.getOpt (Option.map (fn tm => fn x => ``BExp_BinExp BIExp_And (^x) (BExp_Den (^tm))``) pcond_symb_o, I); - val mk_bsysprecond_pcond_thm = - (computeLib.RESTR_EVAL_CONV [``birs_eval_exp``] THENC birs_stepLib.birs_eval_exp_CONV) - (bsysprecond_tm_f ``mk_bsysprecond ^bspec_pre_tm ^bprog_envtyl_tm``); - val birs_pcond_tm = (snd o dest_eq o concl) mk_bsysprecond_pcond_thm; - - val senv_GEN_list_thm = (REWRITE_CONV [birenvtyl_def] THENC EVAL THENC REWRITE_CONV [GSYM birs_gen_env_thm, GSYM birs_gen_env_NULL_thm]) ``bir_senv_GEN_list ^bprog_envtyl_tm``; - val birs_env_tm = (snd o dest_eq o concl) senv_GEN_list_thm; - - val pcond_is_sat = bir_smtLib.bir_smt_check_sat false birs_pcond_tm; - val _ = if pcond_is_sat then () else - raise ERR "bir_symb_analysis_init_gen" "initial pathcondition is not satisfiable; it seems to contain a contradiction"; - - val birs_state_init = ``<| - bsst_pc := ^birs_state_init_lbl; - bsst_environ := ^birs_env_tm; - bsst_status := BST_Running; - bsst_pcond := ^birs_pcond_tm - |>``; - in - (birs_state_init, senv_GEN_list_thm, mk_bsysprecond_pcond_thm) - end; - -fun bir_symb_analysis bprog_tm birs_end_lbls birs_state = - let - val timer_symbanalysis = holba_miscLib.timer_start 0; - val timer_symbanalysis_last = ref (holba_miscLib.timer_start 0); - - open birs_execLib; - val birs_rule_SUBST_thm = birs_rule_SUBST_prog_fun bprog_tm; - fun birs_post_step_fun (t, (last_pc, last_stmt)) = ( - (fn t => ( - holba_miscLib.timer_stop (fn delta_s => print ("running since " ^ delta_s ^ "\n")) timer_symbanalysis; - holba_miscLib.timer_stop (fn delta_s => print ("time since last step " ^ delta_s ^ "\n")) (!timer_symbanalysis_last); - timer_symbanalysis_last := holba_miscLib.timer_start 0; - (*print_term ((last o pairSyntax.strip_pair o snd o dest_comb o concl) t);*) - t)) o - apply_if_assign last_stmt (birs_rule_SUBST_trysimp_fun birs_rule_SUBST_thm (!birs_simp_select)) o - birs_rule_tryprune_fun birs_rulesTheory.branch_prune1_spec_thm o - birs_rule_tryprune_fun birs_rulesTheory.branch_prune2_spec_thm o - birs_rule_tryjustassert_fun true - ) t; - in - birs_driveLib.bir_symb_exec_to (bprog_tm, birs_post_step_fun) birs_end_lbls birs_state - end (* let *) - - -fun bir_symb_analysis_thm_gen pcond_symb_o bir_prog_def +fun bir_symb_analysis_thm bir_prog_def init_addr_def end_addr_defs bspec_pre_def birenvtyl_def = let @@ -92,7 +24,7 @@ fun bir_symb_analysis_thm_gen pcond_symb_o bir_prog_def val bprog_tm = (fst o dest_eq o concl) bir_prog_def; val init_addr_tm = (snd o dest_eq o concl) init_addr_def; - val birs_state_init_lbl_tm = + val init_lbl = (snd o dest_eq o concl o EVAL) ``bir_block_pc (BL_Address ^(gen_mk_Imm init_addr_tm))``; val birs_state_end_tm_lbls = List.map @@ -102,19 +34,22 @@ fun bir_symb_analysis_thm_gen pcond_symb_o bir_prog_def end) end_addr_defs; val bspec_pre_tm = (lhs o snd o strip_forall o concl) bspec_pre_def; - val (birs_state_init, birs_env_thm, bsysprecond_thm) = - bir_symb_analysis_init_gen pcond_symb_o birs_state_init_lbl_tm bspec_pre_tm birenvtyl_def; - val symb_analysis_thm = bir_symb_analysis - bprog_tm birs_state_end_tm_lbls birs_state_init; - val symb_analysis_fix_thm = CONV_RULE (RAND_CONV (LAND_CONV (REWRITE_CONV [GSYM birs_env_thm]))) symb_analysis_thm; + val birs_state_init = + birs_driveLib.birs_analysis_init birenvtyl_def bspec_pre_tm init_lbl; + + val symb_analysis_thm = + birs_driveLib.birs_exec_to + bprog_tm + (birs_strategiesLib.birs_post_step_riscv_default) + (fn _ => NONE) + (birs_strategiesLib.not_at_lbls birs_state_end_tm_lbls) + birs_state_init; val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n======\n > bir_symb_analysis_thm took " ^ delta_s ^ "\n")) timer; in - (bsysprecond_thm, symb_analysis_fix_thm) + symb_analysis_thm end (* let *) -val bir_symb_analysis_thm = bir_symb_analysis_thm_gen NONE; - end (* local *) local @@ -152,8 +87,15 @@ fun bir_symb_transfer bspec_pre_tm bspec_post_tm bir_prog_def birenvtyl_def bspec_pre_def bspec_post_def prog_vars_list_def - symb_analysis_thm bsysprecond_thm prog_vars_thm = - let + symb_analysis_thm prog_vars_thm = + let + val (bsysprecond_thm, symb_analysis_thm) = + birs_transferLib.prepare_transfer + birenvtyl_def + ``BExp_Const (Imm1 1w)`` + ((lhs o snd o strip_forall o concl) bspec_pre_def) + symb_analysis_thm; + val birs_state_ss = rewrites (type_rws ``:birs_state_t``); val bprog_tm = (fst o dest_eq o concl) bir_prog_def; val prog_vars_list_tm = (fst o dest_eq o concl) prog_vars_list_def; @@ -368,7 +310,7 @@ fun bir_symb_transfer_thm bir_prog_def init_addr_def end_addr_def bspec_pre_def bspec_post_def birenvtyl_def prog_vars_list_def - symb_analysis_thm bsysprecond_thm prog_vars_thm = + symb_analysis_thm prog_vars_thm = let val init_addr_tm = (snd o dest_eq o concl) init_addr_def; val end_addr_tm = (snd o dest_eq o concl) end_addr_def; @@ -380,7 +322,7 @@ fun bir_symb_transfer_thm bspec_pre_tm bspec_post_tm bir_prog_def birenvtyl_def bspec_pre_def bspec_post_def prog_vars_list_def - symb_analysis_thm bsysprecond_thm prog_vars_thm + symb_analysis_thm prog_vars_thm end (* let *) end (* local *) @@ -420,8 +362,15 @@ fun bir_symb_transfer_two bspec_pre_tm bspec_post_1_tm bspec_post_2_tm bir_prog_def birenvtyl_def bspec_pre_def bspec_post_1_def bspec_post_2_def prog_vars_list_def - symb_analysis_thm bsysprecond_thm prog_vars_thm = + symb_analysis_thm prog_vars_thm = let + val (bsysprecond_thm, symb_analysis_thm) = + birs_transferLib.prepare_transfer + birenvtyl_def + ``BExp_Const (Imm1 1w)`` + ((lhs o snd o strip_forall o concl) bspec_pre_def) + symb_analysis_thm; + val birs_state_ss = rewrites (type_rws ``:birs_state_t``); val bprog_tm = (fst o dest_eq o concl) bir_prog_def; val prog_vars_list_tm = (fst o dest_eq o concl) prog_vars_list_def; @@ -688,7 +637,7 @@ fun bir_symb_transfer_two_thm init_addr_def end_addr_1_def end_addr_2_def bspec_pre_def bspec_post_1_def bspec_post_2_def birenvtyl_def prog_vars_list_def - symb_analysis_thm bsysprecond_thm prog_vars_thm = + symb_analysis_thm prog_vars_thm = let val init_addr_tm = (snd o dest_eq o concl) init_addr_def; val end_addr_1_tm = (snd o dest_eq o concl) end_addr_1_def; @@ -702,7 +651,7 @@ fun bir_symb_transfer_two_thm bspec_pre_tm bspec_post_1_tm bspec_post_2_tm bir_prog_def birenvtyl_def bspec_pre_def bspec_post_1_def bspec_post_2_def prog_vars_list_def - symb_analysis_thm bsysprecond_thm prog_vars_thm + symb_analysis_thm prog_vars_thm end (* let *) end (* local *) diff --git a/src/tools/symbexec/birs_driveLib.sml b/src/tools/symbexec/birs_driveLib.sml index f43950d95..e28e58636 100644 --- a/src/tools/symbexec/birs_driveLib.sml +++ b/src/tools/symbexec/birs_driveLib.sml @@ -109,48 +109,50 @@ in (* local *) (birs_check_state_norm ("build_tree", "") st; build_tree_rec exec_funs (take_step exec_funs st)); - fun exec_until exec_funs comp_fun = + fun exec_until (exec_funs, comp_fun) = (Profile.profile "reduce_tree" (reduce_tree comp_fun)) o (Profile.profile "build_tree" (build_tree exec_funs)); - (* ----------------------------------------------------------------------------- *) - - fun not_stop_lbl stop_lbls st = - not (List.exists (identical (dest_birs_state_pc st)) stop_lbls); - - fun bir_symb_exec_to (bprog_tm, birs_post_step_fun) birs_end_lbls birs_state = +(* ----------------------------------------------------------------------------- *) + + fun prep_exec bprog_tm post_step_fun fetch is_continue = let - val _ = birs_check_state_norm ("bir_symb_exec_to", "") birs_state; - open birs_execLib; - val birs_rule_STEP_thm = birs_rule_STEP_prog_fun (Profile.profile "bir_prog_has_no_halt_fun" bir_prog_has_no_halt_fun bprog_tm); - val birs_rule_STEP_fun_spec = - (birs_post_step_fun o - birs_rule_STEP_fun birs_rule_STEP_thm); - (* now the composition *) - val birs_rule_SEQ_thm = birs_rule_SEQ_prog_fun bprog_tm; - val birs_rule_SEQ_fun_spec = birs_rule_SEQ_fun birs_rule_SEQ_thm; - (*val _ = print_thm single_step_A_thm;*) - (* and also the sequential composition *) + val birs_rule_STEP_thm = + birs_rule_STEP_prog_fun + (Profile.profile "bir_prog_has_no_halt_fun" bir_prog_has_no_halt_fun bprog_tm); val birs_rule_STEP_SEQ_thm = MATCH_MP birs_rulesTheory.birs_rule_STEP_SEQ_gen_thm (bir_prog_has_no_halt_fun bprog_tm); - val birs_rule_STEP_SEQ_fun_spec = - (birs_post_step_fun o + val birs_rule_SEQ_thm = birs_rule_SEQ_prog_fun bprog_tm; + val birs_rule_SUBST_thm = birs_rule_SUBST_prog_fun bprog_tm; + + val step = + (post_step_fun (birs_rule_SUBST_thm) o + birs_rule_STEP_fun birs_rule_STEP_thm); + val comp_fun = birs_rule_SEQ_fun birs_rule_SEQ_thm; + val step_SING = + (post_step_fun (birs_rule_SUBST_thm) o birs_rule_STEP_SEQ_fun birs_rule_STEP_SEQ_thm); - + (* val fetch = fn _ => NONE; - (*val fetch = fn _ => SOME TRUTH;*) - (*val fetch = fn x => SOME (birs_rule_STEP_fun_spec x);*) + (*val fetch = fn x => SOME (step x);*) val is_continue = not_stop_lbl birs_end_lbls; + *) + in + ((fetch, step_SING, step, is_continue), + comp_fun) + end; + fun birs_exec_to bprog_tm post_step_fun fetch is_continue birs_state = + let + val _ = birs_check_state_norm ("birs_exec_to", "") birs_state; + + val exec_params = prep_exec bprog_tm post_step_fun fetch is_continue; val _ = print "now reducing it to one sound structure\n"; val timer = holba_miscLib.timer_start 0; - val result = exec_until - (fetch, birs_rule_STEP_SEQ_fun_spec, birs_rule_STEP_fun_spec, is_continue) - birs_rule_SEQ_fun_spec - birs_state + val result = exec_until exec_params birs_state handle e => (Profile.print_profile_results (Profile.results ()); raise e); val _ = holba_miscLib.timer_stop (fn delta_s => print ("\n======\n > exec_until took " ^ delta_s ^ "\n")) timer; @@ -164,7 +166,63 @@ in (* local *) in result end; - val bir_symb_exec_to = fn x => fn y => Profile.profile "bir_symb_exec_to" (bir_symb_exec_to x y); + val birs_exec_to = fn x1 => fn x2 => fn x3 => fn x4 => Profile.profile "birs_exec_to" (birs_exec_to x1 x2 x3 x4); + +(* ----------------------------------------------------------------------------- *) + + val pcond_gen_symb = ``BVar "syp_gen" (BType_Imm Bit1)``; + fun mk_pcond_gen pcond = + let + (* TODO: check that pcond_gen_symb does not appear in pcond *) + in + ``BExp_BinExp BIExp_And (^pcond) (BExp_Den (^pcond_gen_symb))`` + end; + + fun birs_init env pcond init_lbl = + let + (* TODO: check that env is norm *) + + val pcond_is_sat = bir_smtLib.bir_smt_check_sat false pcond; + val _ = if pcond_is_sat then () else + raise ERR "birs_init" "initial pathcondition is not satisfiable; it seems to contain a contradiction"; + + val st = ``<| + bsst_pc := ^init_lbl; + bsst_environ := ^env; + bsst_status := BST_Running; + bsst_pcond := ^(mk_pcond_gen pcond) + |>``; + in + st + end; + +(* ----------------------------------------------------------------------------- *) + + fun gen_birs_env_thm birenvtyl_def = + let + open birs_auxTheory; + val bprog_envtyl_tm = (fst o dest_eq o concl) birenvtyl_def; + in + (REWRITE_CONV [birenvtyl_def] THENC EVAL THENC REWRITE_CONV [GSYM birs_gen_env_thm, GSYM birs_gen_env_NULL_thm]) ``bir_senv_GEN_list ^bprog_envtyl_tm`` + end; + val gen_birs_env = (rhs o concl o gen_birs_env_thm); + + fun gen_birs_pcond_thm birenvtyl_def bpre = + let + val bprog_envtyl_tm = (fst o dest_eq o concl) birenvtyl_def; + + val mk_bsysprecond_pcond_thm = + (computeLib.RESTR_EVAL_CONV [``birs_eval_exp``] THENC birs_stepLib.birs_eval_exp_CONV) + (``mk_bsysprecond ^bpre ^bprog_envtyl_tm``); + in + mk_bsysprecond_pcond_thm + end; + fun gen_birs_pcond birenvtyl_def = (rhs o concl o gen_birs_pcond_thm birenvtyl_def); + + fun birs_analysis_init birenvtyl_def bpre init_lbl = + birs_init (gen_birs_env birenvtyl_def) (gen_birs_pcond birenvtyl_def bpre) init_lbl; + + (* ----------------------------------------------------------------------------- *) end (* local *) diff --git a/src/tools/symbexec/birs_strategiesLib.sml b/src/tools/symbexec/birs_strategiesLib.sml new file mode 100644 index 000000000..b560c5051 --- /dev/null +++ b/src/tools/symbexec/birs_strategiesLib.sml @@ -0,0 +1,86 @@ +structure birs_strategiesLib = +struct + +local + + open HolKernel Parse boolLib bossLib; + + open birsSyntax; + open birs_utilsLib; + + (* error handling *) + val libname = "birs_strategiesLib" + val ERR = Feedback.mk_HOL_ERR libname + val wrap_exn = Feedback.wrap_exn libname + +in (* local *) + + fun not_at_lbls stop_lbls st = + not (List.exists (identical (dest_birs_state_pc st)) stop_lbls); + + (* TODO: later make the whole post step function a parameter to the symb_analysis function *) + val birs_simp_select = ref birs_simp_instancesLib.birs_simp_default_riscv; + + fun birs_post_step_riscv_default (birs_rule_SUBST_thm) = + let + val timer_symbanalysis = holba_miscLib.timer_start 0; + val timer_symbanalysis_last = ref (holba_miscLib.timer_start 0); + + open birs_execLib; + fun birs_post_step_fun (t, (last_pc, last_stmt)) = ( + (fn t => ( + holba_miscLib.timer_stop (fn delta_s => print ("running since " ^ delta_s ^ "\n")) timer_symbanalysis; + holba_miscLib.timer_stop (fn delta_s => print ("time since last step " ^ delta_s ^ "\n")) (!timer_symbanalysis_last); + timer_symbanalysis_last := holba_miscLib.timer_start 0; + (*print_term ((last o pairSyntax.strip_pair o snd o dest_comb o concl) t);*) + t)) o + birs_if_assign_RULE last_stmt (birs_rule_SUBST_trysimp_fun birs_rule_SUBST_thm (!birs_simp_select)) o + birs_rule_tryprune_fun birs_rulesTheory.branch_prune1_spec_thm o + birs_rule_tryprune_fun birs_rulesTheory.branch_prune2_spec_thm o + birs_rule_tryjustassert_fun true + ) t; + in + birs_post_step_fun + end; + + fun birs_post_step_armcm0_default (birs_rule_SUBST_thm) = + let + open birs_simp_instancesLib; + val birs_simp_select = birs_simp_default_armcm0_gen true; + val birs_simp_select_ifthenelse = birs_simp_default_core_exp_simp; + open holba_miscLib; + + val timer_symbanalysis = timer_start 0; + val timer_symbanalysis_last = ref (timer_start 0); + fun debug_output_RULE t = + (timer_stop (fn delta_s => print ("running since " ^ delta_s ^ "\n")) timer_symbanalysis; + timer_stop (fn delta_s => print ("time since last step " ^ delta_s ^ "\n")) (!timer_symbanalysis_last); + timer_symbanalysis_last := timer_start 0; + (*print_term ((last o pairSyntax.strip_pair o snd o dest_comb o concl) t);*) + t); + + open birs_execLib; + val birs_simp_RULE_gen = birs_rule_SUBST_trysimp_fun birs_rule_SUBST_thm; + fun birs_simp_RULE last_stmt = + ((* the ifthenelse simplification for countw assignments before branches, that gets applied after the branch happens and the condition is available in the branchcondition *) + birs_if_branch_RULE (birs_simp_RULE_gen (birs_simp_select_ifthenelse)) o + (* the simplification after assignments *) + birs_if_assign_RULE last_stmt (birs_simp_RULE_gen (birs_simp_select))); + val birs_prune_RULE = + (birs_rule_tryprune_fun birs_rulesTheory.branch_prune1_spec_thm o + birs_rule_tryprune_fun birs_rulesTheory.branch_prune2_spec_thm o + birs_rule_tryjustassert_fun true); + + fun birs_post_step_fun (t, (last_pc, last_stmt)) = ( + debug_output_RULE o + (*(apply_if_branch debug_Pi_fun) o*) + birs_simp_RULE last_stmt o + birs_prune_RULE + ) t; + in + birs_post_step_fun + end; + +end (* local *) + +end (* struct *) diff --git a/src/tools/symbexec/birs_transferLib.sml b/src/tools/symbexec/birs_transferLib.sml index 643dad1ee..0e4bcadb8 100644 --- a/src/tools/symbexec/birs_transferLib.sml +++ b/src/tools/symbexec/birs_transferLib.sml @@ -5,12 +5,7 @@ local open HolKernel Parse boolLib bossLib; - - (* error handling *) - val libname = "bir_symb_transferLib" - val ERR = Feedback.mk_HOL_ERR libname - val wrap_exn = Feedback.wrap_exn libname - +(* open birs_stepLib; open symb_recordTheory; @@ -27,9 +22,38 @@ open birs_composeLib; open birs_auxTheory; val birs_state_ss = rewrites (type_rws ``:birs_state_t``); +*) + + (* error handling *) + val libname = "birs_transferLib" + val ERR = Feedback.mk_HOL_ERR libname + val wrap_exn = Feedback.wrap_exn libname in +fun prepare_transfer birenvtyl_def pcond_inst bpre symb_analysis_thm = + let + val prog_env_thm = birs_driveLib.gen_birs_env_thm birenvtyl_def; + val prog_pcond_thm = birs_driveLib.gen_birs_pcond_thm birenvtyl_def bpre; + val pcond_tm = (rhs o concl) prog_pcond_thm; + + (* first remove generic path condition symbol *) + open birs_instantiationLib; + open birs_utilsLib; + val specd_symb_analysis_thm = birs_sound_symb_inst_RULE [(birs_driveLib.pcond_gen_symb, pcond_inst)] symb_analysis_thm; + val pcond_symb_analysis_thm = birs_sys_pcond_RULE pcond_tm specd_symb_analysis_thm; + + (* then fix the initial state *) + val fixed_symb_analysis_thm = CONV_RULE (birs_sys_CONV (REWRITE_CONV [GSYM prog_env_thm])) pcond_symb_analysis_thm; + val _ = print "\n\n"; + val _ = print_thm prog_pcond_thm; + val _ = print "\n\n"; + val _ = print_thm fixed_symb_analysis_thm; + val _ = print "\n\n"; + in + (prog_pcond_thm, fixed_symb_analysis_thm) + end; + end (* local *) diff --git a/src/tools/symbexec/examples/test-birs_transfer.sml b/src/tools/symbexec/examples/test-birs_transfer.sml index d9bd867de..e6d97b195 100644 --- a/src/tools/symbexec/examples/test-birs_transfer.sml +++ b/src/tools/symbexec/examples/test-birs_transfer.sml @@ -94,11 +94,23 @@ val bprecond_def = Define ` `; val bprecond = (fst o dest_eq o concl) bprecond_def; -val (birs_state_init, birs_env_thm, bsysprecond_thm) = - bir_symb_analysis_init_gen NONE birs_state_init_lbl bprecond birenvtyl_def; -val symb_analysis_thm = bir_symb_analysis - bprog [birs_state_end_lbl] birs_state_init; -val exec_thm = CONV_RULE (RAND_CONV (LAND_CONV (REWRITE_CONV [GSYM birs_env_thm]))) symb_analysis_thm; + val birs_state_init = + birs_driveLib.birs_analysis_init birenvtyl_def bprecond birs_state_init_lbl; + + val symb_analysis_thm = + birs_driveLib.birs_exec_to + bprog + (birs_strategiesLib.birs_post_step_riscv_default) + (fn _ => NONE) + (birs_strategiesLib.not_at_lbls [birs_state_end_lbl]) + birs_state_init; + + val (bsysprecond_thm, exec_thm) = + birs_transferLib.prepare_transfer + birenvtyl_def + ``BExp_Const (Imm1 1w)`` + ((lhs o snd o strip_forall o concl) bprecond_def) + symb_analysis_thm; val (sys_tm, L_tm, Pi_tm) = (get_birs_sysLPi o concl) exec_thm; From 5c7669eb24729f6143c60e56e62856fbbd7d1635 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sat, 19 Oct 2024 12:31:13 +0200 Subject: [PATCH 84/95] Fix --- examples/tutorial/8-symbexec/test-symbexec.sml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/examples/tutorial/8-symbexec/test-symbexec.sml b/examples/tutorial/8-symbexec/test-symbexec.sml index eaa4e0195..7ce0cb17a 100644 --- a/examples/tutorial/8-symbexec/test-symbexec.sml +++ b/examples/tutorial/8-symbexec/test-symbexec.sml @@ -80,7 +80,7 @@ val bspec_tutorial_pre_def = Define `bspec_tutorial_pre : bir_exp_t = ^precond`; (* Symbolic analysis execution *) (* --------------------------- *) -val (bsysprecond_thm, symb_analysis_thm) = +val symb_analysis_thm = bir_symb_analysis_thm bir_tutorial_prog_def tutorial_init_addr_def [tutorial_end_addr_def] @@ -97,8 +97,8 @@ val _ = print_thm symb_analysis_thm; (* ============================================================= *) (* check leafs *) -val (sys_i, L_s, Pi_f) = (get_birs_sysLPi o concl) symb_analysis_thm; -val leafs = (pred_setSyntax.strip_set o snd o dest_comb) Pi_f; +val (sys_i, L_s, Pi) = (get_birs_sysLPi o concl) symb_analysis_thm; +val leafs = pred_setSyntax.strip_set Pi; val _ = print "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n" val _ = print "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n" val _ = print ("number of leafs: " ^ (Int.toString (length leafs)) ^ "\n\n"); @@ -123,7 +123,7 @@ fun get_init_vals wtm = end; (* compute concrete states from path conditions using SMT-solver *) -val wtms = List.map (bir_exp_to_wordsLib.bir2bool o (fn (_,_,_,pcond_tm) => pcond_tm) o dest_birs_state) leafs; +val wtms = List.map (bir_exp_to_wordsLib.bir2bool o dest_birs_state_pcond) leafs; val states = List.map get_init_vals wtms; From 087eb8acec2e09a4a08d88577c7a70379762bbf6 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sat, 19 Oct 2024 12:37:42 +0200 Subject: [PATCH 85/95] Generalize symbolic execution transfer with parameter for generic symbol instantiation --- .../incr-mem/incr_mem_symb_transfScript.sml | 2 +- .../riscv/incr/incr_symb_transfScript.sml | 3 ++- .../riscv/isqrt/isqrt_symb_transfScript.sml | 6 ++--- .../mod2-mem/mod2_mem_symb_transfScript.sml | 2 +- .../riscv/mod2/mod2_symb_transfScript.sml | 2 +- .../riscv/swap/swap_symb_transfScript.sml | 2 +- src/tools/symbexec/bir_symbLib.sig | 8 +++---- src/tools/symbexec/bir_symbLib.sml | 24 ++++++++++++------- 8 files changed, 29 insertions(+), 20 deletions(-) diff --git a/examples/riscv/incr-mem/incr_mem_symb_transfScript.sml b/examples/riscv/incr-mem/incr_mem_symb_transfScript.sml index aca8bc551..12b96aa5f 100644 --- a/examples/riscv/incr-mem/incr_mem_symb_transfScript.sml +++ b/examples/riscv/incr-mem/incr_mem_symb_transfScript.sml @@ -30,7 +30,7 @@ val bspec_cont_thm = bir_symb_transfer init_addr_tm end_addr_tm bspec_pre_tm bspec_post_tm bir_incr_mem_prog_def incr_mem_birenvtyl_def bspec_incr_mem_pre_def bspec_incr_mem_post_def incr_mem_prog_vars_list_def - incr_mem_symb_analysis_thm incr_mem_prog_vars_thm; + incr_mem_symb_analysis_thm NONE incr_mem_prog_vars_thm; Theorem bspec_cont_incr_mem: bir_cont bir_incr_mem_prog bir_exp_true diff --git a/examples/riscv/incr/incr_symb_transfScript.sml b/examples/riscv/incr/incr_symb_transfScript.sml index 6ea5c5ec9..3b04017b4 100644 --- a/examples/riscv/incr/incr_symb_transfScript.sml +++ b/examples/riscv/incr/incr_symb_transfScript.sml @@ -33,6 +33,7 @@ val bspec_pre_def = bspec_incr_pre_def; val bspec_post_def = bspec_incr_post_def; val prog_vars_list_def = incr_prog_vars_list_def; val symb_analysis_thm = incr_symb_analysis_thm; +val pcond_gen_inst_o = NONE; val prog_vars_thm = incr_prog_vars_thm; *) @@ -40,7 +41,7 @@ val bspec_cont_thm = bir_symb_transfer init_addr_tm end_addr_tm bspec_pre_tm bspec_post_tm bir_incr_prog_def incr_birenvtyl_def bspec_incr_pre_def bspec_incr_post_def incr_prog_vars_list_def - incr_symb_analysis_thm incr_prog_vars_thm; + incr_symb_analysis_thm NONE incr_prog_vars_thm; Theorem bspec_cont_incr: bir_cont bir_incr_prog bir_exp_true diff --git a/examples/riscv/isqrt/isqrt_symb_transfScript.sml b/examples/riscv/isqrt/isqrt_symb_transfScript.sml index ca12fb5a1..cbef91b9c 100644 --- a/examples/riscv/isqrt/isqrt_symb_transfScript.sml +++ b/examples/riscv/isqrt/isqrt_symb_transfScript.sml @@ -23,7 +23,7 @@ val bspec_cont_1_thm = bir_isqrt_prog_def isqrt_init_addr_1_def isqrt_end_addr_1_def bspec_isqrt_pre_1_def bspec_isqrt_post_1_def isqrt_birenvtyl_def isqrt_prog_vars_list_def - isqrt_symb_analysis_1_thm isqrt_prog_vars_thm; + isqrt_symb_analysis_1_thm NONE isqrt_prog_vars_thm; val init_addr_1_tm = (snd o dest_eq o concl) isqrt_init_addr_1_def; val end_addr_1_tm = (snd o dest_eq o concl) isqrt_end_addr_1_def; @@ -48,7 +48,7 @@ val bspec_cont_2_thm = bir_isqrt_prog_def isqrt_init_addr_2_def isqrt_end_addr_2_def bspec_isqrt_pre_2_def bspec_isqrt_post_2_def isqrt_birenvtyl_def isqrt_prog_vars_list_def - isqrt_symb_analysis_2_thm isqrt_prog_vars_thm; + isqrt_symb_analysis_2_thm NONE isqrt_prog_vars_thm; val init_addr_2_tm = (snd o dest_eq o concl) isqrt_init_addr_2_def; val end_addr_2_tm = (snd o dest_eq o concl) isqrt_end_addr_2_def; @@ -74,7 +74,7 @@ val bspec_cont_3_thm = isqrt_init_addr_3_def isqrt_end_addr_3_loop_def isqrt_end_addr_3_ret_def bspec_isqrt_pre_3_def bspec_isqrt_post_3_loop_def bspec_isqrt_post_3_ret_def isqrt_birenvtyl_def isqrt_prog_vars_list_def - isqrt_symb_analysis_3_thm isqrt_prog_vars_thm; + isqrt_symb_analysis_3_thm NONE isqrt_prog_vars_thm; val init_addr_tm = (snd o dest_eq o concl) isqrt_init_addr_3_def; val end_addr_1_tm = (snd o dest_eq o concl) isqrt_end_addr_3_loop_def; diff --git a/examples/riscv/mod2-mem/mod2_mem_symb_transfScript.sml b/examples/riscv/mod2-mem/mod2_mem_symb_transfScript.sml index 74d851de6..22bd99c0e 100644 --- a/examples/riscv/mod2-mem/mod2_mem_symb_transfScript.sml +++ b/examples/riscv/mod2-mem/mod2_mem_symb_transfScript.sml @@ -30,7 +30,7 @@ val bspec_cont_thm = bir_symb_transfer init_addr_tm end_addr_tm bspec_pre_tm bspec_post_tm bir_mod2_mem_prog_def mod2_mem_birenvtyl_def bspec_mod2_mem_pre_def bspec_mod2_mem_post_def mod2_mem_prog_vars_list_def - mod2_mem_symb_analysis_thm mod2_mem_prog_vars_thm; + mod2_mem_symb_analysis_thm NONE mod2_mem_prog_vars_thm; Theorem bspec_cont_mod2_mem: bir_cont bir_mod2_mem_prog bir_exp_true diff --git a/examples/riscv/mod2/mod2_symb_transfScript.sml b/examples/riscv/mod2/mod2_symb_transfScript.sml index 06494b58d..deee448ee 100644 --- a/examples/riscv/mod2/mod2_symb_transfScript.sml +++ b/examples/riscv/mod2/mod2_symb_transfScript.sml @@ -30,7 +30,7 @@ val bspec_cont_thm = bir_symb_transfer init_addr_tm end_addr_tm bspec_pre_tm bspec_post_tm bir_mod2_prog_def mod2_birenvtyl_def bspec_mod2_pre_def bspec_mod2_post_def mod2_prog_vars_list_def - mod2_symb_analysis_thm mod2_prog_vars_thm; + mod2_symb_analysis_thm NONE mod2_prog_vars_thm; Theorem bspec_cont_mod2: bir_cont bir_mod2_prog bir_exp_true diff --git a/examples/riscv/swap/swap_symb_transfScript.sml b/examples/riscv/swap/swap_symb_transfScript.sml index 051a217cc..e6d5d1756 100644 --- a/examples/riscv/swap/swap_symb_transfScript.sml +++ b/examples/riscv/swap/swap_symb_transfScript.sml @@ -30,7 +30,7 @@ val bspec_cont_thm = bir_symb_transfer init_addr_tm end_addr_tm bspec_pre_tm bspec_post_tm bir_swap_prog_def swap_birenvtyl_def bspec_swap_pre_def bspec_swap_post_def swap_prog_vars_list_def - swap_symb_analysis_thm swap_prog_vars_thm; + swap_symb_analysis_thm NONE swap_prog_vars_thm; Theorem bspec_cont_swap: bir_cont bir_swap_prog bir_exp_true diff --git a/src/tools/symbexec/bir_symbLib.sig b/src/tools/symbexec/bir_symbLib.sig index 23bf310b9..47c834ad7 100644 --- a/src/tools/symbexec/bir_symbLib.sig +++ b/src/tools/symbexec/bir_symbLib.sig @@ -10,14 +10,14 @@ sig term -> term -> thm -> thm -> thm -> thm -> thm -> - thm -> thm -> + thm -> term option -> thm -> thm; val bir_symb_transfer_thm : thm -> thm -> thm -> thm -> thm -> thm -> thm -> - thm -> thm -> + thm -> term option -> thm -> thm; val bir_symb_transfer_two : @@ -25,7 +25,7 @@ sig term -> term -> term -> thm -> thm -> thm -> thm -> thm -> thm -> - thm -> thm -> + thm -> term option -> thm -> thm; val bir_symb_transfer_two_thm : @@ -33,7 +33,7 @@ sig thm -> thm -> thm -> thm -> thm -> thm -> thm -> thm -> - thm -> thm -> + thm -> term option -> thm -> thm; end diff --git a/src/tools/symbexec/bir_symbLib.sml b/src/tools/symbexec/bir_symbLib.sml index c1bf84841..8af4ab4ea 100644 --- a/src/tools/symbexec/bir_symbLib.sml +++ b/src/tools/symbexec/bir_symbLib.sml @@ -87,12 +87,16 @@ fun bir_symb_transfer bspec_pre_tm bspec_post_tm bir_prog_def birenvtyl_def bspec_pre_def bspec_post_def prog_vars_list_def - symb_analysis_thm prog_vars_thm = + symb_analysis_thm pcond_gen_inst_o prog_vars_thm = let + val pcond_gen_inst = + case pcond_gen_inst_o of + SOME x => x + | NONE => ``BExp_Const (Imm1 1w)``; val (bsysprecond_thm, symb_analysis_thm) = birs_transferLib.prepare_transfer birenvtyl_def - ``BExp_Const (Imm1 1w)`` + pcond_gen_inst ((lhs o snd o strip_forall o concl) bspec_pre_def) symb_analysis_thm; @@ -310,7 +314,7 @@ fun bir_symb_transfer_thm bir_prog_def init_addr_def end_addr_def bspec_pre_def bspec_post_def birenvtyl_def prog_vars_list_def - symb_analysis_thm prog_vars_thm = + symb_analysis_thm pcond_gen_inst_o prog_vars_thm = let val init_addr_tm = (snd o dest_eq o concl) init_addr_def; val end_addr_tm = (snd o dest_eq o concl) end_addr_def; @@ -322,7 +326,7 @@ fun bir_symb_transfer_thm bspec_pre_tm bspec_post_tm bir_prog_def birenvtyl_def bspec_pre_def bspec_post_def prog_vars_list_def - symb_analysis_thm prog_vars_thm + symb_analysis_thm pcond_gen_inst_o prog_vars_thm end (* let *) end (* local *) @@ -362,12 +366,16 @@ fun bir_symb_transfer_two bspec_pre_tm bspec_post_1_tm bspec_post_2_tm bir_prog_def birenvtyl_def bspec_pre_def bspec_post_1_def bspec_post_2_def prog_vars_list_def - symb_analysis_thm prog_vars_thm = + symb_analysis_thm pcond_gen_inst_o prog_vars_thm = let + val pcond_gen_inst = + case pcond_gen_inst_o of + SOME x => x + | NONE => ``BExp_Const (Imm1 1w)``; val (bsysprecond_thm, symb_analysis_thm) = birs_transferLib.prepare_transfer birenvtyl_def - ``BExp_Const (Imm1 1w)`` + pcond_gen_inst ((lhs o snd o strip_forall o concl) bspec_pre_def) symb_analysis_thm; @@ -637,7 +645,7 @@ fun bir_symb_transfer_two_thm init_addr_def end_addr_1_def end_addr_2_def bspec_pre_def bspec_post_1_def bspec_post_2_def birenvtyl_def prog_vars_list_def - symb_analysis_thm prog_vars_thm = + symb_analysis_thm pcond_gen_inst_o prog_vars_thm = let val init_addr_tm = (snd o dest_eq o concl) init_addr_def; val end_addr_1_tm = (snd o dest_eq o concl) end_addr_1_def; @@ -651,7 +659,7 @@ fun bir_symb_transfer_two_thm bspec_pre_tm bspec_post_1_tm bspec_post_2_tm bir_prog_def birenvtyl_def bspec_pre_def bspec_post_1_def bspec_post_2_def prog_vars_list_def - symb_analysis_thm prog_vars_thm + symb_analysis_thm pcond_gen_inst_o prog_vars_thm end (* let *) end (* local *) From bfcde330001f1cd12bafe38fe2235d1c810320c5 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sat, 19 Oct 2024 12:40:41 +0200 Subject: [PATCH 86/95] Fix (untested) --- examples/riscv/chacha/chacha_symb_exec_ivsetupScript.sml | 6 +----- examples/riscv/chacha/chacha_symb_exec_keysetupScript.sml | 6 +----- examples/riscv/ifelse/ifelse_symb_execScript.sml | 6 +----- .../riscv/poly1305-inlined/poly1305_symb_execScript.sml | 6 +----- examples/riscv/poly1305/poly1305_symb_execScript.sml | 6 +----- 5 files changed, 5 insertions(+), 25 deletions(-) diff --git a/examples/riscv/chacha/chacha_symb_exec_ivsetupScript.sml b/examples/riscv/chacha/chacha_symb_exec_ivsetupScript.sml index eea5874e8..78b2f2813 100644 --- a/examples/riscv/chacha/chacha_symb_exec_ivsetupScript.sml +++ b/examples/riscv/chacha/chacha_symb_exec_ivsetupScript.sml @@ -18,16 +18,12 @@ val _ = show_tags := true; (* ivsetup *) (* ------- *) -val (bsysprecond_thm, symb_analysis_thm) = +val symb_analysis_thm = bir_symb_analysis_thm bir_chacha_prog_def chacha_ivsetup_init_addr_def [chacha_ivsetup_end_addr_def] bspec_chacha_ivsetup_pre_def chacha_birenvtyl_def; -val _ = Portable.pprint Tag.pp_tag (tag bsysprecond_thm); - -Theorem chacha_ivsetup_bsysprecond_thm = bsysprecond_thm - val _ = Portable.pprint Tag.pp_tag (tag symb_analysis_thm); Theorem chacha_ivsetup_symb_analysis_thm = symb_analysis_thm diff --git a/examples/riscv/chacha/chacha_symb_exec_keysetupScript.sml b/examples/riscv/chacha/chacha_symb_exec_keysetupScript.sml index fae722243..b8ff312b1 100644 --- a/examples/riscv/chacha/chacha_symb_exec_keysetupScript.sml +++ b/examples/riscv/chacha/chacha_symb_exec_keysetupScript.sml @@ -18,16 +18,12 @@ val _ = show_tags := true; (* keysetup *) (* -------- *) -val (bsysprecond_thm, symb_analysis_thm) = +val symb_analysis_thm = bir_symb_analysis_thm bir_chacha_prog_def chacha_keysetup_init_addr_def [chacha_keysetup_end_addr_def] bspec_chacha_keysetup_pre_def chacha_birenvtyl_def; -val _ = Portable.pprint Tag.pp_tag (tag bsysprecond_thm); - -Theorem chacha_keysetup_bsysprecond_thm = bsysprecond_thm - val _ = Portable.pprint Tag.pp_tag (tag symb_analysis_thm); Theorem chacha_keysetup_symb_analysis_thm = symb_analysis_thm diff --git a/examples/riscv/ifelse/ifelse_symb_execScript.sml b/examples/riscv/ifelse/ifelse_symb_execScript.sml index 8f83e9441..3003f7ad0 100644 --- a/examples/riscv/ifelse/ifelse_symb_execScript.sml +++ b/examples/riscv/ifelse/ifelse_symb_execScript.sml @@ -14,16 +14,12 @@ val _ = new_theory "ifelse_symb_exec"; val _ = show_tags := true; -val (bsysprecond_thm, symb_analysis_thm) = +val symb_analysis_thm = bir_symb_analysis_thm bir_ifelse_prog_def ifelse_init_addr_def [ifelse_end_addr_def] bspec_ifelse_pre_def ifelse_birenvtyl_def; -val _ = Portable.pprint Tag.pp_tag (tag bsysprecond_thm); - -Theorem ifelse_bsysprecond_thm = bsysprecond_thm - val _ = Portable.pprint Tag.pp_tag (tag symb_analysis_thm); Theorem ifelse_symb_analysis_thm = symb_analysis_thm diff --git a/examples/riscv/poly1305-inlined/poly1305_symb_execScript.sml b/examples/riscv/poly1305-inlined/poly1305_symb_execScript.sml index 88500df7c..d9742ec1a 100644 --- a/examples/riscv/poly1305-inlined/poly1305_symb_execScript.sml +++ b/examples/riscv/poly1305-inlined/poly1305_symb_execScript.sml @@ -18,16 +18,12 @@ val _ = show_tags := true; (* init *) (* ------ *) -val (bsysprecond_thm, symb_analysis_thm) = +val symb_analysis_thm = bir_symb_analysis_thm bir_poly1305_prog_def poly1305_init_init_addr_def [poly1305_init_end_addr_def] bspec_poly1305_init_pre_def poly1305_birenvtyl_def; -val _ = Portable.pprint Tag.pp_tag (tag bsysprecond_thm); - -Theorem poly1305_init_bsysprecond_thm = bsysprecond_thm - val _ = Portable.pprint Tag.pp_tag (tag symb_analysis_thm); Theorem poly1305_init_symb_analysis_thm = symb_analysis_thm diff --git a/examples/riscv/poly1305/poly1305_symb_execScript.sml b/examples/riscv/poly1305/poly1305_symb_execScript.sml index 393fe9e67..d772dfe51 100644 --- a/examples/riscv/poly1305/poly1305_symb_execScript.sml +++ b/examples/riscv/poly1305/poly1305_symb_execScript.sml @@ -18,16 +18,12 @@ val _ = show_tags := true; (* U8TO32 *) (* ------ *) -val (bsysprecond_thm, symb_analysis_thm) = +val symb_analysis_thm = bir_symb_analysis_thm bir_poly1305_prog_def poly1305_u8to32_init_addr_def [poly1305_u8to32_end_addr_def] bspec_poly1305_u8to32_pre_def poly1305_birenvtyl_def; -val _ = Portable.pprint Tag.pp_tag (tag bsysprecond_thm); - -Theorem poly1305_u8to32_bsysprecond_thm = bsysprecond_thm - val _ = Portable.pprint Tag.pp_tag (tag symb_analysis_thm); Theorem poly1305_u8to32_symb_analysis_thm = symb_analysis_thm From b6eb479e1a6371db9de6b5dfda11c7970df9b0b4 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 21 Oct 2024 22:52:56 +0200 Subject: [PATCH 87/95] Add instantiation of summaries during symbolic execution --- src/tools/symbexec/bir_symbLib.sml | 14 ++++- src/tools/symbexec/birsSyntax.sml | 14 +++++ src/tools/symbexec/birs_composeLib.sml | 4 ++ src/tools/symbexec/birs_driveLib.sml | 15 +++-- src/tools/symbexec/birs_instantiationLib.sml | 45 +++++++++------ src/tools/symbexec/birs_intervalLib.sml | 21 ++++++- src/tools/symbexec/birs_stepLib.sml | 9 ++- src/tools/symbexec/birs_strategiesLib.sml | 35 ++++++++++++ src/tools/symbexec/birs_transferLib.sml | 5 +- src/tools/symbexec/birs_utilsLib.sml | 57 ++++++++++++------- .../symbexec/distribute_generic_stuffLib.sml | 24 +++++--- 11 files changed, 185 insertions(+), 58 deletions(-) diff --git a/src/tools/symbexec/bir_symbLib.sml b/src/tools/symbexec/bir_symbLib.sml index 8af4ab4ea..64c9288d4 100644 --- a/src/tools/symbexec/bir_symbLib.sml +++ b/src/tools/symbexec/bir_symbLib.sml @@ -41,7 +41,7 @@ fun bir_symb_analysis_thm bir_prog_def birs_driveLib.birs_exec_to bprog_tm (birs_strategiesLib.birs_post_step_riscv_default) - (fn _ => NONE) + (birs_strategiesLib.birs_from_summaries_riscv []) (birs_strategiesLib.not_at_lbls birs_state_end_tm_lbls) birs_state_init; @@ -121,7 +121,11 @@ fun bir_symb_transfer val birs_state_init_pre_EQ_thm = prove (``^(sys_i) = ^birs_state_init_pre_tm``, REWRITE_TAC [birs_state_init_pre_GEN_def, mk_bsysprecond_def, bsysprecond_thm] >> - CONV_TAC (computeLib.RESTR_EVAL_CONV [``birs_eval_exp``] THENC birs_stepLib.birs_eval_exp_CONV)); + CONV_TAC ( + computeLib.RESTR_EVAL_CONV [birs_eval_exp_tm] THENC + REWRITE_CONV [GSYM birs_gen_env_thm, GSYM birs_gen_env_NULL_thm] THENC + birs_auxLib.GEN_match_conv is_birs_eval_exp birs_stepLib.birs_eval_exp_CONV THENC + EVAL)); val analysis_thm = REWRITE_RULE [birs_state_init_pre_EQ_thm, GSYM bir_prog_def] symb_analysis_thm; @@ -401,7 +405,11 @@ fun bir_symb_transfer_two val birs_state_init_pre_EQ_thm = prove (``^(sys_i) = ^birs_state_init_pre_tm``, REWRITE_TAC [birs_state_init_pre_GEN_def, mk_bsysprecond_def, bsysprecond_thm] >> - CONV_TAC (computeLib.RESTR_EVAL_CONV [``birs_eval_exp``] THENC birs_stepLib.birs_eval_exp_CONV)); + CONV_TAC ( + computeLib.RESTR_EVAL_CONV [birs_eval_exp_tm] THENC + REWRITE_CONV [GSYM birs_gen_env_thm, GSYM birs_gen_env_NULL_thm] THENC + birs_auxLib.GEN_match_conv is_birs_eval_exp birs_stepLib.birs_eval_exp_CONV THENC + EVAL)); val analysis_thm = REWRITE_RULE [birs_state_init_pre_EQ_thm, GSYM bir_prog_def] symb_analysis_thm; diff --git a/src/tools/symbexec/birsSyntax.sml b/src/tools/symbexec/birsSyntax.sml index eb1db8c8f..f51d2a625 100644 --- a/src/tools/symbexec/birsSyntax.sml +++ b/src/tools/symbexec/birsSyntax.sml @@ -182,6 +182,15 @@ in val (birs_exp_imp_tm, mk_birs_exp_imp, dest_birs_exp_imp, is_birs_exp_imp) = syntax_fns2 "birs_exp_imp"; end +local + open distribute_generic_stuffTheory; + fun syntax_fns n d m = HolKernel.syntax_fns {n = n, dest = d, make = m} "distribute_generic_stuff"; + val syntax_fns2 = syntax_fns 2 HolKernel.dest_binop HolKernel.mk_binop; +in + val (mk_bsysprecond_tm, mk_mk_bsysprecond, dest_mk_bsysprecond, is_mk_bsysprecond) = syntax_fns2 "mk_bsysprecond"; +end + + (* ====================================================================================== *) (* extract terms from a sound structure *) @@ -236,6 +245,8 @@ end val get_birs_Pi_length = (length o get_birs_Pi_list); + val len_of_thm_Pi = get_birs_Pi_length o concl; + (* function to get the first Pi state *) val get_birs_Pi_first = (fst o pred_setSyntax.dest_insert o get_birs_Pi); @@ -348,6 +359,9 @@ end fun birs_check_min_Pi_thm m (sfun) = check_raise ((fn x => x >= m) o get_birs_Pi_length o concl) (sfun, "Pi has to have at least "^(Int.toString m)^" states"); + fun birs_check_env_norm (sfun, smsg) = + check_raise (birs_env_is_norm) (sfun, "env is not norm" ^ smsg); + (* check if two structures are in normform and use the same program *) fun birs_check_compatible A_thm B_thm = let diff --git a/src/tools/symbexec/birs_composeLib.sml b/src/tools/symbexec/birs_composeLib.sml index e4c078ad5..a0e373bc1 100644 --- a/src/tools/symbexec/birs_composeLib.sml +++ b/src/tools/symbexec/birs_composeLib.sml @@ -83,6 +83,10 @@ in val _ = birs_check_norm_thm ("birs_rule_SEQ_fun", "") bprog_fixed_thm handle e => (print_term (concl bprog_fixed_thm); raise e); + + (* check that the resulting Pi set cardinality is A - 1 + B *) + val _ = if len_of_thm_Pi step_A_thm - 1 + len_of_thm_Pi step_B_thm = len_of_thm_Pi bprog_fixed_thm then () else + raise ERR "birs_rule_SEQ_fun" "somehow the states did not merge in Pi set"; in bprog_fixed_thm end; diff --git a/src/tools/symbexec/birs_driveLib.sml b/src/tools/symbexec/birs_driveLib.sml index e28e58636..421969948 100644 --- a/src/tools/symbexec/birs_driveLib.sml +++ b/src/tools/symbexec/birs_driveLib.sml @@ -180,7 +180,7 @@ in (* local *) fun birs_init env pcond init_lbl = let - (* TODO: check that env is norm *) + val _ = birs_check_env_norm ("birs_init", "") env; val pcond_is_sat = bir_smtLib.bir_smt_check_sat false pcond; val _ = if pcond_is_sat then () else @@ -201,19 +201,26 @@ in (* local *) fun gen_birs_env_thm birenvtyl_def = let open birs_auxTheory; + val bprog_envtyl_tm = (fst o dest_eq o concl) birenvtyl_def; in - (REWRITE_CONV [birenvtyl_def] THENC EVAL THENC REWRITE_CONV [GSYM birs_gen_env_thm, GSYM birs_gen_env_NULL_thm]) ``bir_senv_GEN_list ^bprog_envtyl_tm`` + (REWRITE_CONV [birenvtyl_def] THENC + EVAL THENC + REWRITE_CONV [GSYM birs_gen_env_thm, GSYM birs_gen_env_NULL_thm]) (mk_bir_senv_GEN_list bprog_envtyl_tm) end; val gen_birs_env = (rhs o concl o gen_birs_env_thm); fun gen_birs_pcond_thm birenvtyl_def bpre = let + open birs_auxTheory; val bprog_envtyl_tm = (fst o dest_eq o concl) birenvtyl_def; val mk_bsysprecond_pcond_thm = - (computeLib.RESTR_EVAL_CONV [``birs_eval_exp``] THENC birs_stepLib.birs_eval_exp_CONV) - (``mk_bsysprecond ^bpre ^bprog_envtyl_tm``); + (computeLib.RESTR_EVAL_CONV [birs_eval_exp_tm, birs_gen_env_tm] THENC + REWRITE_CONV [GSYM birs_gen_env_thm, GSYM birs_gen_env_NULL_thm] THENC + birs_auxLib.GEN_match_conv is_birs_eval_exp birs_stepLib.birs_eval_exp_CONV THENC + EVAL (*FST (THE (...))*)) + (mk_mk_bsysprecond (bpre, bprog_envtyl_tm)); in mk_bsysprecond_pcond_thm end; diff --git a/src/tools/symbexec/birs_instantiationLib.sml b/src/tools/symbexec/birs_instantiationLib.sml index ad456c435..d0210578b 100644 --- a/src/tools/symbexec/birs_instantiationLib.sml +++ b/src/tools/symbexec/birs_instantiationLib.sml @@ -43,11 +43,10 @@ in (* local *) *) (* find necessary iunstantiations for birs_sound_symb_inst_RULE *) - fun birs_find_symb_exp_map bv_syp_gen A_thm B_thm = + fun birs_find_symb_exp_map bv_syp_gen state B_thm = let - (* take first Pi state of A, env and pcond *) - val A_Pi_sys_tm = (get_birs_Pi_first o concl) A_thm; - val (_,A_env,_,A_pcond) = dest_birs_state A_Pi_sys_tm; + (* take first env and pcond of target state *) + val (_,A_env,_,A_pcond) = dest_birs_state state; (* construct symb_exp_map *) fun get_default_bv (vn,exp) = @@ -107,14 +106,11 @@ in (* local *) end; (* - instantiation process (including sequential composition) + instantiation for state *) - fun birs_sound_inst_SEQ_RULE birs_rule_SEQ_thm bv_syp_gen A_thm B_thm = + fun birs_sound_inst_RULE bv_syp_gen state B_thm = let - val _ = birs_check_compatible A_thm B_thm; - val A_Pi_sys_tm = (get_birs_Pi_first o concl) A_thm; - val (_,_,_,A_pcond) = dest_birs_state A_Pi_sys_tm; - val len_of_thm_Pi = get_birs_Pi_length o concl; + val (_,_,_,A_pcond) = dest_birs_state state; open birs_auxTheory; @@ -122,7 +118,7 @@ in (* local *) - environment mappings - the generic path condition symbol bv_syp_gen - renaming of all free symbols for good measure *) - val symb_exp_map = birs_find_symb_exp_map bv_syp_gen A_thm B_thm; + val symb_exp_map = birs_find_symb_exp_map bv_syp_gen state B_thm; (*val _ = List.map (fn (bv_symb,exp) => (print_term bv_symb; print "|->\n"; print_term exp; print "\n")) symb_exp_map;*) (* instantiate all *) @@ -151,12 +147,29 @@ in (* local *) *) val B_thm_inst_sys_Pi = birs_Pi_first_pcond_RULE B_Pi_pcond_new B_thm_inst_sys; - (* sequential composition of the two theorems *) - val seq_thm = birs_composeLib.birs_rule_SEQ_fun birs_rule_SEQ_thm A_thm B_thm_inst_sys_Pi; + (* fix env mapping order *) + val B_thm_inst_fixed = CONV_RULE (birs_sys_CONV (birs_env_set_order_CONV (birs_env_varnames state))) B_thm_inst_sys_Pi; + + (* check that the initial state of B_thm_inst_fixed is indeed what we intended to get *) + val _ = if identical state ((get_birs_sys o concl) B_thm_inst_fixed) then () else + raise ERR "birs_sound_inst_RULE" "instantiation failed, initial state of instantiated theorem not identical with target state"; + in + B_thm_inst_fixed + end; + + (* + instantiation process (including sequential composition) + *) + fun birs_sound_inst_SEQ_RULE birs_rule_SEQ_thm bv_syp_gen A_thm B_thm = + let + val _ = birs_check_compatible A_thm B_thm; + + val A_Pi_sys_tm = (get_birs_Pi_first o concl) A_thm; - (* check that the resulting Pi set cardinality is A - 1 + B *) - val _ = if len_of_thm_Pi A_thm - 1 + len_of_thm_Pi B_thm_inst_sys_Pi = len_of_thm_Pi seq_thm then () else - raise ERR "birs_sound_inst_SEQ_RULE" "somehow the states did not merge in Pi"; + val B_inst_thm = birs_sound_inst_RULE bv_syp_gen A_Pi_sys_tm B_thm; + + (* sequential composition of the two theorems *) + val seq_thm = birs_composeLib.birs_rule_SEQ_fun birs_rule_SEQ_thm A_thm B_inst_thm; in seq_thm end; diff --git a/src/tools/symbexec/birs_intervalLib.sml b/src/tools/symbexec/birs_intervalLib.sml index 587f7d6d1..db727cc56 100644 --- a/src/tools/symbexec/birs_intervalLib.sml +++ b/src/tools/symbexec/birs_intervalLib.sml @@ -202,6 +202,24 @@ end in (* local *) + fun birs_intervals_Pi_first_simplify_limits thm = + let + (* TODO: simplify the limits of the intervals in the pathcondition *) + (* for example: + BExp_IntervalPred + (BExp_Den (BVar "syi_countw" (BType_Imm Bit64))) + (BExp_BinExp BIExp_Plus + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 5w))) (BExp_Const (Imm64 21w)), + BExp_BinExp BIExp_Plus + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 5w))) (BExp_Const (Imm64 21w))) *) + in + thm + end; + (* unifies the representation of the interval for env mapping vn (handles introduction (e.g., after symbolic execution without interval) and also fusion of transitive intervals (e.g., after instantiation)) *) (* afterwards: vn is on top, symbolname mapped for interval is ("syi_"^vn), exactly one interval relating to it in the pathcondition *) (* this has to be used after an instantiation and after an execution (which in turn is either from an initial state, or from after a merge operation), and before a bounds operation below *) @@ -212,7 +230,8 @@ in (* local *) val _ = if not debug_mode then () else print "starting to unify interval for one Pi state\n"; (* bring up mapping vn to the top of env mappings *) - val thm0 = CONV_RULE (birs_Pi_first_CONV (birs_env_var_top_CONV vn)) thm; + val thm_ = CONV_RULE (birs_Pi_first_CONV (birs_env_var_top_CONV vn)) thm; + val thm0 = birs_intervals_Pi_first_simplify_limits thm_; val env_exp = (snd o get_birs_Pi_first_env_top_mapping o concl) thm0; (* is the mapping just a symbol, which is not the initial symbolic one? diff --git a/src/tools/symbexec/birs_stepLib.sml b/src/tools/symbexec/birs_stepLib.sml index a9197a94f..bae364eb1 100644 --- a/src/tools/symbexec/birs_stepLib.sml +++ b/src/tools/symbexec/birs_stepLib.sml @@ -600,7 +600,8 @@ fun abbr_birs_gen_env i acc consf t = fun consf_ thm = consf (CONV_RULE (RAND_CONV (RAND_CONV (K thm))) thm0); in abbr_birs_gen_env (i+1) (eq_thm::acc) consf_ tl - end; + end + handle _ => raise ERR "abbr_birs_gen_env" "abbreviation failed"; (* val (thm, eq_thms) = abbr_birs_gen_env 0 [] I t; *) @@ -615,11 +616,13 @@ fun rev_birs_gen_env (thm, eq_thms) = fun birs_eval_exp_CONV_p1 t = let - val tm = (snd o dest_comb o snd o dest_comb) t;(*dest_birs_eval_exp;*) + val tm = (dest_birs_gen_env o snd o dest_birs_eval_exp) t; val (thm, eq_thms) = abbr_birs_gen_env 0 [] I tm; in + (* rewrite the environment list *) (RAND_CONV (RAND_CONV (K thm)) t, eq_thms) - end; + end + handle e => (print_term t; raise wrap_exn "birs_eval_exp_CONV_p1" e); val birs_eval_exp_CONV_p2 = REWRITE_CONV [birs_eval_exp_def] THENC diff --git a/src/tools/symbexec/birs_strategiesLib.sml b/src/tools/symbexec/birs_strategiesLib.sml index b560c5051..977694a8c 100644 --- a/src/tools/symbexec/birs_strategiesLib.sml +++ b/src/tools/symbexec/birs_strategiesLib.sml @@ -81,6 +81,41 @@ in (* local *) birs_post_step_fun end; + fun birs_from_summaries postproc sums state = + let + (* assumtions on summary theorem list, each theorem: + - is birs_symb_exec for correct program + - initial state: + is in running state, + environment is generic (from bir_senv_GEN_list, but as birs_gen_env) + - otherwise usable for symbolic execution function *) + open birs_instantiationLib; + fun state_pc_in_sum pc sum = + identical (dest_birs_state_pc state) ((dest_birs_state_pc o get_birs_sys o concl) sum); + (* filter by pc (should return NONE directly, if there is no match) *) + val sums_pc = List.filter (state_pc_in_sum state) sums; + in + let + (* try instantiation from the first (instantiate and justify with pcond strengthening) *) + fun foldfun (sum, acc) = + if isSome acc then acc else + (let + val thm = birs_sound_inst_RULE birs_driveLib.pcond_gen_symb state sum; + val _ = print "\n====================================================\n" + val _ = print "====================================================\n" + val _ = print "used a summary\n\n"; + val _ = print_thm thm; + in + SOME thm + end + handle _ => acc); + in + Option.map postproc (List.foldl foldfun NONE sums_pc) + end + end; + + val birs_from_summaries_riscv = birs_from_summaries I; + end (* local *) end (* struct *) diff --git a/src/tools/symbexec/birs_transferLib.sml b/src/tools/symbexec/birs_transferLib.sml index 0e4bcadb8..13a42f250 100644 --- a/src/tools/symbexec/birs_transferLib.sml +++ b/src/tools/symbexec/birs_transferLib.sml @@ -42,14 +42,17 @@ fun prepare_transfer birenvtyl_def pcond_inst bpre symb_analysis_thm = open birs_utilsLib; val specd_symb_analysis_thm = birs_sound_symb_inst_RULE [(birs_driveLib.pcond_gen_symb, pcond_inst)] symb_analysis_thm; val pcond_symb_analysis_thm = birs_sys_pcond_RULE pcond_tm specd_symb_analysis_thm; + val extra_symb_analysis_thm = CONV_RULE (birs_Pi_CONV (REWRITE_CONV [birs_auxTheory.BExp_IntervalPred_def])) pcond_symb_analysis_thm; (* then fix the initial state *) - val fixed_symb_analysis_thm = CONV_RULE (birs_sys_CONV (REWRITE_CONV [GSYM prog_env_thm])) pcond_symb_analysis_thm; + val fixed_symb_analysis_thm = CONV_RULE (birs_sys_CONV (REWRITE_CONV [GSYM prog_env_thm])) extra_symb_analysis_thm; + (* val _ = print "\n\n"; val _ = print_thm prog_pcond_thm; val _ = print "\n\n"; val _ = print_thm fixed_symb_analysis_thm; val _ = print "\n\n"; + *) in (prog_pcond_thm, fixed_symb_analysis_thm) end; diff --git a/src/tools/symbexec/birs_utilsLib.sml b/src/tools/symbexec/birs_utilsLib.sml index f9555dea8..43696fc84 100644 --- a/src/tools/symbexec/birs_utilsLib.sml +++ b/src/tools/symbexec/birs_utilsLib.sml @@ -349,31 +349,46 @@ in (* local *) val _ = birs_check_state_norm ("birs_env_CONV", "") birs_tm; val env_new_thm = conv (dest_birs_state_env birs_tm); in - (* better use EQ_MP? *) - REWRITE_CONV [env_new_thm] birs_tm + (* better use some variant of EQ_MP? should exist *) + REWRITE_CONV [Once env_new_thm] birs_tm end - (* move a certain mapping to the top *) - fun birs_env_var_top_CONV varname birs_tm = - (* TODO: should use birs_env_CONV *) + (* adjust the order of a mapping according to a given list *) + fun birs_env_set_order_CONV varnames tm = let - val _ = birs_check_state_norm ("birs_env_var_top_CONV", "") birs_tm; - - val (pc, env, status, pcond) = dest_birs_state birs_tm; - val (mappings, mappings_ty) = (listSyntax.dest_list o dest_birs_gen_env) env; - val is_m_for_varname = (fn x => x = varname) o stringSyntax.fromHOLstring o fst o pairSyntax.dest_pair; - fun get_exp_if m = - if is_m_for_varname m then SOME m else NONE; - val m_o = List.foldl (fn (m, acc) => case acc of SOME x => SOME x | NONE => get_exp_if m) NONE mappings; - val m = valOf m_o handle _ => raise ERR "birs_env_var_top_CONV" "variable name not mapped in bir state"; - val mappings_new = m::(List.filter (not o is_m_for_varname) mappings); - - val env_new = (mk_birs_gen_env o listSyntax.mk_list) (mappings_new, mappings_ty); - val birs_new_tm = mk_birs_state (pc, env_new, status, pcond); + fun is_m_for_varname vn = (fn x => x = vn) o stringSyntax.fromHOLstring o fst o pairSyntax.dest_pair; + fun get_exp_if vn m = + if is_m_for_varname vn m then SOME m else NONE; + fun reorder_mappings [] ms acc = ((List.rev acc)@ms) + | reorder_mappings (varname::vns) ms acc = + let + val m_o = List.foldl (fn (m, acc) => case acc of SOME x => SOME x | NONE => get_exp_if varname m) NONE ms; + val m = valOf m_o handle _ => raise ERR "birs_env_set_order_CONV" "variable name not mapped in bir state"; + val ms_new = List.filter (not o is_m_for_varname varname) ms; + in + reorder_mappings vns ms_new (m::acc) + end; + + fun set_env_order env = + let + val _ = birs_check_env_norm ("birs_env_set_order_CONV", "") env; + + val (mappings, mappings_ty) = (listSyntax.dest_list o dest_birs_gen_env) env; + + val env_new = (mk_birs_gen_env o listSyntax.mk_list) (reorder_mappings varnames mappings [], mappings_ty); + in + mk_oracle_thm "BIRS_ENVVARSETORDER" ([], mk_eq (env, env_new)) + end + handle _ => raise ERR "birs_env_set_order_CONV" "something uncaught"; + + val env_eq_thm = birs_env_CONV set_env_order tm; in - mk_oracle_thm "BIRS_ENVVARTOP" ([], mk_eq (birs_tm, birs_new_tm)) - end - handle _ => raise ERR "birs_env_var_top_CONV" "something uncaught"; + env_eq_thm + end; + + (* move a certain mapping to the top *) + fun birs_env_var_top_CONV varname = + birs_env_set_order_CONV [varname]; (* ---------------------------------------------------------------------------------------- *) diff --git a/src/tools/symbexec/distribute_generic_stuffLib.sml b/src/tools/symbexec/distribute_generic_stuffLib.sml index cabe6251a..aa7724b7c 100644 --- a/src/tools/symbexec/distribute_generic_stuffLib.sml +++ b/src/tools/symbexec/distribute_generic_stuffLib.sml @@ -13,6 +13,8 @@ local open distribute_generic_stuffTheory; open bir_symb_sound_coreTheory; + open birsSyntax; + val birs_state_ss = rewrites (type_rws ``:birs_state_t``); in @@ -92,7 +94,11 @@ bsymbstate_bconcpred_bsymbval bsys2 bpost; fun bsymbstate_bconcpred_bsymbval bsys bcond = let val birs_eval_thm = - (computeLib.RESTR_EVAL_CONV [``birs_eval_exp``] THENC birs_stepLib.birs_eval_exp_CONV THENC EVAL) ``FST (THE (birs_eval_exp ^bcond ((^bsys).bsst_environ)))``; + (computeLib.RESTR_EVAL_CONV [birs_eval_exp_tm, birs_gen_env_tm] THENC + REWRITE_CONV [GSYM birs_gen_env_thm, GSYM birs_gen_env_NULL_thm] THENC + birs_auxLib.GEN_match_conv is_birs_eval_exp birs_stepLib.birs_eval_exp_CONV THENC + EVAL) + ``FST (THE (birs_eval_exp ^bcond ((^bsys).bsst_environ)))``; val birs_eval_res = (snd o dest_eq o concl) birs_eval_thm; val _ = if not (pairSyntax.is_fst birs_eval_res) then () else raise mk_HOL_ERR "symbexec_transfer_lib" "bsymbstate_bconcpred_bsymbval" "could not finish symbolic evaluation"; in @@ -127,18 +133,18 @@ fun gen_birs_smt_implcond bsys1 bpre bsys2 bpost = symbs in H' are the query variables here; alternative for better performance - use abbreviations for symbols to avoid blowup of symbolic expression; *) +val birs_strongpostcond_impl_pat_tm = `` + sys1 = SYS1 ==> + sys2 = SYS2 ==> + birs_symb_matchstate sys1 H bs1 ==> + bir_eval_exp BPRE bs1.bst_environ = SOME bir_val_true ==> + birs_symb_matchstate sys2 H bs2 ==> + bir_eval_exp BPOST bs2.bst_environ = SOME bir_val_true``; fun birs_strongpostcond_impl_TAC (assum_list, goal) = let val _ = if List.null assum_list then () else raise mk_HOL_ERR "symbexec_transfer_lib" "birs_strongpostcond_impl_TAC" "assumption list not empty"; - val pat_tm = `` - sys1 = SYS1 ==> - sys2 = SYS2 ==> - birs_symb_matchstate sys1 H bs1 ==> - bir_eval_exp BPRE bs1.bst_environ = SOME bir_val_true ==> - birs_symb_matchstate sys2 H bs2 ==> - bir_eval_exp BPOST bs2.bst_environ = SOME bir_val_true``; val tm_subst = - fst (match_term pat_tm goal) + fst (match_term birs_strongpostcond_impl_pat_tm goal) handle _ => raise mk_HOL_ERR "symbexec_transfer_lib" "birs_strongpostcond_impl_TAC" "wrong goal shape"; val bsys1 = subst tm_subst ``SYS1:birs_state_t``; val bsys2 = subst tm_subst ``SYS2:birs_state_t``; From 089e2b0d5c13eaeadccdcb7a3ae6e272ca800fb5 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 21 Oct 2024 23:01:19 +0200 Subject: [PATCH 88/95] Fix CI --- src/tools/symbexec/examples/test-birs_transfer.sml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/tools/symbexec/examples/test-birs_transfer.sml b/src/tools/symbexec/examples/test-birs_transfer.sml index e6d97b195..976a35a1c 100644 --- a/src/tools/symbexec/examples/test-birs_transfer.sml +++ b/src/tools/symbexec/examples/test-birs_transfer.sml @@ -124,8 +124,10 @@ val bsysprecond_def = Define ` `; val bprecond_birs_eval_exp_thm = save_thm( "bprecond_birs_eval_exp_thm", - (computeLib.RESTR_EVAL_CONV [``birs_eval_exp``] THENC - birs_stepLib.birs_eval_exp_CONV) + (computeLib.RESTR_EVAL_CONV [birs_eval_exp_tm] THENC + REWRITE_CONV [GSYM birs_gen_env_thm, GSYM birs_gen_env_NULL_thm] THENC + birs_auxLib.GEN_match_conv is_birs_eval_exp birs_stepLib.birs_eval_exp_CONV THENC + EVAL) ``birs_eval_exp bprecond (bir_senv_GEN_list birenvtyl)`` ); val bsysprecond_thm = save_thm( From 1f8de93e5ff7cfcd93ed21d17af9fd7e0ec30433 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Tue, 22 Oct 2024 22:22:14 +0200 Subject: [PATCH 89/95] Fix for interval unification --- src/tools/symbexec/birs_intervalLib.sml | 63 ++++++++++++++++++++----- 1 file changed, 50 insertions(+), 13 deletions(-) diff --git a/src/tools/symbexec/birs_intervalLib.sml b/src/tools/symbexec/birs_intervalLib.sml index db727cc56..6cd5bd0ac 100644 --- a/src/tools/symbexec/birs_intervalLib.sml +++ b/src/tools/symbexec/birs_intervalLib.sml @@ -113,6 +113,14 @@ val intervalpattern64_tm = `` (BExp_Const (Imm64 x_c)), BExp_BinExp BIExp_Plus (BExp_Den (BVar x_b (BType_Imm Bit64))) (BExp_Const (Imm64 x_d)))``; +val intervalpattern64_inst_tm = `` + BExp_IntervalPred (BExp_Den (BVar x_a (BType_Imm Bit64))) + (BExp_BinExp BIExp_Plus (BExp_BinExp BIExp_Plus (BExp_Den (BVar x_b (BType_Imm Bit64))) + (BExp_Const (Imm64 x_c1))) + (BExp_Const (Imm64 x_c2)), + BExp_BinExp BIExp_Plus (BExp_BinExp BIExp_Plus (BExp_Den (BVar x_b (BType_Imm Bit64))) + (BExp_Const (Imm64 x_d1))) + (BExp_Const (Imm64 x_d2)))``; fun get_interval_parameters i_tm = let @@ -127,6 +135,23 @@ fun get_interval_parameters i_tm = (Arbnum.toInt o wordsSyntax.dest_word_literal) hc) end handle _ => raise ERR "get_interval_parameters" ("no match? : " ^ (term_to_string i_tm)); +fun get_interval_parameters_inst i_tm = + let + val (vs, _) = hol88Lib.match intervalpattern64_inst_tm i_tm; + val symb_str = fst (List.nth (vs, 0)); + val refsymb_str = fst (List.nth (vs, 1)); + val lc1 = fst (List.nth (vs, 2)); + val lc2 = fst (List.nth (vs, 3)); + val hc1 = fst (List.nth (vs, 4)); + val hc2 = fst (List.nth (vs, 5)); + in + (fromHOLstring symb_str, fromHOLstring refsymb_str, + (Arbnum.toInt o wordsSyntax.dest_word_literal) lc1 + + (Arbnum.toInt o wordsSyntax.dest_word_literal) lc2, + (Arbnum.toInt o wordsSyntax.dest_word_literal) hc1 + + (Arbnum.toInt o wordsSyntax.dest_word_literal) hc2) + end + handle _ => raise ERR "get_interval_parameters_inst" ("no match? : " ^ (term_to_string i_tm)); fun mk_interval_tm (symb_str, refsymb_str, lc, hc) = subst [``x_a:string`` |-> fromMLstring symb_str, ``x_b:string`` |-> fromMLstring refsymb_str, @@ -198,26 +223,38 @@ val interval2 = ``BExp_IntervalPred (BExp_Den (BVar "syi_countw" (BType_Imm Bit6 in interval end; + + (* + val interval = `` + BExp_IntervalPred + (BExp_Den (BVar "syi_countw" (BType_Imm Bit64))) + (BExp_BinExp BIExp_Plus + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 5w))) (BExp_Const (Imm64 21w)), + BExp_BinExp BIExp_Plus + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) + (BExp_Const (Imm64 5w))) (BExp_Const (Imm64 21w))) + ``; + val i_tm = interval; + *) + fun simplify_interval tm = + (mk_interval_tm o get_interval_parameters_inst) tm + handle _ => tm; end in (* local *) fun birs_intervals_Pi_first_simplify_limits thm = let - (* TODO: simplify the limits of the intervals in the pathcondition *) - (* for example: - BExp_IntervalPred - (BExp_Den (BVar "syi_countw" (BType_Imm Bit64))) - (BExp_BinExp BIExp_Plus - (BExp_BinExp BIExp_Plus - (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) - (BExp_Const (Imm64 5w))) (BExp_Const (Imm64 21w)), - BExp_BinExp BIExp_Plus - (BExp_BinExp BIExp_Plus - (BExp_Den (BVar "sy_countw" (BType_Imm Bit64))) - (BExp_Const (Imm64 5w))) (BExp_Const (Imm64 21w))) *) + (* simplify the limits of the intervals in the pathcondition *) + val pcond = (get_birs_Pi_first_pcond o concl) thm; + val pcondl = dest_bandl pcond; + val pcondl_fixed = List.map (fn tm => if is_BExp_IntervalPred tm then simplify_interval tm else tm) pcondl; + val thm_fixed = birs_Pi_first_pcond_RULE (bslSyntax.bandl pcondl_fixed) thm; in - thm + thm_fixed end; (* unifies the representation of the interval for env mapping vn (handles introduction (e.g., after symbolic execution without interval) and also fusion of transitive intervals (e.g., after instantiation)) *) From db3a8b4ea70d6fb3d301053bde3f19de7bfe0eeb Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Wed, 30 Oct 2024 10:36:59 +0100 Subject: [PATCH 90/95] reduce metaprogramming in incr example --- examples/riscv/incr/incrScript.sml | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/examples/riscv/incr/incrScript.sml b/examples/riscv/incr/incrScript.sml index 836bf774a..b07eb9334 100644 --- a/examples/riscv/incr/incrScript.sml +++ b/examples/riscv/incr/incrScript.sml @@ -3,20 +3,19 @@ open HolKernel Parse; open bir_lifter_interfaceLib; open birs_auxLib; -val progname = "incr"; - val _ = Parse.current_backend := PPBackEnd.vt100_terminal; val _ = set_trace "bir_inst_lifting.DEBUG_LEVEL" 2; -val _ = new_theory progname; +val _ = new_theory "incr"; -val _ = lift_da_and_store progname (progname ^ ".da") da_riscv ((Arbnum.fromInt 0x10488), (Arbnum.fromInt 0x10498)); +val _ = lift_da_and_store "incr" "incr.da" da_riscv + ((Arbnum.fromInt 0x10488), (Arbnum.fromInt 0x10498)); (* ----------------------------------------- *) (* Program variable definitions and theorems *) (* ----------------------------------------- *) -val bir_prog_def = DB.fetch progname ("bir_"^progname^"_prog_def"); -val _ = gen_prog_vars_birenvtyl_defthms progname bir_prog_def; +val bir_prog_def = DB.fetch "-" "bir_incr_prog_def"; +val _ = gen_prog_vars_birenvtyl_defthms "incr" bir_prog_def; val _ = export_theory (); From 7f59ecdc89f9e1f9fc05f4a2efcfcbce2c4667df Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Wed, 30 Oct 2024 14:14:03 +0100 Subject: [PATCH 91/95] basic chacha round spec and symbexec --- examples/riscv/chacha/chacha_specScript.sml | 47 +++++++++++++++++++ .../chacha_symb_exec_quarterroundScript.sml | 31 ++++++++++++ 2 files changed, 78 insertions(+) create mode 100644 examples/riscv/chacha/chacha_symb_exec_quarterroundScript.sml diff --git a/examples/riscv/chacha/chacha_specScript.sml b/examples/riscv/chacha/chacha_specScript.sml index b8dedc968..36b04583e 100644 --- a/examples/riscv/chacha/chacha_specScript.sml +++ b/examples/riscv/chacha/chacha_specScript.sml @@ -38,6 +38,30 @@ open bir_program_varsTheory; val _ = new_theory "chacha_spec"; +(* ------------- *) +(* ChaCha theory *) +(* ------------- *) + +(* +op line (a:idx) (b:idx) (d:idx) (s:int) (m:state) : state = + let m = m.[a <- (m.[a] + m.[b])] in + let m = m.[d <- W32.rol (m.[d] +^ m.[a]) s] in m. +*) + +Type chacha_state = ``:word32 # word32 # word32 # word32 # + word32 # word32 # word32 # word32 # + word32 # word32 # word32 # word32 # + word32 # word32 # word32 # word32`` + +Type chacha_row = ``:word32 # word32 # word32 # word32`` + +Definition chacha_line: + chacha_line ((a0,b0,c0,d0):chacha_row) : chacha_row = + let a1 = a0 + b0 in + let d1 = d0 ?? a1 in + (a1, b0, c0, d1) +End + (* ---------------- *) (* Block boundaries *) (* ---------------- *) @@ -62,6 +86,16 @@ Definition chacha_ivsetup_end_addr_def: chacha_ivsetup_end_addr : word64 = 0x10778w End +(* quarterround *) + +Definition chacha_quarterround_init_addr_def: + chacha_quarterround_init_addr : word64 = 0x108a0w +End + +Definition chacha_quarterround_end_addr_def: + chacha_quarterround_end_addr : word64 = 0x108b4w +End + (* --------------- *) (* BSPEC contracts *) (* --------------- *) @@ -90,4 +124,17 @@ Definition bspec_chacha_ivsetup_pre_def: ^bspec_chacha_ivsetup_pre_tm End +(* quarterround *) + +val bspec_chacha_quarterround_pre_tm = bslSyntax.bandl [ + mem_addrs_aligned_prog_disj_bir_tm mem_params_standard "x10", + mem_addrs_aligned_prog_disj_bir_tm mem_params_standard "x11", + mem_addrs_aligned_prog_disj_bir_tm mem_params_standard "x12" +]; + +Definition bspec_chacha_quarterround_pre_def: + bspec_chacha_quarterround_pre : bir_exp_t = + ^bspec_chacha_quarterround_pre_tm +End + val _ = export_theory (); diff --git a/examples/riscv/chacha/chacha_symb_exec_quarterroundScript.sml b/examples/riscv/chacha/chacha_symb_exec_quarterroundScript.sml new file mode 100644 index 000000000..b01817606 --- /dev/null +++ b/examples/riscv/chacha/chacha_symb_exec_quarterroundScript.sml @@ -0,0 +1,31 @@ +open HolKernel Parse boolLib bossLib; + +open wordsTheory; + +open bir_symbLib; + +open chachaTheory chacha_specTheory; + +val _ = new_theory "chacha_symb_exec_quarterround"; + +(* --------------------------- *) +(* Symbolic analysis execution *) +(* --------------------------- *) + +val _ = show_tags := true; + +(* ------------ *) +(* quarterround *) +(* ------------ *) + +val symb_analysis_thm = + bir_symb_analysis_thm + bir_chacha_prog_def + chacha_quarterround_init_addr_def [chacha_quarterround_end_addr_def] + bspec_chacha_quarterround_pre_def chacha_birenvtyl_def; + +val _ = Portable.pprint Tag.pp_tag (tag symb_analysis_thm); + +Theorem chacha_quarterround_symb_analysis_thm = symb_analysis_thm + +val _ = export_theory (); From f6a6d5bc116ee4794ffdc05ad6d03ba8e890f11f Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Wed, 30 Oct 2024 16:54:24 +0100 Subject: [PATCH 92/95] spec of chacha20 inspired by EasyCrypt spec --- examples/riscv/chacha/chacha_specScript.sml | 77 ++++++++++++++++++--- 1 file changed, 67 insertions(+), 10 deletions(-) diff --git a/examples/riscv/chacha/chacha_specScript.sml b/examples/riscv/chacha/chacha_specScript.sml index 36b04583e..b1e371fe1 100644 --- a/examples/riscv/chacha/chacha_specScript.sml +++ b/examples/riscv/chacha/chacha_specScript.sml @@ -48,18 +48,75 @@ op line (a:idx) (b:idx) (d:idx) (s:int) (m:state) : state = let m = m.[d <- W32.rol (m.[d] +^ m.[a]) s] in m. *) -Type chacha_state = ``:word32 # word32 # word32 # word32 # - word32 # word32 # word32 # word32 # - word32 # word32 # word32 # word32 # - word32 # word32 # word32 # word32`` +Definition chacha_line: + chacha_line (a:word32) (b:word32) (d:word32) (s:word32) + (m:word32 -> word32) = + let m = (a =+ (m a) + (m b)) m in + let m = (d =+ ((m a) ?? (m d)) #<<~ s) m in + m +End -Type chacha_row = ``:word32 # word32 # word32 # word32`` +(* +op quarter_round a b c d : shuffle = + line a b d 16 \oo + line c d b 12 \oo + line a b d 8 \oo + line c d b 7. +*) -Definition chacha_line: - chacha_line ((a0,b0,c0,d0):chacha_row) : chacha_row = - let a1 = a0 + b0 in - let d1 = d0 ?? a1 in - (a1, b0, c0, d1) +Definition chacha_quarter_round: + chacha_quarter_round (a:word32) (b:word32) (c:word32) (d:word32) = + chacha_line a b d 16w o + chacha_line c d b 12w o + chacha_line a b d 8w o + chacha_line c d b 7w +End + +(* +EVAL ``(chacha_quarter_round + 0x11111111w 0x01020304w 0x9b8d6f43w 0x01234567w) (\x. 0w)`` +*) + +(* +op column_round : shuffle = + quarter_round 0 4 8 12 \oo + quarter_round 1 5 9 13 \oo + quarter_round 2 6 10 14 \oo + quarter_round 3 7 11 15. +*) + +Definition chacha_column_round: + chacha_column_round = + chacha_quarter_round 0w 4w 8w 12w o + chacha_quarter_round 1w 5w 9w 13w o + chacha_quarter_round 2w 6w 10w 14w o + chacha_quarter_round 3w 7w 11w 15w +End + +(* +op diagonal_round : shuffle = + quarter_round 0 5 10 15 \oo + quarter_round 1 6 11 12 \oo + quarter_round 2 7 8 13 \oo + quarter_round 3 4 9 14. +*) + +Definition chacha_diagonal_round: + chacha_diagonal_round = + chacha_quarter_round 0w 5w 10w 15w o + chacha_quarter_round 1w 6w 11w 12w o + chacha_quarter_round 2w 7w 8w 13w o + chacha_quarter_round 3w 4w 9w 14w +End + +(* +op double_round: shuffle = + column_round \oo diagonal_round. +*) + +Definition chacha_double_round: + chacha_double_round = + chacha_column_round o chacha_diagonal_round End (* ---------------- *) From c986f424f96bf9ee6976f84541914280bb8f9385 Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Wed, 30 Oct 2024 20:43:35 +0100 Subject: [PATCH 93/95] fixed and validated chacha round spec --- examples/riscv/chacha/chacha_specScript.sml | 87 +++++++++++++++++---- 1 file changed, 71 insertions(+), 16 deletions(-) diff --git a/examples/riscv/chacha/chacha_specScript.sml b/examples/riscv/chacha/chacha_specScript.sml index b1e371fe1..d662c8596 100644 --- a/examples/riscv/chacha/chacha_specScript.sml +++ b/examples/riscv/chacha/chacha_specScript.sml @@ -52,7 +52,7 @@ Definition chacha_line: chacha_line (a:word32) (b:word32) (d:word32) (s:word32) (m:word32 -> word32) = let m = (a =+ (m a) + (m b)) m in - let m = (d =+ ((m a) ?? (m d)) #<<~ s) m in + let m = (d =+ ((m d) ?? (m a)) #<<~ s) m in m End @@ -66,17 +66,12 @@ op quarter_round a b c d : shuffle = Definition chacha_quarter_round: chacha_quarter_round (a:word32) (b:word32) (c:word32) (d:word32) = - chacha_line a b d 16w o - chacha_line c d b 12w o + chacha_line c d b 7w o chacha_line a b d 8w o - chacha_line c d b 7w + chacha_line c d b 12w o + chacha_line a b d 16w End -(* -EVAL ``(chacha_quarter_round - 0x11111111w 0x01020304w 0x9b8d6f43w 0x01234567w) (\x. 0w)`` -*) - (* op column_round : shuffle = quarter_round 0 4 8 12 \oo @@ -87,10 +82,10 @@ op column_round : shuffle = Definition chacha_column_round: chacha_column_round = - chacha_quarter_round 0w 4w 8w 12w o - chacha_quarter_round 1w 5w 9w 13w o + chacha_quarter_round 3w 7w 11w 15w o chacha_quarter_round 2w 6w 10w 14w o - chacha_quarter_round 3w 7w 11w 15w + chacha_quarter_round 1w 5w 9w 13w o + chacha_quarter_round 0w 4w 8w 12w End (* @@ -103,10 +98,10 @@ op diagonal_round : shuffle = Definition chacha_diagonal_round: chacha_diagonal_round = - chacha_quarter_round 0w 5w 10w 15w o - chacha_quarter_round 1w 6w 11w 12w o + chacha_quarter_round 3w 4w 9w 14w o chacha_quarter_round 2w 7w 8w 13w o - chacha_quarter_round 3w 4w 9w 14w + chacha_quarter_round 1w 6w 11w 12w o + chacha_quarter_round 0w 5w 10w 15w End (* @@ -116,9 +111,69 @@ op double_round: shuffle = Definition chacha_double_round: chacha_double_round = - chacha_column_round o chacha_diagonal_round + chacha_diagonal_round o chacha_column_round End +(* Examples and validation *) + +Definition chacha_example_state_row: + chacha_example_state_row : word32 -> word32 = + let m = ARB in + let m = (0w =+ 0x11111111w) m in + let m = (1w =+ 0x01020304w) m in + let m = (2w =+ 0x9b8d6f43w) m in + let m = (3w =+ 0x01234567w) m in + m +End + +Definition chacha_example_state_full: + chacha_example_state_full : word32 -> word32 = + let m = ARB in + let m = (0w =+ 0x879531e0w) m in + let m = (1w =+ 0xc5ecf37dw) m in + let m = (2w =+ 0x516461b1w) m in + let m = (3w =+ 0xc9a62f8aw) m in + let m = (4w =+ 0x44c20ef3w) m in + let m = (5w =+ 0x3390af7fw) m in + let m = (6w =+ 0xd9fc690bw) m in + let m = (7w =+ 0x2a5f714cw) m in + let m = (8w =+ 0x53372767w) m in + let m = (9w =+ 0xb00a5631w) m in + let m = (10w =+ 0x974c541aw) m in + let m = (11w =+ 0x359e9963w) m in + let m = (12w =+ 0x5c971061w) m in + let m = (13w =+ 0x3d631689w) m in + let m = (14w =+ 0x2098d9d6w) m in + let m = (15w =+ 0x91dbd320w) m in + m +End + +(* RFC7539 2.1.1 example *) +Theorem chacha_example_quarter_round_row[local]: + chacha_quarter_round 0w 1w 2w 3w chacha_example_state_row 0w = 0xea2a92f4w + /\ + chacha_quarter_round 0w 1w 2w 3w chacha_example_state_row 1w = 0xcb1cf8cew + /\ + chacha_quarter_round 0w 1w 2w 3w chacha_example_state_row 2w = 0x4581472ew + /\ + chacha_quarter_round 0w 1w 2w 3w chacha_example_state_row 3w = 0x5881c4bbw +Proof + EVAL_TAC +QED + +(* RFC7539 2.2.1 example *) +Theorem chacha_example_quarter_round_full[local]: + chacha_quarter_round 2w 7w 8w 13w chacha_example_state_full 2w = 0xbdb886dcw + /\ + chacha_quarter_round 2w 7w 8w 13w chacha_example_state_full 7w = 0xcfacafd2w + /\ + chacha_quarter_round 2w 7w 8w 13w chacha_example_state_full 8w = 0xe46bea80w + /\ + chacha_quarter_round 2w 7w 8w 13w chacha_example_state_full 13w = 0xccc07c79w +Proof + EVAL_TAC +QED + (* ---------------- *) (* Block boundaries *) (* ---------------- *) From e753c0b7904f2e3677c015a363e202e405bcf6e7 Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Wed, 30 Oct 2024 21:43:45 +0100 Subject: [PATCH 94/95] test for 20 rounds of chacha --- examples/riscv/chacha/chacha_specScript.sml | 49 +++++++++++++++++++++ 1 file changed, 49 insertions(+) diff --git a/examples/riscv/chacha/chacha_specScript.sml b/examples/riscv/chacha/chacha_specScript.sml index d662c8596..d29dcd69b 100644 --- a/examples/riscv/chacha/chacha_specScript.sml +++ b/examples/riscv/chacha/chacha_specScript.sml @@ -114,6 +114,20 @@ Definition chacha_double_round: chacha_diagonal_round o chacha_column_round End +Definition chacha_rounds: + chacha_rounds = + chacha_double_round o + chacha_double_round o + chacha_double_round o + chacha_double_round o + chacha_double_round o + chacha_double_round o + chacha_double_round o + chacha_double_round o + chacha_double_round o + chacha_double_round +End + (* Examples and validation *) Definition chacha_example_state_row: @@ -174,6 +188,41 @@ Proof EVAL_TAC QED +Definition chacha_example_state_key_setup: + chacha_example_state_key_setup : word32 -> word32 = + let m = ARB in + let m = (0w =+ 0x61707865w) m in + let m = (1w =+ 0x3320646ew) m in + let m = (2w =+ 0x79622d32w) m in + let m = (3w =+ 0x6b206574w) m in + let m = (4w =+ 0x03020100w) m in + let m = (5w =+ 0x07060504w) m in + let m = (6w =+ 0x0b0a0908w) m in + let m = (7w =+ 0x0f0e0d0cw) m in + let m = (8w =+ 0x13121110w) m in + let m = (9w =+ 0x17161514w) m in + let m = (10w =+ 0x1b1a1918w) m in + let m = (11w =+ 0x1f1e1d1cw) m in + let m = (12w =+ 0x00000001w) m in + let m = (13w =+ 0x09000000w) m in + let m = (14w =+ 0x4a000000w) m in + let m = (15w =+ 0x00000000w) m in + m +End + +(* RFC7539 2.3.2 example *) +Theorem chacha_example_state_key_setup[local]: + chacha_rounds chacha_example_state_key_setup 0w = 0x837778abw + /\ + chacha_rounds chacha_example_state_key_setup 1w = 0xe238d763w + /\ + chacha_rounds chacha_example_state_key_setup 2w = 0xa67ae21ew + /\ + chacha_rounds chacha_example_state_key_setup 3w = 0x5950bb2fw +Proof + EVAL_TAC +QED + (* ---------------- *) (* Block boundaries *) (* ---------------- *) From ff853e4aa77df4fcb0123f8c7b261edc2e77a222 Mon Sep 17 00:00:00 2001 From: Karl Palmskog Date: Thu, 31 Oct 2024 13:57:33 +0100 Subject: [PATCH 95/95] more chacha20 high level specs --- examples/riscv/chacha/chacha_specScript.sml | 56 ++++++++++++++++++++- 1 file changed, 54 insertions(+), 2 deletions(-) diff --git a/examples/riscv/chacha/chacha_specScript.sml b/examples/riscv/chacha/chacha_specScript.sml index d29dcd69b..7025a69e2 100644 --- a/examples/riscv/chacha/chacha_specScript.sml +++ b/examples/riscv/chacha/chacha_specScript.sml @@ -128,10 +128,62 @@ Definition chacha_rounds: chacha_double_round End +Definition chacha_add_16: + chacha_add_16 (s: word32 -> word32) + (s' : word32 -> word32) : word32 -> word32 = + let m = s in + let m = (0w =+ (s 0w) + (s' 0w)) m in + let m = (1w =+ (s 1w) + (s' 1w)) m in + let m = (2w =+ (s 2w) + (s' 2w)) m in + let m = (3w =+ (s 3w) + (s' 3w)) m in + let m = (4w =+ (s 4w) + (s' 4w)) m in + let m = (5w =+ (s 5w) + (s' 5w)) m in + let m = (6w =+ (s 6w) + (s' 6w)) m in + let m = (7w =+ (s 7w) + (s' 7w)) m in + let m = (8w =+ (s 8w) + (s' 8w)) m in + let m = (9w =+ (s 9w) + (s' 9w)) m in + let m = (10w =+ (s 10w) + (s' 10w)) m in + let m = (11w =+ (s 11w) + (s' 11w)) m in + let m = (12w =+ (s 12w) + (s' 12w)) m in + let m = (13w =+ (s 13w) + (s' 13w)) m in + let m = (14w =+ (s 14w) + (s' 14w)) m in + let m = (15w =+ (s 15w) + (s' 15w)) m in + m +End + +Definition chacha_core: + chacha_core (s:word32 -> word32) : word32 -> word32 = + let s' = chacha_rounds s in + chacha_add_16 s' s +End + +Definition chacha_setup: + chacha_setup (k : word32 -> word32) + (n : word32 -> word32) (c : word32) : word32 -> word32 = + let m = ARB in + let m = (0w =+ 0x61707865w) m in + let m = (1w =+ 0x3320646ew) m in + let m = (2w =+ 0x79622d32w) m in + let m = (3w =+ 0x6b206574w) m in + let m = (4w =+ (k 0w)) m in + let m = (5w =+ (k 1w)) m in + let m = (6w =+ (k 2w)) m in + let m = (7w =+ (k 3w)) m in + let m = (8w =+ (k 4w)) m in + let m = (9w =+ (k 5w)) m in + let m = (10w =+ (k 6w)) m in + let m = (11w =+ (k 7w)) m in + let m = (12w =+ c) m in + let m = (13w =+ (n 0w)) m in + let m = (14w =+ (n 1w)) m in + let m = (15w =+ (n 2w)) m in + m +End + (* Examples and validation *) Definition chacha_example_state_row: - chacha_example_state_row : word32 -> word32 = + chacha_example_state_row : word32 -> word32 = let m = ARB in let m = (0w =+ 0x11111111w) m in let m = (1w =+ 0x01020304w) m in @@ -141,7 +193,7 @@ Definition chacha_example_state_row: End Definition chacha_example_state_full: - chacha_example_state_full : word32 -> word32 = + chacha_example_state_full : word32 -> word32 = let m = ARB in let m = (0w =+ 0x879531e0w) m in let m = (1w =+ 0xc5ecf37dw) m in