├── README.md ├── code-injection.lisp └── kernel-seperation.lisp /README.md: -------------------------------------------------------------------------------- 1 | Toy formal verification project, from when I was learning ACL2: formally verify SecVisor, a secure hypervisor. 2 | 3 | code-injection.lisp: Seshadri, Luk, Qu, and Perrig, in their SecVisor paper, implement a hypervisor that satisfies a certain set of properties in order to prevent code injection attacks. In a later paper, the Murphi model checker is used to formally verify that their hypervisor doesn't violate their properties, but they never formally verify that the properties given are sufficient for preventing code injection attacks (model checking is incapable of proving such a statement). This file contains an ACL2 proof that the given properties are sufficient for preventing code injection attacks. Moreover, a technically weaker (but practically equivalent) version of the same properties is also sufficient. 4 | 5 | kernel-seperation.lisp: This file develops a kernel seperation property based on the above properties, plus the condition that the kernel's data region is inaccessable while arbitrary user code is executing (which the SecVisor paper postulates in the case where a shadow page table is used). This can be trivially modified to handle the case where user processes can read but not modify kernel code and data. 6 | -------------------------------------------------------------------------------- /code-injection.lisp: -------------------------------------------------------------------------------- 1 | #|| 2 | code-injection.lisp: Seshadri, Luk, Qu, and Perrig, in their SecVisor paper, implement 3 | a hypervisor that satisfies a certain set of properties in order to prevent 4 | code injection attacks. In a later paper, the Murphi model checker is used to 5 | formally verify that their hypervisor doesn't violate their properties, but 6 | they never formally verify that the properties given are sufficient for 7 | preventing code injection attacks (perhaps because it's too trivial, or perhaps 8 | because model checking is incapable of proving such a statement.) This file 9 | contains an ACL2 proof that the given properties are sufficient for preventing 10 | code injection attacks. Moreover, a technically weaker (but practically 11 | equivalent) version of the same properties is also sufficient. 12 | 13 | kernel-seperation.lisp: This file develops a kernel seperation property based 14 | on the above properties, plus the condition that the kernel's data region is 15 | inaccessable while arbitrary user code is executing (which the SecVisor paper 16 | postulates in the case where a shadow page table is used). This can be 17 | trivially modified to handle the case where user processes can read but not 18 | modify kernel code and data 19 | 20 | kernel-seperation-machine.lisp: is a refinement of kernel-seperation.lisp on a 21 | less abstract machine 22 | 23 | return-oriented-programming.lisp: allow the attack to use return-to-libc and generalized return 24 | oriented programming, and show that an exploit exists 25 | 26 | return-oriented-programming-protection.lisp: prove that protection agaisnt return oriented programming is possible 27 | programming 28 | ||# 29 | 30 | (in-package "ACL2") 31 | (include-book "misc/records" :dir :system) 32 | 33 | ;set the nth value in a record 34 | (defun sn (key pos val rec) 35 | (let* ((current-list (g key rec)) 36 | (new-list (update-nth pos val current-list))) 37 | (s key new-list rec))) 38 | 39 | ;get the nth value in a record 40 | (defun gn (key pos rec) 41 | (let* ((current-list (g key rec)) 42 | (current-nth (nth pos current-list))) 43 | current-nth)) 44 | 45 | #|| 46 | (defun contains-addr (s addrs) 47 | (if (endp addrs) 48 | nil 49 | (if (gn :mem (car addrs) s) 50 | t 51 | nil))) 52 | ||# 53 | 54 | ;a machine state looks like this 55 | ;((:xpl . , booleanp ) ;flag indicating the machine has been explioted 56 | ; (:appr . , (list)) ;list of approved code addresses. 57 | ; (:mem . , (list)) ;contents of memory; (not nil) = malicious instruction) 58 | ; (:ip . , natp)) ;the current ip. Not actually constrained to be a natp, 59 | ; but we use gn, which calls nth, which has a natp guard 60 | ; (:cpl . , booleanp ) ; the current privilege level. true = kernel, nil = user 61 | ; making cpl a booleanp doesn't simplify any proofs, so it's left unconstrained 62 | ; similarly, the ip isn't required to be a natp 63 | 64 | (encapsulate 65 | (((malicious *) => *) 66 | ((benign *) => *) 67 | ((mstep *) => *) 68 | ((valid-s? *) => *)) 69 | 70 | 71 | (local 72 | ;;this is what happens when a malicious instructon is executed 73 | (defun malicious (s) 74 | (declare (ignore s)) 75 | nil)) 76 | 77 | ;;this is what happens when a non-malicious instruction is executed 78 | (local 79 | (defun benign (s) 80 | (declare (ignore s)) 81 | nil)) 82 | 83 | ;;this is one step of the machine - could be a malicious or benign instruction 84 | (local 85 | (defun mstep (s) 86 | (declare (ignore s)) 87 | nil)) 88 | 89 | ;;valid machine states obey this invariant 90 | (local 91 | (defun valid-s? (s) 92 | (declare (ignore s)) 93 | nil)) 94 | 95 | 96 | ;;The properties we want to use are listed below. The text in the comments is 97 | ;;pulled from the SecVisor paper. "True" properties which didn't end up being 98 | ;;used are introduced with defthmd. 99 | 100 | ;; P1: Every entry into kernel mode (where an entry into kernel mode occurs at 101 | ;; the instant the privilege of the CPU changes to kernel mode) should set the 102 | ;; CPU’s Instruction Pointer (IP) to an instruction within approved kernel 103 | ;; code. 104 | 105 | ;; P2: After an entry into kernel mode places the IP within approved code, the 106 | ;; IP should continue to point to approved kernel code until the CPU exits 107 | ;; kernel mode. 108 | 109 | (defthm |p1 and p2 valid| 110 | (let* ((ip (g :ip s)) 111 | (appr (g :appr s)) 112 | (cpl (g :cpl s))) 113 | (implies (valid-s? s) 114 | (implies cpl 115 | (member ip appr))))) 116 | 117 | ;; P3: Every exit from kernel mode (where we define an exit from kernel mode 118 | ;; as a control transfer that sets the IP to an address in user memory) should 119 | ;; set the privilege level of the CPU to user mode. 120 | 121 | (defthm |p3 valid| 122 | (let* ((nxt-ip (g :ip nxt-s)) 123 | (nxt-cpl (g :cpl nxt-s)) 124 | (nxt-dpl (gn :dpl nxt-ip nxt-s))) 125 | (implies (valid-s? nxt-s) 126 | (implies (not nxt-dpl) (not nxt-cpl))))) 127 | 128 | 129 | 130 | ;; P4: Memory containing approved code should not be modifiable by any code 131 | ;; executing on the CPU, but SecVisor, or by any peripheral device. 132 | 133 | ;; this formulation works, but requires extra work to make later proofs go 134 | ;; through. 135 | 136 | ;; (defthmd |appr isn't malicious| 137 | ;; (implies (valid-s? s) 138 | ;; (not (contains-addr s (g :appr s))))) 139 | 140 | 141 | ;assume the TCB is correct, i.e., that only valid code is approved 142 | (defthmd |appr isn't malicious 2| 143 | (let ((appr (g :appr s)) 144 | (ins (gn :mem addr s))) 145 | (implies (and (member addr appr) (valid-s? s)) 146 | (not ins)))) 147 | 148 | ;specific instance of above property 149 | ;only this specific, weaker, property is actually required 150 | ;p4 isn't required if we have this prop, and p4 requires this to be 151 | ;true to in order to be meaningful, so this prop is weaker than p4 152 | (defthm |appr isn't malicious - specific| 153 | (let* ((appr (g :appr s)) 154 | (ip (g :ip s)) 155 | (ins (gn :mem ip s))) 156 | (implies (and (member ip appr) (valid-s? s)) 157 | (not ins)))) 158 | 159 | (defthm |mstep produces valid state| 160 | (implies (valid-s? s) 161 | (valid-s? (mstep s)))) 162 | 163 | (defthm |malicious produces valid state| 164 | (implies (valid-s? s) 165 | (valid-s? (malicious s)))) 166 | 167 | 168 | 169 | ;this logically vacuous property obviates the need for a couple pages of 170 | ;annoying lemmas later on 171 | (defthm |xpl is booleanp| 172 | (implies (valid-s? s) 173 | (booleanp (g :xpl s))) 174 | :rule-classes ((:type-prescription 175 | :typed-term (g :xpl s)))) 176 | 177 | 178 | ;;a malcious instruction can exploit iff it executes in executable space with 179 | ;;an elevated privilege level. 180 | 181 | ;;the executable space isn't actually used; since it's never constrained, 182 | ;;leaving it in here has no effect 183 | (defthm |exploit conditions| 184 | (let* ((nxt-s (malicious s)) 185 | (ip (g :ip s)) 186 | (exe (member ip (g :exe s))) 187 | (cpl (g :cpl s))) 188 | (implies (valid-s? s) 189 | (iff 190 | (pand cpl exe) 191 | (equal (g :xpl nxt-s) t))))) 192 | 193 | (defthm |benign can't exploit| 194 | (let ((nxt-s (benign s))) 195 | (not (g :xpl nxt-s)))) 196 | 197 | 198 | 199 | #|| 200 | ;;if memory contains an malicious instruction, we execute it, otherwise we 201 | ;;execute an benign instruction. This formulation creates an invalid rewrite 202 | ;;rule, so we write is a slightly more obscure fashion below 203 | 204 | (defthm |mstep runs instruction| 205 | (let* ((ip (g :ip s)) 206 | (ins (gn :mem ip s))) 207 | (implies (valid-s? s) 208 | (if ins 209 | (equal (mstep s apr) (malicious s)) 210 | (equal (mstep s apr) (benign s)))))) 211 | ||# 212 | 213 | (defthm |mstep runs malicious| 214 | (let* ((ip (g :ip s)) 215 | (ins (gn :mem ip s))) 216 | (implies (and (valid-s? s) ins) 217 | (equal (mstep s) (malicious s))))) 218 | 219 | (defthm |mstep runs benign| 220 | (let* ((ip (g :ip s)) 221 | (ins (gn :mem ip s))) 222 | (implies (and (valid-s? s) (not ins)) 223 | (equal (mstep s) (benign s))))) 224 | #|| 225 | (defthm |mstep runs instruction| 226 | (let* ((ip (g :ip s)) 227 | (ins (gn :mem ip s))) 228 | (implies (and (valid-s? s) (not ins)) 229 | (or (equal (mstep s) (benign s)) 230 | (equal (mstep s) (malicious s))))) 231 | :rule-classes ((:type-prescription 232 | :typed-term (mstep s)))) 233 | ||# 234 | ) 235 | 236 | 237 | ;just seeing if this obvious property is provable; apparently ACL2 needs to be 238 | ;steered a bit to see it. 239 | (defthmd |xpl requires mal| 240 | (let* ((ip (g :ip s)) 241 | (ins (gn :mem ip s))) 242 | (implies (and (valid-s? s) (not ins)) 243 | (not (g :xpl (mstep s))))) 244 | :hints (("Goal" 245 | :do-not-induct t 246 | :in-theory (disable |mstep runs benign|) 247 | :use ((:instance |mstep runs benign|))))) 248 | 249 | 250 | ;something like this lemma is required to prove |xpl requires cpl|, but this 251 | ;generates an illegal rewrite rule, so we'll try proving the contrapositive and 252 | ;using that 253 | (defthm |heniously obvious lemma| 254 | (IMPLIES 255 | (VALID-S? S) 256 | (NOT (AND (NOT (EQUAL (G :XPL (MALICIOUS S)) T)) 257 | (G :XPL (MALICIOUS S))))) 258 | :rule-classes nil 259 | :hints (("Goal" 260 | :do-not-induct t 261 | :in-theory (disable |malicious produces valid state|) 262 | :use ((:instance |malicious produces valid state|))))) 263 | 264 | 265 | (defthm |heniously obvious lemma - contrapositive| 266 | (IMPLIES 267 | (AND (NOT (EQUAL (G :XPL (MALICIOUS S)) T)) 268 | (G :XPL (MALICIOUS S))) 269 | (NOT (VALID-S? S))) 270 | :hints (("Goal" 271 | :do-not-induct t 272 | :in-theory (disable |malicious produces valid state|) 273 | :use ((:instance |malicious produces valid state|))))) 274 | 275 | 276 | ;a sucessful attack requires an elevated privilege level 277 | (defthm |xpl requires cpl| 278 | (let* ((nxt-s (malicious s)) 279 | (cpl (g :cpl s))) 280 | (implies (and (g :xpl nxt-s) (valid-s? s)) 281 | cpl)) 282 | :hints (("Goal" 283 | :in-theory (disable |exploit conditions|) 284 | :use ((:instance |exploit conditions|))))) 285 | 286 | ;elevated privilege level implies that we're running approved code 287 | (defthm |xpl requires appr| 288 | (let* ((nxt-s (mstep s)) 289 | (xpl (g :xpl nxt-s)) 290 | (appr (g :appr s)) 291 | (ip (g :ip s))) 292 | (implies (and xpl (valid-s? s)) 293 | (member ip appr))) 294 | ;; :otf-flg t 295 | :hints (("Goal" 296 | :cases ((not (let* ((ip (g :ip s)) 297 | (ins (gn :mem ip s))) 298 | ins)))))) 299 | ;; :do-not '(eliminate-destructors generalize fertilize) 300 | ;; :do-not-induct t))) 301 | 302 | ;approved code can't cause an exploit 303 | (defthm |appr is safe| 304 | (let* ((nxt-s (mstep s)) 305 | (xpl (g :xpl nxt-s)) 306 | (appr (g :appr s)) 307 | (ip (g :ip s))) 308 | (implies (and (member ip appr) (valid-s? s)) 309 | (not xpl))) 310 | :hints (("Goal" 311 | :in-theory (disable |xpl requires appr|)))) 312 | 313 | 314 | ;; given any valid machine state, running one step is safe 315 | (set-ignore-ok t) 316 | (defthm |mstep is safe from code injection| 317 | (let* ((nxt-s (mstep s)) 318 | (xpl (g :xpl nxt-s)) 319 | (appr (g :appr s)) 320 | (ip (g :ip s)) 321 | (ins (gn :mem ip s))) 322 | (implies (valid-s? s) 323 | (not xpl))) 324 | :hints (("Goal" 325 | :use ((:instance |xpl requires appr|))) 326 | ("Goal'''" 327 | :in-theory (disable |xpl requires appr| 328 | |appr isn't malicious - specific| 329 | |appr isn't malicious 2|)))) 330 | (set-ignore-ok nil) 331 | 332 | ;; this function returns true if running an arbitrary sequence of steps doesn't 333 | ;; allow a code injection attack 334 | (defun running-is-safe (s l) 335 | (declare (xargs :measure (acl2-count l))) 336 | (let* ((nxt-s (mstep s)) 337 | (xpl (g :xpl nxt-s))) 338 | (if (atom l) t 339 | (if xpl 340 | nil 341 | (running-is-safe nxt-s (cdr l)))))) 342 | 343 | ;; code injection attacks can't happen with arbitrary sequences 344 | (defthm |running is safe| 345 | (implies (valid-s? s) 346 | (running-is-safe s l))) 347 | 348 | 349 | ;; FIXME: 350 | ;1. it would be a lot clearer if the minimal set of required constraints were 351 | ;included in the encapsulte 352 | ;2. it might be better to have a machine step be a function of the machine 353 | ;state and some oracle which indicates if a malicious or a benign 'user' is running 354 | -------------------------------------------------------------------------------- /kernel-seperation.lisp: -------------------------------------------------------------------------------- 1 | 2 | #|| 3 | code-injection.lisp: Seshadri, Luk, Qu, and Perrig, in their SecVisor paper, implement 4 | a hypervisor that satisfies a certain set of properties in order to prevent 5 | code injection attacks. In a later paper, the Murphi model checker is used to 6 | formally verify that their hypervisor doesn't violate their properties, but 7 | they never formally verify that the properties given are sufficient for 8 | preventing code injection attacks (perhaps because it's too trivial, or perhaps 9 | because model checking is incapable of proving such a statement.) This file 10 | contains an ACL2 proof that the given properties are sufficient for preventing 11 | code injection attacks. Moreover, a technically weaker (but practically 12 | equivalent) version of the same properties is also sufficient. 13 | 14 | kernel-seperation.lisp: This file develops a kernel seperation property based 15 | on the above properties, plus the condition that the kernel's data region is 16 | inaccessable while arbitrary user code is executing (which the SecVisor paper 17 | postulates in the case where a shadow page table is used). This can be 18 | trivially modified to handle the case where user processes can read but not 19 | modify kernel code and data 20 | 21 | kernel-seperation-machine.lisp: is a refinement of kernel-seperation.lisp on a 22 | less abstract machine 23 | 24 | return-oriented-programming.lisp: allow the attack to use return-to-libc and generalized return 25 | oriented programming, and show that an exploit exists 26 | 27 | return-oriented-programming-protection.lisp: prove that protection agaisnt return oriented programming is possible 28 | programming 29 | ||# 30 | 31 | (in-package "ACL2") 32 | (include-book "misc/records" :dir :system) 33 | 34 | ;this file is patterned after Sandip Ray's virtual-spec. 35 | 36 | ;the user has no access to kernel space, but the kernel can affect user space, 37 | ;in 'abstract' terms, a 'concrete' op can do one of these things. 38 | 39 | ;1. User op: this is some abstract op in user space and a no-op in kernel space 40 | 41 | ;2. Self contained kernel op: this is some abstract op in kernel space and a 42 | ;no-op in user space 43 | 44 | ;3. Kernel writes user (and possibly itself): this is an abstract op in kernel space and an abstract 45 | ;op with non-deterministic I/O in user space 46 | 47 | ;4. Kernel reads user: this is an abstract op with non-determinsitic I/O in 48 | ;kernel space 49 | 50 | ;5. Kernel reads and writes user: this is a abstract op with non-deterministic 51 | ;I/O in both user and kernel space 52 | 53 | 54 | ;;These mappings are more explict than they need to be. This was done to help 55 | ;;track down some bugs in the formulation of the correctness properties, and 56 | ;;there's really no reason these can't be moved back into the encapsulate block 57 | ;;and made abstract 58 | 59 | 60 | ;;nil = kernel op and t = user op 61 | 62 | (local 63 | (defun map-id (id op st-id ld-id) 64 | (declare (ignore op)) 65 | ;uop = user op; kop = kernel op 66 | (cond (id '(t)) ;any uop 67 | ((and st-id ld-id) '(t nil)) ;kop which reads and writes user 68 | (st-id '(t nil)) ;kop which writes user 69 | (ld-id '(nil)) ;kop which reads user 70 | (t '(nil)))));kop which only touches kernel 71 | 72 | (local 73 | (defun map-op-io (id op st-id ld-id) 74 | (declare (ignore op)) 75 | (cond (id '(nil)) 76 | ((and st-id ld-id) '(t t)) 77 | (st-id '(t nil)) 78 | (ld-id '(t)) 79 | (t '(nil))))) 80 | 81 | (local 82 | (defun map-op (id op st-id ld-id) 83 | (cond (id (list op)) 84 | ((and st-id ld-id) (list op op)) 85 | (st-id (list op op)) 86 | (ld-id (list op)) 87 | (t (list op))))) 88 | 89 | (defun cop-listp (cop-list) 90 | (let* ((cop-item (first cop-list)) 91 | (id (first cop-item)) 92 | (st-id (third cop-item))) 93 | (cond ((endp cop-list) t) 94 | ((and (booleanp id) (booleanp st-id)) (cop-listp (rest cop-list))) 95 | (t nil)))) 96 | 97 | (encapsulate 98 | 99 | (((abs->conc *) => *) 100 | ((conc->abs * *) => *) 101 | ((cop * * * * *) => *) 102 | ((aop * * *) => *) 103 | ; ((map-id * * *) => *) 104 | ; ((map-op * * *) => *) 105 | ((valid-abs? *) => *) 106 | ((valid-conc? *) => *)) 107 | 108 | ;;this turns an abstract state into a concrete machine state 109 | (local 110 | (defun abs->conc (abs) 111 | (declare (ignore abs)) 112 | nil)) 113 | 114 | ;;this rips out the abstract state associated with either user or kernel space 115 | ;;from a concrete state of the whole machine 116 | (local 117 | (defun conc->abs (conc id) 118 | (declare (ignore conc id)) 119 | nil)) 120 | 121 | ;; concrete op - inputs are: 122 | ;; concrete state 123 | ;; the id of the operator 124 | ;; the operation 125 | ;; the store target of the op 126 | ;; the load target of the op 127 | (local 128 | (defun cop (conc id op st-id ld-id) 129 | (declare (ignore conc id op st-id ld-id)) 130 | nil)) 131 | 132 | 133 | ;;abstract op - inputs are: 134 | ;;abstract state 135 | ;;some oracular I/O 136 | (local 137 | (defun aop (abs op io) 138 | (declare (ignore abs op io)) 139 | nil)) 140 | 141 | ;;not actually an invariant 142 | (local 143 | (defun valid-abs? (abs) 144 | (declare (ignore abs)) 145 | nil)) 146 | 147 | ;;invariant on concrete machine states 148 | (local 149 | (defun valid-conc? (conc) 150 | (declare (ignore conc)) 151 | nil)) 152 | 153 | 154 | ;;this -1 / -2 nonsense is a sure sign that this is the wrong approach. This 155 | ;;entire thing could probably be refactored to 1/2 to 1/3 its current size and 156 | ;;complexity, but it's 4am, and this is just a justification for trying this 157 | ;;on a less abstract machine, so I'm going to see if I can finish this 158 | ;;incredibly inelegant version before heading to work, so I can avoid ever 159 | ;;looking at it again :) 160 | 161 | ;;other changes to make while refactoring: 162 | ;; 1. don't use nil as an identifier 163 | ;; 2. pass around a single variable which contains all the relevant op info, 164 | ;;instead of using 4 vars for each concrete op and 3 vars for each abstract op 165 | 166 | ;;in retrospect, it probably would have saved time to recast these properties 167 | ;;in a simpler way. 168 | 169 | 170 | ;;the following two properties capture all combinations listed in 1. - 5., above 171 | (defthm aop-makes-sense-1 172 | (let* ((abs-ids (map-id id op st-id ld-id)) 173 | (abs-ops (map-op id op st-id ld-id)) 174 | (abs-ios (map-op-io id op st-id ld-id)) 175 | (abs-op (first abs-ops)) 176 | (abs-io (first abs-ios))) 177 | (implies (and (valid-conc? conc) 178 | (equal (length abs-ids) 1)) 179 | (equal (conc->abs abs-id (cop conc id op st-id ld-id)) 180 | (if (equal abs-id id) 181 | (aop (conc->abs abs-id conc) abs-op abs-io) 182 | (conc->abs abs-id conc)))))) 183 | 184 | (defthm aop-makes-sense-2 185 | (let* ((abs-ids (map-id id op st-id ld-id)) 186 | (abs-ops (map-op id op st-id ld-id)) 187 | (abs-ios (map-op-io id op st-id ld-id)) 188 | (cop-result (cop conc id op st-id ld-id)) 189 | (abs-id-1 (first abs-ids)) 190 | (abs-op-1 (first abs-ops)) 191 | (abs-io-1 (first abs-ios)) 192 | (abs-id-2 (second abs-ids)) 193 | (abs-op-2 (second abs-ops)) 194 | (abs-io-2 (second abs-ios))) 195 | (implies (and (valid-conc? conc) 196 | (equal (length abs-ids) 2)) 197 | (and (equal (conc->abs abs-id-1 cop-result) 198 | (aop (conc->abs abs-id-1 conc) abs-op-1 abs-io-1)) 199 | (equal (conc->abs abs-id-2 cop-result) 200 | (aop (conc->abs abs-id-2 conc) abs-op-2 abs-io-2)))))) 201 | 202 | (defthm abs->conc-is-inverse-of-conc->abs 203 | (implies (valid-abs? abs) 204 | (equal (conc->abs id (abs->conc abs)) 205 | (g id abs)))) 206 | 207 | ;;the invariant holds 208 | (defthm cop-is-valid 209 | (implies (valid-conc? conc) 210 | (valid-conc? (cop conc id op st-id ld-id)))) 211 | 212 | ;; don't really need this 213 | ;; (defthm aop-is-valid 214 | ;; (implies (valid-abs? abs) 215 | ;; (valid-abs? (aop abs op io)))) 216 | 217 | ;;we want something satisfying the invariant when we make a conrete machine 218 | ;;state 219 | (defthm abs->conc-is-valid 220 | (implies (valid-abs? abs) 221 | (valid-conc? (abs->conc abs)))) 222 | 223 | ) 224 | 225 | (defun crun (conc cop-list) 226 | (let ((cop-item (first cop-list))) 227 | (if (endp cop-list) 228 | conc 229 | (crun (cop conc (first cop-item) (second cop-item) (third cop-item) 230 | (fourth cop-item)) 231 | (rest cop-list))))) 232 | 233 | (defthm crun-is-valid 234 | (implies (valid-conc? conc) 235 | (valid-conc? (crun conc cop-list)))) 236 | 237 | (defun arun (abs aop-list) 238 | (let ((aop-item (first aop-list))) 239 | (if (endp aop-list) 240 | abs 241 | (arun (aop abs (first aop-item) (second aop-item)) 242 | (rest aop-list))))) 243 | 244 | #|| 245 | (defthmd arun-is-valid 246 | (implies (valid-abs? abs) 247 | (valid-abs? (arun abs aop-list)))) 248 | ||# 249 | 250 | (defun relevant-abs-sequence (id cop-list) 251 | (let* ((cop-item (first cop-list)) 252 | (abs-ids (map-id (first cop-item) (second cop-item) (third cop-item) 253 | (fourth cop-item))) 254 | (abs-ops (map-op (first cop-item) (second cop-item) (third cop-item) 255 | (fourth cop-item))) 256 | (abs-ios (map-op-io (first cop-item) (second cop-item) (third cop-item) 257 | (fourth cop-item))) 258 | (abs-id-1 (first abs-ids)) 259 | (abs-id-2 (second abs-ids)) 260 | (aop-item-1 (list (first abs-ops) (first abs-ios))) 261 | (aop-item-2 (list (second abs-ops) (second abs-ios)))) 262 | (cond ((endp cop-list) nil) 263 | ((and (equal (length abs-ids) 2) (equal abs-id-2 id)) 264 | (cons aop-item-2 (relevant-abs-sequence id (rest cop-list)))) 265 | ((equal abs-id-1 id) 266 | (cons aop-item-1 (relevant-abs-sequence id (rest cop-list)))) 267 | (t (relevant-abs-sequence id (rest cop-list)))))) 268 | 269 | 270 | ;these meaningless crock-* theorems were just used for debugging 271 | (defthmd crock 272 | (let* ((abs-item (relevant-abs-sequence 273 | abs-id 274 | (list (list id op st-id ld-id))))) 275 | (implies (atom op) 276 | (por (equal (length abs-item) 1) 277 | (equal (length abs-item) 0))))) 278 | 279 | 280 | (defthmd crock-ocl-check 281 | (equal (length (map-id t op st-id ld-id)) 1)) 282 | 283 | (defthmd crock-op-corr-1 284 | (IMPLIES (AND (VALID-CONC? CONC) 285 | (BOOLEANP ID) 286 | ID) 287 | (EQUAL (CONC->ABS NIL (COP CONC T OP ST-ID LD-ID)) 288 | (CONC->ABS NIL CONC)))) 289 | 290 | (defthm op-corr-lemma-1 291 | (IMPLIES (AND ST-ID (VALID-CONC? CONC)) 292 | (EQUAL (CONC->ABS NIL (COP CONC NIL OP T NIL)) 293 | (AOP (CONC->ABS NIL CONC) OP NIL))) 294 | :hints (("Goal" 295 | :in-theory (disable aop-makes-sense-2) 296 | :use ((:instance aop-makes-sense-2 297 | (st-id t) 298 | (id nil) 299 | (ld-id nil)))))) 300 | 301 | (defthm op-corr-lemma-2 302 | (IMPLIES (AND ST-ID 303 | (VALID-CONC? CONC)) 304 | (EQUAL (CONC->ABS T (COP CONC NIL OP ST-ID LD-ID)) 305 | (AOP (CONC->ABS T CONC) OP T))) 306 | :hints (("Goal" 307 | :in-theory (disable aop-makes-sense-2) 308 | :use ((:instance aop-makes-sense-2 309 | (st-id st-id) 310 | (id nil)))))) 311 | 312 | (defthm op-corr-lemma-3 313 | (IMPLIES (AND ST-ID LD-ID (VALID-CONC? CONC)) 314 | (EQUAL (CONC->ABS NIL (COP CONC NIL OP T LD-ID)) 315 | (AOP (CONC->ABS NIL CONC) OP T))) 316 | :hints (("Goal" 317 | :in-theory (disable aop-makes-sense-2) 318 | :use ((:instance aop-makes-sense-2 319 | (st-id t) 320 | (id nil)))))) 321 | 322 | 323 | ;this rewrite rule isn't required to prove run-correspondence, but proving this 324 | ;superfluous lemma was invaluable in figuring out that the three lemmas listed 325 | ;above are necessary 326 | (defthmd op-correspondence 327 | (let* ((ras (relevant-abs-sequence 328 | abs-id 329 | (list (list id op st-id ld-id)))) 330 | (abs-item (first ras)) 331 | (abs-op (first abs-item)) 332 | (abs-io (second abs-item))) 333 | (implies (and (valid-conc? conc) 334 | (booleanp id) 335 | (booleanp st-id) 336 | (booleanp abs-id)) 337 | (equal (conc->abs abs-id (cop conc id op st-id ld-id)) 338 | (if (not (equal (length ras) 0)) 339 | (aop (conc->abs abs-id conc) abs-op abs-io) 340 | (conc->abs abs-id conc)))))) 341 | 342 | (defthm run-correspondence 343 | (implies (and (valid-conc? conc) 344 | (booleanp abs-id) 345 | (cop-listp cop-list)) 346 | (equal (conc->abs abs-id (crun conc cop-list)) 347 | (arun 348 | (conc->abs abs-id conc) 349 | (relevant-abs-sequence abs-id cop-list))))) 350 | 351 | ;;! 352 | (defthm seperation-is-sound 353 | (let ((conc (abs->conc abs))) 354 | (implies (and (valid-abs? abs) 355 | (booleanp abs-id) 356 | (cop-listp cop-list)) 357 | (equal (conc->abs abs-id (crun conc cop-list)) 358 | (arun 359 | (conc->abs abs-id conc) 360 | (relevant-abs-sequence abs-id cop-list))))) 361 | :hints (("Goal" 362 | :in-theory (disable run-correspondence) 363 | :use ((:instance run-correspondence 364 | (conc (abs->conc abs))))))) 365 | 366 | --------------------------------------------------------------------------------