├── .gitignore ├── README.md └── rust.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | rust-redex 2 | ========== 3 | 4 | This repo contains an encoding of Patina using Redex. This is intended 5 | to serve as a starting point for formal proofs but also for modeling 6 | new features to Rust. 7 | -------------------------------------------------------------------------------- /rust.rkt: -------------------------------------------------------------------------------- 1 | ;; -*- coding: utf-8; -*- 2 | 3 | ;; Cheat sheet for unicode, using M-x set-input-method as TeX: 4 | ;; \alpha -> α 5 | ;; \beta -> β 6 | ;; \gamma -> γ 7 | ;; \cdot -> · 8 | ;; \ell -> ℓ 9 | ;; \in -> ∈ 10 | ;; \notin -> ∉ 11 | ;; and so on 12 | ;; lifetime-≤ 13 | 14 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 15 | ;; REDEX MODEL FOR RUST 16 | ;; 17 | ;; Current state: 18 | ;; 19 | ;; FIXME - Type system rules do not handle vectors well 20 | ;; 21 | ;; FIXME - Type system rules for match issue a loan for entire Option but 22 | ;; in Real Rust we have this downcast notion so we can issue a more 23 | ;; targeted loan; I don't think this makes any real difference in practice, 24 | ;; so long as we are limited to Option loans. 25 | ;; 26 | ;; FIXME - Consider just removing by-ref match and instead having an operator 27 | ;; to convert Option to Option<&T> 28 | ;; 29 | ;; FIXME - check that local variables types are bounded by their lifetime 30 | ;; 31 | ;; FIXME - add in relationships between lifetime parameters that we can infer from types 32 | 33 | #lang racket 34 | 35 | (require redex 36 | rackunit) 37 | 38 | (define-language Patina 39 | (prog (srs fns)) 40 | ;; structures: 41 | (srs (sr ...)) 42 | (sr (struct s ℓs (ty ...))) 43 | ;; lifetimes: 44 | (ℓs (ℓ ...)) 45 | ;; function def'ns 46 | (fns (fn ...)) 47 | (fn (fun g ℓs vdecls bk)) 48 | ;; blocks: 49 | (bk (block ℓ vdecls sts)) 50 | ;; variable decls 51 | (vdecls [vdecl ...]) 52 | (vdecl (x ty)) 53 | ;; statements: 54 | [sts (st ...)] 55 | (st (lv = rv) 56 | (lv := rv) 57 | (free lv) ;; shallow free 58 | (drop lv) ;; deep free 59 | (call g ℓs lvs) 60 | (match lv (Some mode x => bk) (None => bk)) 61 | bk) 62 | ;; lvalues : 63 | ;; changing "field names" to be numbers 64 | (lvs (lv ...)) 65 | (lv x ;; variable 66 | (lv · f) ;; field projection 67 | (lv @ lv) ;; indexing 68 | (* lv)) ;; deref 69 | ;; rvalues : 70 | (rv lv ;; use lvalue 71 | (& ℓ mq lv) ;; take address of lvalue 72 | (struct s ℓs (lv ...)) ;; struct constant 73 | number ;; constant number 74 | (lv + lv) ;; sum 75 | (new lv) ;; allocate memory 76 | (Some lv) ;; create an Option with Some 77 | (None ty) ;; create an Option with None 78 | (vec ty lv ...) ;; create a fixed-length vector 79 | (vec-len lv) ;; extract length of a vector 80 | (pack lv ty) ;; convert fixed-length to DST 81 | ) 82 | (mode (ref ℓ mq) by-value) 83 | ;; types : 84 | (tys (ty ...)) 85 | (ty (struct s ℓs) ;; s<'ℓ...> 86 | (~ ty) ;; ~t 87 | (& ℓ mq ty) ;; &'ℓ mq t 88 | int 89 | (Option ty) 90 | (vec ty olen)) 91 | ;; mq : mutability qualifier 92 | (mq mut imm) 93 | (mqs [mq ...]) 94 | ;; variables 95 | (x variable-not-otherwise-mentioned) 96 | ;; function names 97 | (g variable-not-otherwise-mentioned) 98 | ;; structure names 99 | (s variable-not-otherwise-mentioned) 100 | ;; labels 101 | (ℓ variable-not-otherwise-mentioned) 102 | ;; field "names" 103 | (f number) 104 | (fs [f ...]) 105 | ;; z -- sizes, offsets 106 | [zs (z ...)] 107 | [z number] 108 | ;; l -- vector lengths 109 | [l number] 110 | ;; olen -- optional vector lengths 111 | [olen number erased] 112 | ;; hack for debugging 113 | (debug debug-me) 114 | ) 115 | 116 | (check-not-false (redex-match Patina ty (term (vec int 3)))) 117 | 118 | ;;;; 119 | ;; 120 | ;; EVALUATION 121 | ;; 122 | ;;;; 123 | 124 | (define-extended-language Patina-machine Patina 125 | ;; a configuration of the machine 126 | [C (prog H V T S)] 127 | ;; H (heap) : maps addresses to heap values 128 | [H ((α hv) ...)] 129 | ;; hv (heap values) 130 | [hv (ptr α) (int number) void] 131 | ;; V: maps variable names to addresses 132 | [V (vmap ...)] 133 | [vmap ((x α) ...)] 134 | ;; T : a map from names to types 135 | [T (vdecls ...)] 136 | ;; θ : a substitution (from to) 137 | [θ [(ℓ ℓ) ...]] 138 | ;; S (stack) : stack-frames contain pending statements 139 | [S (sf ...)] 140 | [sf (ℓ sts)] 141 | [(αs βs γs) (number ...)] 142 | [(α β γ) number] 143 | ) 144 | 145 | ;; unit test setup for helper fns 146 | 147 | (define test-srs 148 | (term [(struct A () (int)) 149 | (struct B (l0) (int (& l0 mut int))) 150 | (struct C (l0) ((struct A ()) 151 | (struct B (l0)))) 152 | (struct D (l0) ((struct C (l0)) 153 | (struct A ()) 154 | (struct C (l0)) 155 | (struct B (l0)))) 156 | (struct E () [(~ int)]) 157 | ])) 158 | 159 | (check-not-false (redex-match Patina-machine srs test-srs)) 160 | 161 | (define test-T (term [[(i int) 162 | (p (~ int))] 163 | [(a (struct A ())) 164 | (b (struct B (static))) 165 | (c (struct C (static))) 166 | (q (& b1 imm int)) 167 | (r (~ int)) 168 | (s (Option (~ int))) 169 | (ints3 (vec int 3)) 170 | (i0 int) 171 | (i1 int) 172 | (i2 int) 173 | (i3 int) 174 | (ints3p (& b1 imm (vec int 3))) 175 | (intsp (& b1 imm (vec int erased))) 176 | ]])) 177 | (check-not-false (redex-match Patina-machine T test-T)) 178 | 179 | (define test-V (term (((i 10) 180 | (p 11)) 181 | ((a 12) 182 | (b 13) 183 | (c 15) 184 | (q 18) 185 | (r 19) 186 | (s 20) 187 | (ints3 22) 188 | (i0 25) 189 | (i1 26) 190 | (i2 27) 191 | (i3 28) 192 | (ints3p 29) 193 | (intsp 30))))) 194 | (check-not-false (redex-match Patina-machine V test-V)) 195 | 196 | (define test-H (term [(10 (int 22)) ;; i == 22 197 | (11 (ptr 99)) ;; p == 99 198 | (12 (int 23)) ;; a:0 199 | (13 (int 24)) ;; b:0 200 | (14 (ptr 98)) ;; b:1 201 | (15 (int 25)) ;; c:1:0 202 | (16 (int 26)) ;; c:1:0 203 | (17 (ptr 97)) ;; c:1:1 204 | (18 (ptr 98)) ;; q 205 | (19 (ptr 96)) ;; r 206 | (20 (int 1)) ;; s – discriminant 207 | (21 (ptr 95)) ;; s – payload 208 | (22 (int 10)) ;; ints3 @ 0 209 | (23 (int 11)) ;; ints3 @ 1 210 | (24 (int 12)) ;; ints3 @ 2 211 | (25 (int 0)) ;; i0 212 | (26 (int 1)) ;; i1 213 | (27 (int 2)) ;; i2 214 | (28 (int 3)) ;; i3 215 | (29 (ptr 22)) ;; ints3p 216 | (30 (ptr 22)) ;; intsp ptr 217 | (31 (int 3)) ;; intsp dst 218 | (95 (int 31)) ;; *payload(s) 219 | (96 (int 30)) ;; *c:1:1 220 | (97 (int 29)) ;; *c:1:1 221 | (98 (int 28)) ;; *b:1 222 | (99 (int 27))])) ;; *p 223 | (check-not-false (redex-match Patina-machine H test-H)) 224 | 225 | (define test-dst-srs 226 | (term [(struct RCDataInt3 () [int (vec int 3)]) 227 | (struct RCInt3 (l0) [(& l0 imm (struct RCDataInt3 []))]) 228 | (struct RCDataIntN () (int (vec int erased))) 229 | (struct RCIntN (l0) [(& l0 imm (struct RCDataIntN []))]) 230 | (struct Cycle1 () [(Option (~ (struct Cycle []))) (vec int erased)]) 231 | (struct Cycle2 () [(Option (~ (struct Cycle [])))]) 232 | ])) 233 | 234 | (check-not-false (redex-match Patina-machine srs test-dst-srs)) 235 | 236 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 237 | ;; simple test prog that assigns to the result pointer 238 | 239 | (define twentytwo-main 240 | (term (fun main [a] [(outp (& a mut int))] 241 | (block l0 [] [((* outp) = 22)])))) 242 | 243 | (check-not-false (redex-match Patina-machine fn twentytwo-main)) 244 | 245 | (define twentytwo-fns (term [,twentytwo-main])) 246 | (check-not-false (redex-match Patina-machine fns twentytwo-fns)) 247 | 248 | (define twentytwo-prog 249 | (term (,test-srs ,twentytwo-fns))) 250 | (check-not-false (redex-match Patina-machine prog twentytwo-prog)) 251 | 252 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 253 | ;; test prog that creates a linked list and counts down 254 | 255 | (define sum-srs 256 | (term [(struct List () (int 257 | (Option (~ (struct List [])))))])) 258 | (check-not-false (redex-match Patina-machine srs sum-srs)) 259 | 260 | (define sum-main 261 | (term (fun main [a] [(outp (& a mut int))] 262 | (block l0 263 | [(i int) 264 | (n (Option (~ (struct List [])))) 265 | (s (struct List [])) 266 | (l (~ (struct List [])))] 267 | [(i = 22) 268 | (n = (None (~ (struct List [])))) 269 | (s = (struct List [] (i n))) 270 | (l = (new s)) 271 | (i := 44) 272 | (n = (Some l)) 273 | (s = (struct List [] (i n))) 274 | (l = (new s)) 275 | (block l1 276 | [(p (& l1 imm (struct List [])))] 277 | [(p = (& l1 imm (* l))) 278 | (call sum-list [l1 a] [p outp]) 279 | ]) 280 | (drop l) 281 | ])))) 282 | (check-not-false (redex-match Patina-machine fn sum-main)) 283 | 284 | ;; fn sum-list<'a,'b>(inp: &'a List, outp: &'b mut int) { 285 | ;; let r: int = inp.0; 286 | ;; match inp.1 { 287 | ;; Some(ref next1) => { // next1: &~List 288 | ;; let next2 = &**next1; 289 | ;; let b = 0; 290 | ;; { 291 | ;; let c = &mut b; 292 | ;; sum-list(next2, c); 293 | ;; } 294 | ;; *outp = r + b; 295 | ;; } 296 | ;; None => { 297 | ;; *outp = r + b; 298 | ;; } 299 | ;; } 300 | ;; } 301 | (define sum-sum-list 302 | (term (fun sum-list [a b] [(inp (& a imm (struct List []))) 303 | (outp (& b mut int))] 304 | (block l0 305 | [(r int)] 306 | [(r = ((* inp) · 0)) 307 | (match ((* inp) · 1) 308 | (Some (ref l0 imm) next1 => 309 | (block l1 310 | [(next2 (& l1 imm (struct List []))) 311 | (b int)] 312 | [(next2 = (& l1 imm (* (* next1)))) 313 | (b = 0) 314 | (block l3 315 | [(c (& l3 mut int))] 316 | [(c = (& l3 mut b)) 317 | (call sum-list [l1 l3] [next2 c])]) 318 | ((* outp) := (r + b))])) 319 | (None => 320 | (block l1 321 | [] 322 | [((* outp) := r)])))])))) 323 | (check-not-false (redex-match Patina-machine fn sum-sum-list)) 324 | 325 | (define sum-fns 326 | (term (,sum-main ,sum-sum-list))) 327 | 328 | (define sum-prog 329 | (term (,sum-srs ,sum-fns))) 330 | (check-not-false (redex-match Patina-machine prog sum-prog)) 331 | 332 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 333 | ;; test prog that creates an RC vector, casts it to DST, and then 334 | ;; accesses it 335 | 336 | (define dst-srs 337 | (term [(struct RCDataInt3 () [int (vec int 3)]) 338 | (struct RCInt3 (l0) [(& l0 imm (struct RCDataInt3 []))]) 339 | (struct RCDataIntN () (int (vec int erased))) 340 | (struct RCIntN (l0) [(& l0 imm (struct RCDataIntN []))]) 341 | ])) 342 | 343 | ;; gonna be super tedious... 344 | (define dst-main 345 | (term (fun main [a] [(outp (& a mut int))] 346 | (block l0 [(i1 int) 347 | (i2 int) 348 | (i3 int) 349 | (v (vec int 3)) 350 | (rd3 (struct RCDataInt3 [])) 351 | (rd3p (& l0 imm (struct RCDataInt3 []))) 352 | (rdNp (& l0 imm (struct RCDataIntN []))) 353 | ] 354 | [(i1 = 22) 355 | (i2 = 23) 356 | (i3 = 24) 357 | (v = (vec int i1 i2 i3)) 358 | (i1 = 1) 359 | (rd3 = (struct RCDataInt3 [] (i1 v))) 360 | (rd3p = (& l0 imm rd3)) 361 | (rdNp = (pack rd3p (& l0 imm (struct RCDataIntN [])))) 362 | (i1 = 0) 363 | (i2 = 0) 364 | (i2 = ((((* rdNp) · 1) @ i1) + i2)) 365 | (i1 = 1) 366 | (i2 = ((((* rdNp) · 1) @ i1) + i2)) 367 | (i1 = 2) 368 | (i2 = ((((* rdNp) · 1) @ i1) + i2)) 369 | ((* outp) = i2) 370 | ])))) 371 | (check-not-false (redex-match Patina-machine fn dst-main)) 372 | 373 | (define dst-prog 374 | (term (,dst-srs [,dst-main]))) 375 | (check-not-false (redex-match Patina-machine prog dst-prog)) 376 | 377 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 378 | ;; initial -- the initial state of the machine 379 | 380 | (define initial-H (term [(0 (int 0)) ;; static value for result code 381 | (1 (ptr 0))])) ;; pointer to result code 382 | (check-not-false (redex-match Patina-machine H initial-H)) 383 | 384 | (define initial-V (term [[(resultp 1)]])) 385 | (check-not-false (redex-match Patina-machine V initial-V)) 386 | 387 | (define initial-T (term [[(resultp (& l0 mut int))]])) 388 | (check-not-false (redex-match Patina-machine T initial-T)) 389 | 390 | (define initial-S (term [(l0 [(call main (l0) (resultp))])])) 391 | (check-not-false (redex-match Patina-machine S initial-S)) 392 | 393 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 394 | ;; ∈, ∉ -- a metafunction like member 395 | 396 | (define-metafunction Patina-machine 397 | ∈ : any [any ...] -> any 398 | 399 | [(∈ any_0 [any_1 ...]) 400 | ,(not (not (member (term any_0) (term [any_1 ...]))))]) 401 | 402 | (define-metafunction Patina-machine 403 | ∉ : any [any ...] -> any 404 | 405 | [(∉ any_0 [any_1 ...]) 406 | ,(not (member (term any_0) (term [any_1 ...])))]) 407 | 408 | (test-equal (term (∈ 1 [1 2 3])) (term #t)) 409 | (test-equal (term (∈ 4 [1 2 3])) (term #f)) 410 | (test-equal (term (∉ 1 [1 2 3])) (term #f)) 411 | (test-equal (term (∉ 4 [1 2 3])) (term #t)) 412 | 413 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 414 | ;; common logic functions in term form 415 | 416 | (define-metafunction Patina-machine 417 | ¬ : boolean -> boolean 418 | 419 | [(¬ #t) #f] 420 | [(¬ #f) #t]) 421 | 422 | (define-metafunction Patina-machine 423 | ∨ : boolean boolean -> boolean 424 | 425 | [(∨ #f #f) #f] 426 | [(∨ _ _) #t]) 427 | 428 | (define-metafunction Patina-machine 429 | ∧ : boolean boolean -> boolean 430 | 431 | [(∧ #t #t) #t] 432 | [(∧ _ _) #f]) 433 | 434 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 435 | ;; if-true list bools -- like filter but takes a list of booleans 436 | 437 | (define-metafunction Patina-machine 438 | if-true : [any ...] [boolean ...] -> [any ...] 439 | 440 | [(if-true any_0 any_1) 441 | ,(for/list ([x (term any_0)] [t (term any_1)] #:when t) x)]) 442 | 443 | (test-equal (term (if-true [1 2 3 4 5] [#f #t #f #t #f])) 444 | (term [2 4])) 445 | 446 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 447 | ;; ∀, ∃ -- useful functions for operating over vectors of booleans. 448 | ;; Particularly useful in combination with macros and maps. 449 | 450 | (define-metafunction Patina-machine 451 | ∀ : [any ...] -> boolean 452 | [(∀ [_ ... #f _ ...]) #f] 453 | [(∀ _) #t]) 454 | 455 | (define-metafunction Patina-machine 456 | ∃ : [any ...] -> boolean 457 | [(∃ [#f ...]) #f] 458 | [(∃ _) #t]) 459 | 460 | (define-metafunction Patina-machine 461 | ∄ : [any ...] -> boolean 462 | [(∄ any) (¬ (∃ any))]) 463 | 464 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 465 | ;; ∪ -- a metafunction for set union 466 | 467 | (define-metafunction Patina-machine 468 | ∪ : [any ...] [any ...] -> [any ...] 469 | 470 | [(∪ [any_0 any_1 ...] [any_2 ...]) 471 | (∪ [any_1 ...] [any_2 ...]) 472 | (side-condition (term (∈ any_0 [any_2 ...])))] 473 | 474 | [(∪ [any_0 any_1 ...] [any_2 ...]) 475 | (∪ [any_1 ...] [any_0 any_2 ...])] 476 | 477 | [(∪ [] [any_1 ...]) 478 | [any_1 ...]] 479 | 480 | ) 481 | 482 | (test-equal (term (∪ [1 4] [1 2 3])) (term [4 1 2 3])) 483 | 484 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 485 | ;; ⊆ -- a metafunction for subseteq comparison 486 | 487 | (define-metafunction Patina-machine 488 | ⊆ : [any ...] [any ...] -> boolean 489 | 490 | [(⊆ [] [any ...]) #t] 491 | 492 | [(⊆ [any_0 any_1 ...] [any_2 ...]) 493 | (and (∀ [∃ any_0 [any_2 ...]]) 494 | (⊆ [any_1 ...] [any_2 ...]))] 495 | 496 | ) 497 | 498 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 499 | ;; ⊎ -- a metafunction for disjoint set union 500 | 501 | (define-metafunction Patina-machine 502 | ⊎ : [any ...] [any ...] -> [any ...] 503 | 504 | [(⊎ [any_0 ...] [any_1 ...]) 505 | ([any_0 ...] [any_1 ...])] 506 | 507 | ) 508 | 509 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 510 | ;; \\ -- a metafunction for set difference 511 | 512 | (define-metafunction Patina-machine 513 | \\ : [any ...] [any ...] -> [any ...] 514 | 515 | [(\\ any_0 any_1) 516 | ,(remove* (term any_1) (term any_0))]) 517 | 518 | (test-equal (term (\\ [1 2 3] [2])) (term [1 3])) 519 | (test-equal (term (\\ [1 2 3] [4])) (term [1 2 3])) 520 | 521 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 522 | ;; has -- a metafunction like assoc that works on lists like '((k v) (k1 v1)) 523 | 524 | (define-metafunction Patina-machine 525 | has : any [(any any) ...] -> any 526 | [(has any_k {_ ... [any_k _] _ ...}) #t] 527 | [(has _ _) #f]) 528 | 529 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 530 | ;; get -- a metafunction like assoc that works on lists like '((k v) (k1 v1)) 531 | 532 | (define-metafunction Patina-machine 533 | get : any [(any any) ...] -> any 534 | [(get any {_ ... [any any_v] _ ...}) any_v]) 535 | 536 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 537 | ;; get* -- search through multiple assoc lists 538 | 539 | (define (get* key lists) 540 | (for*/first ([l lists] 541 | [p (in-value (assoc key l))] 542 | #:when p) 543 | (second p))) 544 | 545 | (test-equal (get* (term a) (term (((a 1) (b 2)) ((c 3))))) 546 | 1) 547 | 548 | (test-equal (get* (term c) (term (((a 1) (b 2)) ((c 3))))) 549 | 3) 550 | 551 | (test-equal (get* (term e) (term (((a 1) (b 2)) ((c 3)) ((d 4) (e 5))))) 552 | 5) 553 | 554 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 555 | ;; sort-heap -- sort heap address in ascending order 556 | 557 | (define (sort-heap heap) 558 | (sort heap (λ (pair1 pair2) (< (car pair1) 559 | (car pair2))))) 560 | 561 | ;; useful heap predicates 562 | 563 | (define (in-range addr base size) 564 | (and (>= addr base) 565 | (< addr (+ base size)))) 566 | 567 | (define (select H α z) 568 | (let* [(matching (filter (λ (pair) (in-range (car pair) α z)) H)) 569 | (sorted (sort-heap matching)) 570 | (values (map cadr sorted))] 571 | values)) 572 | 573 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 574 | ;; reject – useful for debugging since it causes contract errors 575 | 576 | (define-metafunction Patina-machine 577 | reject : debug -> number 578 | 579 | [(reject debug) 0]) 580 | 581 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 582 | ;; sum 583 | 584 | (define-metafunction Patina-machine 585 | sum : zs -> z 586 | [(sum any) ,(apply + (term any))]) 587 | 588 | (test-equal (term (sum [1 2 3])) 589 | (term 6)) 590 | 591 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 592 | ;; len 593 | 594 | (define-metafunction Patina-machine 595 | len : [any ...] -> number 596 | [(len any) ,(length (term any))]) 597 | 598 | (test-equal (term (len [1 2 3])) 599 | (term 3)) 600 | 601 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 602 | ;; prefix sum 603 | 604 | (define-metafunction Patina-machine 605 | prefix-sum : z zs -> zs 606 | 607 | [(prefix-sum z_a ()) ()] 608 | [(prefix-sum z_a (z_b z_c ...)) 609 | [z_d z_e ...] 610 | (where z_d (sum [z_a z_b])) 611 | (where [z_e ...] (prefix-sum z_d [z_c ...]))] 612 | 613 | ) 614 | 615 | (test-equal (term (prefix-sum 0 ())) 616 | (term ())) 617 | 618 | (test-equal (term (prefix-sum 0 (1 2 3))) 619 | (term (1 3 6))) 620 | 621 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 622 | ;; offset, inc, and dec 623 | 624 | (define-metafunction Patina-machine 625 | offset : α z -> α 626 | 627 | [(offset α z) ,(+ (term α) (term z))]) 628 | 629 | (define-metafunction Patina-machine 630 | inc : α -> α 631 | 632 | [(inc z) ,(add1 (term z))]) 633 | 634 | (define-metafunction Patina-machine 635 | dec : α -> α 636 | 637 | [(dec z) ,(sub1 (term z))]) 638 | 639 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 640 | ;; deref function -- search a heap for a given address. 641 | 642 | (define-metafunction Patina-machine 643 | deref : H α -> hv 644 | 645 | [(deref H α) 646 | (get α H)]) 647 | 648 | (test-equal (term (deref [(1 (ptr 22))] 1)) (term (ptr 22))) 649 | (test-equal (term (deref [(2 (ptr 23)) (1 (int 22))] 1)) (term (int 22))) 650 | 651 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 652 | ;; fun-defn -- 653 | 654 | (define-metafunction Patina-machine 655 | fun-defn : fns g -> fn 656 | 657 | [(fun-defn (fn_0 fn_1 ...) g) 658 | fn_0 659 | (where (fun g ℓs ((x ty) ...) bk) fn_0)] 660 | 661 | [(fun-defn (fn_0 fn_1 ...) g) 662 | (fun-defn (fn_1 ...) g)]) 663 | 664 | (test-equal (term (fun-defn ,twentytwo-fns main)) 665 | (term ,twentytwo-main)) 666 | 667 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 668 | ;; update -- replaces value for α 669 | 670 | (define-metafunction Patina-machine 671 | update : H α hv -> H 672 | 673 | [(update ((α_0 hv_0) (α_1 hv_1) ...) α_0 hv_2) 674 | ((α_0 hv_2) (α_1 hv_1) ...)] 675 | 676 | [(update ((α_0 hv_0) (α_1 hv_1) ...) α_2 hv_2) 677 | ,(append (term ((α_0 hv_0))) (term (update ((α_1 hv_1) ...) α_2 hv_2)))]) 678 | 679 | (test-equal (term (update [(2 (ptr 23)) (1 (int 22))] 1 (int 23))) 680 | (term ((2 (ptr 23)) (1 (int 23))))) 681 | 682 | (test-equal (term (update [(2 (ptr 23)) (1 (int 22))] 2 (int 23))) 683 | (term ((2 (int 23)) (1 (int 22))))) 684 | 685 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 686 | ;; extend -- grows a heap with z contiguous new addresses 687 | 688 | (define-metafunction Patina-machine 689 | extend : H α z -> H 690 | 691 | [(extend H α 0) H] 692 | 693 | [(extend ((β hv) ...) α z) 694 | (extend ((α void) (β hv) ...) 695 | ,(add1 (term α)) 696 | ,(sub1 (term z)))]) 697 | 698 | (test-equal (term (extend [(10 (ptr 1)) 699 | (11 (int 2)) 700 | (12 (ptr 3))] 701 | 13 702 | 3)) 703 | (term [(15 void) 704 | (14 void) 705 | (13 void) 706 | (10 (ptr 1)) 707 | (11 (int 2)) 708 | (12 (ptr 3))])) 709 | 710 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 711 | ;; shrink -- removes z contiguous addresses from domain of heap 712 | 713 | (define-metafunction Patina-machine 714 | shrink : H α z -> H 715 | 716 | [(shrink H α z) 717 | ,(filter (λ (pair) (not (in-range (car pair) (term α) (term z)))) 718 | (term H))]) 719 | 720 | (test-equal (term (shrink [(10 (ptr 1)) 721 | (11 (int 2)) 722 | (12 (ptr 3)) 723 | (13 (ptr 4)) 724 | (14 (ptr 5))] 725 | 11 726 | 3)) 727 | (term [(10 (ptr 1)) 728 | (14 (ptr 5))])) 729 | 730 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 731 | ;; subst-ℓ 732 | 733 | (define-metafunction Patina-machine 734 | subst-ℓ : θ ℓ -> ℓ 735 | 736 | [(subst-ℓ θ static) static] 737 | [(subst-ℓ θ ℓ) (get ℓ θ) (side-condition (term (has ℓ θ)))] 738 | [(subst-ℓ θ ℓ) ℓ (side-condition (term (¬ (has ℓ θ))))] 739 | ) 740 | 741 | (test-equal (term (subst-ℓ [] static)) (term static)) 742 | (test-equal (term (subst-ℓ [(a b)] a)) (term b)) 743 | (test-equal (term (subst-ℓ [(a b)] c)) (term c)) 744 | 745 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 746 | ;; subst-ty 747 | 748 | (define-metafunction Patina-machine 749 | subst-ty : θ ty -> ty 750 | 751 | [(subst-ty θ (struct s [ℓ ...])) 752 | (struct s [(subst-ℓ θ ℓ) ...])] 753 | 754 | [(subst-ty θ (~ ty)) 755 | (~ (subst-ty θ ty))] 756 | 757 | [(subst-ty θ (& ℓ mq ty)) 758 | (& (subst-ℓ θ ℓ) mq (subst-ty θ ty))] 759 | 760 | [(subst-ty θ int) 761 | int] 762 | 763 | [(subst-ty θ (Option ty)) 764 | (Option (subst-ty θ ty))] 765 | 766 | [(subst-ty θ (vec ty olen)) 767 | (vec (subst-ty θ ty) olen)] 768 | ) 769 | 770 | (test-equal (term (subst-ty [(a b) (b c)] (struct s [a b]))) 771 | (term (struct s [b c]))) 772 | 773 | (test-equal (term (subst-ty [(a b) (b c)] (~ (struct s [a b])))) 774 | (term (~ (struct s [b c])))) 775 | 776 | (test-equal (term (subst-ty [(a b) (b c)] (& a mut (struct s [a b])))) 777 | (term (& b mut (struct s [b c])))) 778 | 779 | (test-equal (term (subst-ty [(a b) (b c)] int)) 780 | (term int)) 781 | 782 | (test-equal (term (subst-ty [(a b) (b c)] (Option (& a mut int)))) 783 | (term (Option (& b mut int)))) 784 | 785 | (test-equal (term (subst-ty [(a b) (b c)] (vec (& a mut int) erased))) 786 | (term (vec (& b mut int) erased))) 787 | 788 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 789 | ;; subst-vdecl(s) 790 | 791 | (define-metafunction Patina-machine 792 | subst-vdecl : θ vdecl -> vdecl 793 | [(subst-vdecl θ (x ty)) (x (subst-ty θ ty))]) 794 | 795 | (define-metafunction Patina-machine 796 | subst-vdecls : θ vdecls -> vdecls 797 | [(subst-vdecls θ (vdecl ...)) ((subst-vdecl θ vdecl) ...)]) 798 | 799 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 800 | ;; subst-rv 801 | 802 | (define-metafunction Patina-machine 803 | subst-rv : θ rv -> rv 804 | 805 | [(subst-rv θ (& ℓ mq lv)) 806 | (& (subst-ℓ θ ℓ) mq lv)] 807 | 808 | [(subst-rv θ (struct s (ℓ ...) (lv ...))) 809 | (struct s ((subst-ℓ θ ℓ) ...) (lv ...))] 810 | 811 | [(subst-rv θ (None ty)) 812 | (None (subst-ty θ ty))] 813 | 814 | [(subst-rv θ (vec ty lv ...)) 815 | (vec (subst-ty θ ty) lv ...)] 816 | 817 | [(subst-rv θ (pack lv ty)) 818 | (pack lv (subst-ty θ ty))] 819 | 820 | [(subst-rv _ any) any]) 821 | 822 | (test-equal (term (subst-rv ((a b) (b c)) (& a imm x))) 823 | (term (& b imm x))) 824 | 825 | (test-equal (term (subst-rv ((a b) (b c)) (struct s (a b) (x y)))) 826 | (term (struct s (b c) (x y)))) 827 | 828 | (test-equal (term (subst-rv ((a b) (b c)) (None (& a imm int)))) 829 | (term (None (& b imm int)))) 830 | 831 | (test-equal (term (subst-rv ((a b) (b c)) (vec (& a imm int) x y z))) 832 | (term (vec (& b imm int) x y z))) 833 | 834 | (test-equal (term (subst-rv ((a b) (b c)) (pack x (& a imm int)))) 835 | (term (pack x (& b imm int)))) 836 | 837 | (test-equal (term (subst-rv ((a b) (b c)) (x + y))) 838 | (term (x + y))) 839 | 840 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 841 | ;; subst-mode / subst-st / subst-bk 842 | 843 | (define-metafunction Patina-machine 844 | subst-mode : θ mode -> mode 845 | 846 | [(subst-mode θ by-value) by-value] 847 | [(subst-mode θ (ref ℓ mq)) (ref (subst-ℓ θ ℓ) mq)]) 848 | 849 | (define-metafunction Patina-machine 850 | subst-st : θ st -> st 851 | 852 | [(subst-st θ (lv = rv)) 853 | (lv = (subst-rv θ rv))] 854 | 855 | [(subst-st θ (lv := rv)) 856 | (lv := (subst-rv θ rv))] 857 | 858 | [(subst-st θ (call g (ℓ ...) lvs)) 859 | (call g ((subst-ℓ θ ℓ) ...) lvs)] 860 | 861 | [(subst-st θ (match lv (Some mode x => bk_1) (None => bk_2))) 862 | (match lv (Some (subst-mode θ mode) x => (subst-bk θ bk_1)) (None => (subst-bk θ bk_2)))] 863 | 864 | [(subst-st θ bk) 865 | (subst-bk θ bk)] 866 | 867 | [(subst-st _ any) any]) 868 | 869 | (define-metafunction Patina-machine 870 | subst-bk : θ bk -> bk 871 | 872 | [(subst-bk θ_0 (block ℓ_0 ((x ty) ...) (st ...))) 873 | (block ℓ_1 ((x (subst-ty θ_2 ty)) ...) ((subst-st θ_2 st) ...)) 874 | ; ℓ_0 is being rebound, so remove the now irrelevant old substutitions for ℓ_0 875 | (where θ_1 (if-true θ_0 ,(map (λ (kv) (not (eq? (term ℓ_0) (car kv)))) (term θ_0)))) 876 | ; ℓ_1 is a capture-avoiding (deterministic) replacement for ℓ_0 (will be ℓ_0 if it's already fine) 877 | (where ℓ_1 ,(variable-not-in (term θ_1) (term ℓ_0))) 878 | ; add the substitution [ℓ_0 ↦ ℓ_1] to θ_1 879 | (where θ_2 (∪ θ_1 ((ℓ_0 ℓ_1)))) 880 | ] 881 | ) 882 | 883 | (test-equal (term (subst-st ((a b) (b c)) (x = (& a imm y)))) 884 | (term (x = (& b imm y)))) 885 | 886 | (test-equal (term (subst-st ((a b) (b c)) (call g (b a) (x y z)))) 887 | (term (call g (c b) (x y z)))) 888 | 889 | (test-equal 890 | (term (subst-st ((a b) (b c)) (block d ((x (& d imm int))) ((y = (vec (& a imm int) x)))))) 891 | (term (block d ((x (& d imm int))) ((y = (vec (& b imm int) x))))) 892 | ) 893 | (test-equal 894 | (term (subst-st ((a a) (b c)) (block a ((x (& a imm int))) ((y = (vec (& b imm int) x)))))) 895 | (term (block a ((x (& a imm int))) ((y = (vec (& c imm int) x)))))) 896 | (test-equal 897 | (term (subst-st ((a b)) (block c ((x (& d imm int))) ((y = (vec (& a imm int) x)))))) 898 | (term (block c ((x (& d imm int))) ((y = (vec (& b imm int) x)))))) 899 | ; avoid capture 900 | (test-equal 901 | (term (subst-st ((a b) (b c)) 902 | (block a ((x (& a imm int))) ((y = (vec (& b imm int) x)))))) 903 | (term (block a ((x (& a imm int))) ((y = (vec (& c imm int) x)))))) 904 | ; a case where we actually need to use a different name 905 | (test-equal 906 | (term (subst-st ((a b) (b c)) 907 | (block c ((x (& a imm int)) (y (& b imm int))) ((y = (vec (& c imm int) x)))))) 908 | (term (block c1 ((x (& b imm int)) (y (& c imm int))) ((y = (vec (& c1 imm int) x)))))) 909 | 910 | (test-equal 911 | (term (subst-st ((l1 ℓfresh)) 912 | (block lll ((p (& l1 imm (struct List ())))) 913 | ((p = (& l1 imm (* l))) 914 | (call sum-list (l1 a) (p outp)))))) 915 | (term (block lll ((p (& ℓfresh imm (struct List ())))) 916 | ((p = (& ℓfresh imm (* l))) 917 | (call sum-list (ℓfresh a) (p outp)))))) 918 | 919 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 920 | ;; field-tys 921 | 922 | (define-metafunction Patina-machine 923 | field-tys : srs s ℓs -> (ty ...) 924 | 925 | [(field-tys ((struct s_0 (ℓ_0 ...) (ty_0 ...)) sr ...) s_0 [ℓ_1 ...]) 926 | ((subst-ty θ ty_0) ...) 927 | (where θ [(ℓ_0 ℓ_1) ...])] 928 | 929 | [(field-tys ((struct s_0 (ℓ_0 ...) (ty_0 ...)) sr ...) s_1 ℓs_1) 930 | (field-tys (sr ...) s_1 ℓs_1)]) 931 | 932 | (test-equal (term (field-tys ,test-srs A ())) 933 | (term (int))) 934 | (test-equal (term (field-tys ,test-srs D (static))) 935 | (term ((struct C (static)) (struct A ()) (struct C (static)) (struct B (static))))) 936 | 937 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 938 | ;; is-DST 939 | 940 | (define-metafunction Patina-machine 941 | is-DST : srs ty -> boolean 942 | 943 | [(is-DST srs ty) (is-DST-1 [] srs ty)]) 944 | 945 | (define-metafunction Patina-machine 946 | is-DST-1 : [s ...] srs ty -> boolean 947 | 948 | [(is-DST-1 [s_a ...] srs (struct s ℓs)) 949 | #false 950 | (side-condition (member (term s) (term [s_a ...])))] 951 | [(is-DST-1 [s_a ...] srs (struct s ℓs)) 952 | (is-DST-1 [s s_a ...] srs ty_z) 953 | (where (ty_a ... ty_z) (field-tys srs s ℓs))] 954 | [(is-DST-1 [s ...] srs (~ ty)) #false] 955 | [(is-DST-1 [s ...] srs (& ℓ mq ty)) #false] 956 | [(is-DST-1 [s ...] srs int) #false] 957 | [(is-DST-1 [s ...] srs (Option ty)) (is-DST-1 [s ...] srs ty)] 958 | [(is-DST-1 [s ...] srs (vec ty erased)) #true] 959 | [(is-DST-1 [s ...] srs (vec ty l)) #false]) 960 | 961 | (test-equal (term (is-DST ,test-dst-srs (~ (vec int erased)))) 962 | #false) 963 | 964 | (test-equal (term (is-DST ,test-dst-srs (vec int erased))) 965 | #true) 966 | 967 | (test-equal (term (is-DST ,test-dst-srs (struct RCDataInt3 []))) 968 | #false) 969 | 970 | (test-equal (term (is-DST ,test-dst-srs (struct RCInt3 [a]))) 971 | #false) 972 | 973 | (test-equal (term (is-DST ,test-dst-srs (struct RCDataIntN []))) 974 | #true) 975 | 976 | (test-equal (term (is-DST ,test-dst-srs (struct RCIntN [a]))) 977 | #false) 978 | 979 | (test-equal (term (is-DST ,test-dst-srs (struct Cycle1 []))) 980 | #true) 981 | 982 | (test-equal (term (is-DST ,test-dst-srs (struct Cycle2 []))) 983 | #false) 984 | 985 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 986 | ;; sizeof 987 | 988 | (define-metafunction Patina-machine 989 | sizeof : srs ty -> z 990 | 991 | [(sizeof srs int) 992 | 1] 993 | 994 | [(sizeof srs (~ ty)) 995 | 1 996 | (side-condition (not (term (is-DST srs ty))))] 997 | 998 | [(sizeof srs (~ ty)) 999 | 2 1000 | (side-condition (term (is-DST srs ty)))] 1001 | 1002 | [(sizeof srs (& ℓ mq ty)) 1003 | 1 1004 | (side-condition (not (term (is-DST srs ty))))] 1005 | 1006 | [(sizeof srs (& ℓ mq ty)) 1007 | 2 1008 | (side-condition (term (is-DST srs ty)))] 1009 | 1010 | [(sizeof srs (struct s ℓs)) 1011 | (sum [(sizeof srs ty) ...]) 1012 | (where [ty ...] (field-tys srs s ℓs))] 1013 | 1014 | [(sizeof srs (vec ty l)) 1015 | ,(* (term (sizeof srs ty)) (term l))] 1016 | 1017 | [(sizeof srs (Option ty)) 1018 | ,(add1 (term (sizeof srs ty)))] 1019 | 1020 | ) 1021 | 1022 | (test-equal (term (sizeof ,test-srs (struct A ()))) 1023 | (term 1)) 1024 | 1025 | (test-equal (term (sizeof ,test-srs (struct B (static)))) 1026 | (term 2)) 1027 | 1028 | (test-equal (term (sizeof ,test-srs (struct C (static)))) 1029 | (term 3)) 1030 | 1031 | (test-equal (term (sizeof ,test-srs (Option (struct C (static))))) 1032 | (term 4)) 1033 | 1034 | (test-equal (term (sizeof ,test-srs (vec int 3))) 1035 | (term 3)) 1036 | 1037 | (test-equal (term (sizeof ,test-srs (& b1 imm (vec int 3)))) 1038 | (term 1)) 1039 | 1040 | (test-equal (term (sizeof ,test-srs (& b1 imm (vec int erased)))) 1041 | (term 2)) 1042 | 1043 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1044 | ;; sizeof-dst 1045 | 1046 | (define-metafunction Patina-machine 1047 | sizeof-dst : srs ty hv -> z 1048 | 1049 | [(sizeof-dst srs (vec ty erased) (int l)) 1050 | ,(* (term (sizeof srs ty)) (term l))] 1051 | 1052 | [(sizeof-dst srs (struct s ℓs) hv) 1053 | (sum [z_a z_z]) 1054 | (where [ty_a ... ty_z] (field-tys srs s ℓs)) 1055 | (where z_a (sum [(sizeof srs ty_a) ...])) 1056 | (where z_z (sizeof-dst srs ty_z hv))] 1057 | 1058 | ) 1059 | 1060 | (test-equal (term (sizeof ,test-srs (struct A ()))) 1061 | (term 1)) 1062 | 1063 | (test-equal (term (sizeof ,test-srs (struct B (static)))) 1064 | (term 2)) 1065 | 1066 | (test-equal (term (sizeof ,test-srs (struct C (static)))) 1067 | (term 3)) 1068 | 1069 | (test-equal (term (sizeof ,test-srs (Option (struct C (static))))) 1070 | (term 4)) 1071 | 1072 | (test-equal (term (sizeof ,test-srs (vec int 3))) 1073 | (term 3)) 1074 | 1075 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1076 | ;; memcopy -- copies memory from one address to another 1077 | 1078 | (define-metafunction Patina-machine 1079 | memcopy : H α β z -> H 1080 | 1081 | [(memcopy H α β 0) H] 1082 | 1083 | [(memcopy H α β z) 1084 | (memcopy (update H α (deref H β)) 1085 | ,(add1 (term α)) 1086 | ,(add1 (term β)) 1087 | ,(sub1 (term z)))]) 1088 | 1089 | (test-equal (term (memcopy [(10 (ptr 1)) 1090 | (11 (int 2)) 1091 | (12 (ptr 3)) 1092 | (20 (ptr 4)) 1093 | (21 (int 5)) 1094 | (22 (ptr 6))] 1095 | 20 1096 | 10 1097 | 3)) 1098 | (term [(10 (ptr 1)) 1099 | (11 (int 2)) 1100 | (12 (ptr 3)) 1101 | (20 (ptr 1)) 1102 | (21 (int 2)) 1103 | (22 (ptr 3))])) 1104 | 1105 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1106 | ;; vaddr -- lookup addr of variable in V 1107 | 1108 | (define-metafunction Patina-machine 1109 | vaddr : V x -> α 1110 | 1111 | [(vaddr V x_0) 1112 | ,(get* (term x_0) (term V))]) 1113 | 1114 | (test-equal (term (vaddr (((a 0) (b 1)) ((c 2))) a)) 1115 | (term 0)) 1116 | (test-equal (term (vaddr (((a 0) (b 1)) ((c 2))) b)) 1117 | (term 1)) 1118 | (test-equal (term (vaddr (((a 0) (b 1)) ((c 2))) c)) 1119 | (term 2)) 1120 | 1121 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1122 | ;; vtype -- lookup type of variable in V 1123 | 1124 | (define-metafunction Patina-machine 1125 | vtype : T x -> ty 1126 | 1127 | [(vtype T x_0) 1128 | ,(get* (term x_0) (term T))]) 1129 | 1130 | (test-equal (term (vtype ,test-T i)) (term int)) 1131 | 1132 | (test-equal (term (vtype ,test-T c)) (term (struct C (static)))) 1133 | 1134 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1135 | ;; field-names -- determines the offsets of each field of a struct 1136 | 1137 | (define-metafunction Patina-machine 1138 | field-names : srs s ℓs -> fs 1139 | 1140 | [(field-names srs s ℓs) 1141 | ,(range (term z)) 1142 | (where tys (field-tys srs s ℓs)) 1143 | (where z (len tys))] 1144 | 1145 | ) 1146 | 1147 | (test-equal (term (field-names ,test-srs C (static))) 1148 | (term [0 1])) 1149 | 1150 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1151 | ;; field-offsets -- determines the offsets of each field of a struct 1152 | 1153 | (define-metafunction Patina-machine 1154 | field-offsets : srs s ℓs -> zs 1155 | 1156 | [(field-offsets srs s ℓs) 1157 | (prefix-sum 0 (0 z ...)) 1158 | (where (ty_a ... ty_z) (field-tys srs s ℓs)) 1159 | (where (z ...) [(sizeof srs ty_a) ...])] 1160 | 1161 | ) 1162 | 1163 | (test-equal (term (field-offsets ,test-srs C (static))) 1164 | (term (0 1))) 1165 | (test-equal (term (field-offsets ,test-srs D (static))) 1166 | (term (0 3 4 7))) 1167 | 1168 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1169 | ;; vec-offsets -- determines the offsets of each element of a vector 1170 | 1171 | (define-metafunction Patina-machine 1172 | vec-offsets : srs ty l -> zs 1173 | 1174 | [(vec-offsets srs ty 0) 1175 | []] 1176 | 1177 | [(vec-offsets srs ty 1) 1178 | [0]] 1179 | 1180 | [(vec-offsets srs ty l) ;; really, really inefficient. 1181 | (z_a ... z_y (offset z_y (sizeof srs ty))) 1182 | (where [z_a ... z_y] (vec-offsets srs ty (dec l)))] 1183 | 1184 | ) 1185 | 1186 | (test-equal (term (vec-offsets ,test-srs int 3)) 1187 | (term (0 1 2))) 1188 | 1189 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1190 | ;; vec-tys -- returns the types of each element in a vector, 1191 | ;; which is just the vector element type repeated N times 1192 | 1193 | (define-metafunction Patina-machine 1194 | vec-tys : srs ty l -> tys 1195 | 1196 | [(vec-tys srs ty 0) 1197 | []] 1198 | 1199 | [(vec-tys srs ty 1) 1200 | [ty]] 1201 | 1202 | [(vec-tys srs ty l) 1203 | (ty ty_a ...) 1204 | (where [ty_a ...] (vec-tys srs ty (dec l)))] 1205 | 1206 | ) 1207 | 1208 | (test-equal (term (vec-tys ,test-srs int 3)) 1209 | (term (int int int))) 1210 | 1211 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1212 | ;; offsetof 1213 | 1214 | (define-metafunction Patina-machine 1215 | offsetof : srs s ℓs f -> z 1216 | 1217 | [(offsetof srs s ℓs f) 1218 | ,(foldl + 0 (map (λ (t) (term (sizeof srs ,t))) 1219 | (take (term (field-tys srs s ℓs)) 1220 | (term f))))]) 1221 | 1222 | (test-equal (term (offsetof ,test-srs C (static) 0)) 1223 | (term 0)) 1224 | 1225 | (test-equal (term (offsetof ,test-srs C (static) 1)) 1226 | (term 1)) 1227 | 1228 | (test-equal (term (offsetof ,test-srs D (static) 1)) 1229 | (term 3)) 1230 | 1231 | (test-equal (term (offsetof ,test-srs D (static) 3)) 1232 | (term 7)) 1233 | 1234 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1235 | ;; lvtype -- compute type of an lvalue 1236 | 1237 | (define-metafunction Patina-machine 1238 | dereftype : ty -> ty 1239 | 1240 | [(dereftype (~ ty)) ty] 1241 | [(dereftype (& ℓ mq ty)) ty]) 1242 | 1243 | (define-metafunction Patina-machine 1244 | fieldtype : srs ty f -> ty 1245 | 1246 | [(fieldtype srs (struct s ℓs) f) 1247 | ,(car (drop (term (field-tys srs s ℓs)) (term f)))]) ; fixme--surely a better way 1248 | 1249 | (define-metafunction Patina-machine 1250 | lvtype : srs T lv -> ty 1251 | 1252 | [(lvtype srs T x) 1253 | (vtype T x)] 1254 | 1255 | [(lvtype srs T (* lv)) 1256 | (dereftype (lvtype srs T lv))] 1257 | 1258 | [(lvtype srs T (lv · f)) 1259 | (fieldtype srs (lvtype srs T lv) f)]) 1260 | 1261 | (test-equal (term (lvtype ,test-srs ,test-T (* p))) (term int)) 1262 | 1263 | (test-equal (term (lvtype ,test-srs ,test-T (c · 1))) (term (struct B (static)))) 1264 | 1265 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1266 | ;; lvaddr -- lookup addr of variable in V 1267 | 1268 | (define-metafunction Patina-machine 1269 | lvaddr-elem : srs H V T ty l lv lv -> z 1270 | 1271 | [(lvaddr-elem srs H V T ty_e l_v lv_v lv_i) 1272 | (offset (lvaddr srs H V T lv_v) z_e) 1273 | (where α_i (lvaddr srs H V T lv_i)) 1274 | (where (int l_i) (deref H α_i)) 1275 | (where z_e ,(* (term l_i) (term (sizeof srs ty_e)))) 1276 | (side-condition (>= (term l_i) 0)) 1277 | (side-condition (< (term l_i) (term l_v)))] 1278 | 1279 | ) 1280 | 1281 | (define-metafunction Patina-machine 1282 | lvaddr : srs H V T lv -> α 1283 | 1284 | [(lvaddr srs H V T x) 1285 | (vaddr V x)] 1286 | 1287 | [(lvaddr srs H V T (* lv)) 1288 | α 1289 | (where (ptr α) (deref H (lvaddr srs H V T lv)))] 1290 | 1291 | [(lvaddr srs H V T (lv · f)) 1292 | (offset (lvaddr srs H V T lv) 1293 | (offsetof srs s ℓs f)) 1294 | (where (struct s ℓs) (lvtype srs T lv))] 1295 | 1296 | ;; indexing into a fixed-length vector 1297 | [(lvaddr srs H V T (lv_v @ lv_i)) 1298 | (lvaddr-elem srs H V T ty_e l_v lv_v lv_i) 1299 | (where (vec ty_e l_v) (lvtype srs T lv_v))] 1300 | 1301 | ;; indexing into a dynamically sized vector 1302 | [(lvaddr srs H V T (lv_v @ lv_i)) 1303 | (lvaddr-elem srs H V T ty_e l_v lv_v lv_i) 1304 | (where (vec ty_e erased) (lvtype srs T lv_v)) 1305 | (where (int l_v) (reified srs H V T lv_v))] 1306 | 1307 | ) 1308 | 1309 | (test-equal (term (lvaddr ,test-srs ,test-H ,test-V ,test-T (c · 1))) 1310 | (term 16)) 1311 | 1312 | (test-equal (term (lvaddr ,test-srs ,test-H ,test-V ,test-T ((c · 1) · 1))) 1313 | (term 17)) 1314 | 1315 | (test-equal (term (lvaddr ,test-srs ,test-H ,test-V ,test-T (* ((c · 1) · 1)))) 1316 | (term 97)) 1317 | 1318 | (test-equal (term (lvaddr ,test-srs ,test-H ,test-V ,test-T (ints3 @ i1))) 1319 | (term 23)) 1320 | 1321 | ;(test-equal (term (lvaddr ,test-srs ,test-H ,test-V ,test-T (ints3 @ i4))) 1322 | ; (term 23)) 1323 | 1324 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1325 | ;; reified -- given a LV of DST type, identifies and returns the "reified" 1326 | ;; portion (i.e., the length). Must be behind the most recent pointer. 1327 | 1328 | (define-metafunction Patina-machine 1329 | reified : srs H V T lv -> hv 1330 | 1331 | [(reified srs H V T (* lv)) 1332 | (deref H (inc α)) 1333 | (where α (lvaddr srs H V T lv))] 1334 | 1335 | [(reified srs H V T (lv_o · f)) 1336 | (reified srs H V T lv_o)] 1337 | 1338 | [(reified srs H V T (lv_v @ lv_i)) 1339 | (reified srs H V T lv_v)] 1340 | 1341 | ) 1342 | 1343 | (test-equal (term (reified ,test-srs ,test-H ,test-V ,test-T 1344 | ((* intsp) @ i2))) 1345 | (term (int 3))) 1346 | 1347 | (test-equal (term (lvaddr ,test-srs ,test-H ,test-V ,test-T ((* intsp) @ i1))) 1348 | (term 23)) 1349 | 1350 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1351 | ;; malloc -- extend heap z contiguous addresses and retun starting address 1352 | 1353 | (define-metafunction Patina-machine 1354 | malloc : H z -> (H α) 1355 | 1356 | [(malloc H z) 1357 | (H_1 β) 1358 | (where ((α hv) ...) H) 1359 | (where β ,(add1 (apply max (term (-1 α ...))))) 1360 | (where H_1 (extend H β z))]) 1361 | 1362 | (test-equal (cadr (term (malloc ,test-H 2))) 100) 1363 | (test-equal (cadr (term (malloc () 2))) 0) 1364 | 1365 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1366 | ;; copymany -- like memcopy but for a series of regions 1367 | 1368 | (define-metafunction Patina-machine 1369 | copymany : H zs αs βs -> H 1370 | 1371 | [(copymany H () () ()) 1372 | H] 1373 | 1374 | [(copymany H (z_0 z_1 ...) (α_0 α_1 ...) (β_0 β_1 ...)) 1375 | (copymany (memcopy H α_0 β_0 z_0) 1376 | (z_1 ...) 1377 | (α_1 ...) 1378 | (β_1 ...))]) 1379 | 1380 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1381 | ;; reify-pack -- extract out the static part of some type that is to be 1382 | ;; packed and reify into a heap value 1383 | 1384 | (define-metafunction Patina-machine 1385 | reify-pack : srs ty ty -> hv 1386 | 1387 | [(reify-pack srs (vec ty l) (vec ty erased)) 1388 | (int l)] 1389 | 1390 | [(reify-pack srs (struct s_s ℓs_s) (struct s_d ℓs_d)) 1391 | (reify-pack srs ty_s^z ty_d^z) 1392 | (where (ty_s^a ... ty_s^z) (field-tys srs s_s ℓs_s)) 1393 | (where (ty_d^a ... ty_d^z) (field-tys srs s_d ℓs_d))] 1394 | 1395 | ) 1396 | 1397 | (test-equal (term (reify-pack ,test-dst-srs (vec int 22) (vec int erased))) 1398 | (term (int 22))) 1399 | 1400 | (test-equal (term (reify-pack ,test-dst-srs (struct RCDataInt3 []) (struct RCDataIntN []))) 1401 | (term (int 3))) 1402 | 1403 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1404 | ;; rveval -- evaluate an rvalue and store it into the heap at address α 1405 | 1406 | (define-metafunction Patina-machine 1407 | rveval : srs H V T α rv -> H 1408 | 1409 | [(rveval srs H V T α lv) 1410 | H_1 1411 | (where ty (lvtype srs T lv)) 1412 | (where z (sizeof srs ty)) 1413 | (where β (lvaddr srs H V T lv)) 1414 | (where H_1 (memcopy H α β z))] 1415 | 1416 | [(rveval srs H V T α (& ℓ mq lv)) 1417 | H_1 1418 | (where β (lvaddr srs H V T lv)) 1419 | (where ty (lvtype srs T lv)) 1420 | (where H_1 (update H α (ptr β))) 1421 | (side-condition (not (term (is-DST srs ty))))] 1422 | 1423 | [(rveval srs H V T α (& ℓ mq lv)) 1424 | H_2 1425 | (where β (lvaddr srs H V T lv)) 1426 | (where ty (lvtype srs T lv)) 1427 | (where (int l) (reified srs H V T lv)) 1428 | (where H_1 (update H α (ptr β))) 1429 | (where H_2 (update H_1 (inc α) (int l))) 1430 | (side-condition (term (is-DST srs ty)))] 1431 | 1432 | [(rveval srs H V T α (struct s ℓs lvs)) 1433 | (copymany H zs_0 βs αs) 1434 | 1435 | ;; types of each field: 1436 | (where tys (field-tys srs s ℓs)) 1437 | ;; sizes of each field's type: 1438 | (where zs_0 ,(map (λ (t) (term (sizeof srs ,t))) (term tys))) 1439 | ;; offset of each field: 1440 | (where zs_1 (field-offsets srs s ℓs)) 1441 | ;; source address of value for each field: 1442 | (where αs ,(map (λ (lv) (term (lvaddr srs H V T ,lv))) (term lvs))) 1443 | ;; target address for each field relative to base address α; 1444 | (where βs ,(map (λ (z) (+ (term α) z)) (term zs_1)))] 1445 | 1446 | [(rveval srs H V T α (new lv)) 1447 | (update H_2 α (ptr γ)) 1448 | 1449 | (where ty (lvtype srs T lv)) 1450 | (where z (sizeof srs ty)) 1451 | (where β (lvaddr srs H V T lv)) 1452 | (where (H_1 γ) (malloc H z)) 1453 | (where H_2 (memcopy H_1 γ β z))] 1454 | 1455 | [(rveval srs H V T α number) 1456 | (update H α (int number))] 1457 | 1458 | [(rveval srs H V T α (lv_l + lv_r)) 1459 | (update H α (int number_s)) 1460 | 1461 | (where α_l (lvaddr srs H V T lv_l)) 1462 | (where α_r (lvaddr srs H V T lv_r)) 1463 | (where (int number_l) (deref H α_l)) 1464 | (where (int number_r) (deref H α_r)) 1465 | (where number_s (offset number_l number_r))] 1466 | 1467 | [(rveval srs H V T α (Some lv)) 1468 | H_2 1469 | 1470 | (where ty (lvtype srs T lv)) 1471 | (where z (sizeof srs ty)) 1472 | (where β (lvaddr srs H V T lv)) 1473 | (where α_p ,(add1 (term α))) 1474 | (where H_1 (memcopy H α_p β z)) 1475 | (where H_2 (update H_1 α (int 1)))] 1476 | 1477 | [(rveval srs H V T α (None ty)) 1478 | (update H α (int 0))] 1479 | 1480 | [(rveval srs H V T α (vec ty)) 1481 | H] 1482 | 1483 | [(rveval srs H V T α (vec ty lv_e ...)) 1484 | H_1 1485 | 1486 | ;; find addresses α_e of the inputs lv_e 1487 | (where [α_e ...] [(lvaddr srs H V T lv_e) ...]) 1488 | ;; determine ty of vector from type of 1st lvalue 1489 | (where [lv_a lv_b ...] [lv_e ...]) 1490 | (where ty (lvtype srs T lv_a)) 1491 | ;; length of vector comes from number of lvalues 1492 | (where l_v (len [lv_a lv_b ...])) 1493 | ;; find types/sizes of the elements (always the same for each element) 1494 | (where [ty_e ...] (vec-tys srs ty l_v)) 1495 | (where [z_e ...] [(sizeof srs ty_e) ...]) 1496 | ;; find addresses β_e of each element 1497 | (where [z_o ...] (vec-offsets srs ty l_v)) 1498 | (where [β_e ...] ((offset α z_o) ...)) 1499 | ;; copy lvalues into their new homes 1500 | (where H_1 (copymany H [z_e ...] [β_e ...] [α_e ...]))] 1501 | 1502 | ;; pack from ~ty_s to ~ty_d where ty_d is DST 1503 | ;; (see nearly identical borrowed pointer rule below) 1504 | [(rveval srs H V T α (pack lv_s (~ ty_d))) 1505 | H_2 1506 | 1507 | ;; copy pointer value 1508 | (where α_s (lvaddr srs H V T lv_s)) 1509 | (where H_1 (memcopy H α α_s 1)) 1510 | 1511 | ;; reify component of type and store into heap at offset 1 of fat 1512 | ;; pointer 1513 | (where (~ ty_s) (lvtype srs T lv)) 1514 | (where hv (reify-pack srs ty_s ty_d)) 1515 | (where H_2 (update H_1 (inc α) hv))] 1516 | 1517 | ;; pack from &ty_s to &ty_d where ty_d is DST 1518 | ;; (see nearly identical owned pointer rule above) 1519 | [(rveval srs H V T α (pack lv_s (& ℓ mq ty_d))) 1520 | H_2 1521 | 1522 | ;; copy pointer value 1523 | (where α_s (lvaddr srs H V T lv_s)) 1524 | (where H_1 (memcopy H α α_s 1)) 1525 | 1526 | ;; reify component of type and store into heap at offset 1 of fat 1527 | ;; pointer 1528 | (where (& ℓ mq ty_s) (lvtype srs T lv_s)) 1529 | (where hv (reify-pack srs ty_s ty_d)) 1530 | (where H_2 (update H_1 (inc α) hv))] 1531 | 1532 | ;; len for non-DST 1533 | [(rveval srs H V T α (vec-len lv)) 1534 | (update H α (int l)) 1535 | (where (vec ty l) (lvtype srs T lv))] 1536 | 1537 | ;; len for DST 1538 | [(rveval srs H V T α (vec-len lv)) 1539 | (update H α (reified srs H V T lv)) 1540 | (where (vec ty erased) (lvtype srs T lv))] 1541 | 1542 | ) 1543 | 1544 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1545 | ;; lvselect -- helper for writing tests, selects values for a portion 1546 | ;; of the heap 1547 | 1548 | (define-metafunction Patina-machine 1549 | lvselect : srs H V T lv -> (hv ...) 1550 | 1551 | [(lvselect srs H V T lv) 1552 | ,(select (term H) (term α) (term z)) 1553 | 1554 | (where ty (lvtype srs T lv)) 1555 | (where α (lvaddr srs H V T lv)) 1556 | (where z (sizeof srs ty))]) 1557 | 1558 | ;; tests for rveval and lvselect 1559 | 1560 | (test-equal (term (lvselect ,test-srs 1561 | (rveval ,test-srs ,test-H ,test-V ,test-T 1562 | (vaddr ,test-V c) 1563 | (struct C (b1) (a b))) 1564 | ,test-V 1565 | ,test-T 1566 | c)) 1567 | (term ((int 23) (int 24) (ptr 98)))) 1568 | 1569 | (test-equal (term (lvselect ,test-srs 1570 | (rveval ,test-srs ,test-H ,test-V ,test-T 1571 | (vaddr ,test-V c) 1572 | (struct C (b1) (a b))) 1573 | ,test-V 1574 | ,test-T 1575 | a)) 1576 | (term ((int 23)))) 1577 | 1578 | (test-equal (term (lvselect ,test-srs 1579 | (rveval ,test-srs ,test-H ,test-V ,test-T 1580 | (vaddr ,test-V p) 1581 | (new i)) 1582 | ,test-V 1583 | ,test-T 1584 | p)) 1585 | (term ((ptr 100)))) 1586 | 1587 | (test-equal (term (lvselect ,test-srs 1588 | (rveval ,test-srs ,test-H ,test-V ,test-T 1589 | (vaddr ,test-V p) 1590 | (new i)) 1591 | ,test-V 1592 | ,test-T 1593 | p)) 1594 | (term ((ptr 100)))) 1595 | 1596 | (test-equal (term (deref (rveval ,test-srs ,test-H ,test-V ,test-T 1597 | (vaddr ,test-V p) 1598 | (new i)) 100)) 1599 | (term (int 22))) ;; *p now contains value of i 1600 | 1601 | (test-equal (term (lvselect ,test-srs 1602 | (rveval ,test-srs ,test-H ,test-V ,test-T 1603 | (vaddr ,test-V q) 1604 | (& mq imm (* ((c · 1) · 1)))) 1605 | ,test-V 1606 | ,test-T 1607 | q)) 1608 | (term ((ptr 97)))) 1609 | 1610 | (test-equal (term (lvselect ,test-srs 1611 | (rveval ,test-srs ,test-H ,test-V ,test-T 1612 | (vaddr ,test-V i) 1613 | (i + (* p))) 1614 | ,test-V 1615 | ,test-T 1616 | i)) 1617 | (term ((int 49)))) 1618 | 1619 | 1620 | ;; test that `None` writes a 0 into the discriminant, leaves rest unchanged 1621 | (test-equal (term (lvselect ,test-srs 1622 | (rveval ,test-srs ,test-H ,test-V ,test-T 1623 | (vaddr ,test-V s) 1624 | (None int)) 1625 | ,test-V 1626 | ,test-T 1627 | s)) 1628 | (term ((int 0) (ptr 95)))) 1629 | 1630 | ;; test that `(Some p)` writes a 1 into the discriminant 1631 | (test-equal (term (lvselect ,test-srs 1632 | (rveval ,test-srs ,test-H ,test-V ,test-T 1633 | (vaddr ,test-V s) 1634 | (Some p)) 1635 | ,test-V 1636 | ,test-T 1637 | s)) 1638 | (term ((int 1) (ptr 99)))) 1639 | 1640 | ;; test `(vec int i1 i2 i3)` 1641 | (test-equal (term (lvselect ,test-srs 1642 | (rveval ,test-srs ,test-H ,test-V ,test-T 1643 | (vaddr ,test-V ints3) 1644 | (vec int i1 i2 i3)) 1645 | ,test-V 1646 | ,test-T 1647 | ints3)) 1648 | (term ((int 1) (int 2) (int 3)))) 1649 | 1650 | ;; test pack 1651 | (test-equal (term (lvselect ,test-srs 1652 | (rveval ,test-srs 1653 | ;; regenerate the value of intsp 1654 | ,test-H 1655 | ,test-V 1656 | ,test-T 1657 | (vaddr ,test-V intsp) 1658 | (pack ints3p (& b1 imm (vec int erased)))) 1659 | ,test-V 1660 | ,test-T 1661 | intsp)) 1662 | (term ((ptr 22) (int 3)))) 1663 | 1664 | ;; test len for non-DST 1665 | (test-equal (term (lvselect ,test-srs 1666 | (rveval ,test-srs 1667 | ,test-H 1668 | ,test-V 1669 | ,test-T 1670 | (vaddr ,test-V i) 1671 | (vec-len ints3)) 1672 | ,test-V 1673 | ,test-T 1674 | i)) 1675 | (term ((int 3)))) 1676 | 1677 | ;; test len for DST 1678 | (test-equal (term (lvselect ,test-srs 1679 | (rveval ,test-srs 1680 | ,test-H 1681 | ,test-V 1682 | ,test-T 1683 | (vaddr ,test-V i) 1684 | (vec-len (* intsp))) 1685 | ,test-V 1686 | ,test-T 1687 | i)) 1688 | (term ((int 3)))) 1689 | 1690 | ;; test taking address of DST 1691 | (test-equal (term (lvselect ,test-srs 1692 | (rveval ,test-srs 1693 | ,test-H 1694 | ,test-V 1695 | ,test-T 1696 | (vaddr ,test-V intsp) 1697 | (& b1 imm (* intsp))) 1698 | ,test-V 1699 | ,test-T 1700 | intsp)) 1701 | (term ((ptr 22) (int 3)))) 1702 | 1703 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1704 | ;; free-pointer srs H α ty -> H 1705 | ;; 1706 | ;; `α` should contain a pointer to memory of type `ty`. Frees the memory 1707 | ;; pointed at by `α` (shallowly). 1708 | 1709 | (define-metafunction Patina-machine 1710 | free-pointer : srs H α ty -> H 1711 | 1712 | [(free-pointer srs H α ty) 1713 | H_1 1714 | (side-condition (not (term (is-DST srs ty)))) 1715 | (where (ptr β) (deref H α)) 1716 | (where z (sizeof srs ty)) 1717 | (where H_1 (shrink H β z)) 1718 | ] 1719 | 1720 | [(free-pointer srs H α ty) 1721 | H_1 1722 | (side-condition (term (is-DST srs ty))) 1723 | (where (ptr β) (deref H α)) 1724 | (where hv (deref H (inc α))) 1725 | (where z (sizeof-dst srs ty hv)) 1726 | (where H_1 (shrink H β z)) 1727 | ] 1728 | 1729 | ) 1730 | 1731 | ; free a ~int 1732 | (test-equal (term (free-pointer ,test-srs 1733 | [(1 (int 22)) 1734 | (10 (ptr 99)) 1735 | (99 (int 33))] 1736 | 10 1737 | int)) 1738 | (term [(1 (int 22)) (10 (ptr 99))])) 1739 | 1740 | ; free a ~[int] of len 3 1741 | (test-equal (term (free-pointer ,test-srs 1742 | [(1 (int 22)) 1743 | (10 (ptr 95)) 1744 | (11 (int 3)) 1745 | (95 (int 33)) 1746 | (96 (int 34)) 1747 | (97 (int 35)) 1748 | (98 (int 36)) 1749 | ] 1750 | 10 1751 | (vec int erased))) 1752 | (term [(1 (int 22)) (10 (ptr 95)) (11 (int 3)) (98 (int 36))])) 1753 | 1754 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1755 | ;; drop-contents -- drops the memory owned by `α` which has type `ty` 1756 | ;; 1757 | ;; Note that this does *not* free (or deinitialize) `α` itself! 1758 | 1759 | (define-metafunction Patina-machine 1760 | drop-contents-at-offsets : srs H α (ty ...) (z ...) -> H 1761 | 1762 | [(drop-contents-at-offsets srs H α () ()) 1763 | H] 1764 | 1765 | [(drop-contents-at-offsets srs H α (ty_0 ty_1 ...) (z_0 z_1 ...)) 1766 | (drop-contents-at-offsets srs H_1 α (ty_1 ...) (z_1 ...)) 1767 | (where H_1 (drop-contents srs H ty_0 (offset α z_0)))] 1768 | 1769 | ) 1770 | 1771 | (define-metafunction Patina-machine 1772 | drop-contents-vec : srs H α ty l -> H 1773 | 1774 | [(drop-contents-vec srs H α ty l) 1775 | (drop-contents-at-offsets srs H α 1776 | (vec-tys srs ty l) 1777 | (vec-offsets srs ty l))] 1778 | 1779 | ) 1780 | 1781 | (define-metafunction Patina-machine 1782 | drop-contents-dst : srs H ty α hv -> H 1783 | 1784 | [(drop-contents-dst srs H (vec ty erased) α (int z)) 1785 | (drop-contents-vec srs H α ty z)] 1786 | 1787 | [(drop-contents-dst srs H (struct s ℓs) α) 1788 | (drop-contents-dst srs H_1 ty_z (offset α z_z) hv) 1789 | (where (ty_a ... ty_z) (field-tys srs s ℓs)) 1790 | (where (z_a ... z_z) (field-offsets srs s ℓs)) 1791 | (where H_1 (drop-contents-at-offsets srs H α (ty_a ...) (z_a ...)))] 1792 | 1793 | ) 1794 | 1795 | (define-metafunction Patina-machine 1796 | drop-contents : srs H ty α -> H 1797 | 1798 | [(drop-contents srs H int α) 1799 | H] 1800 | 1801 | [(drop-contents srs H (vec ty z) α) 1802 | (drop-contents-vec srs H α ty z)] 1803 | 1804 | [(drop-contents srs H (& ℓ mq ty) α) H] 1805 | 1806 | [(drop-contents srs H (~ ty) α) 1807 | H_2 1808 | (where (ptr β) (deref H α)) 1809 | (where z (sizeof srs ty)) 1810 | (where H_1 (drop-contents srs H ty β)) 1811 | (where H_2 (shrink H_1 β z)) 1812 | (side-condition (not (term (is-DST srs ty))))] 1813 | 1814 | [(drop-contents srs H (~ ty) α_0) 1815 | H_2 1816 | (where (ptr β) (deref H α)) 1817 | (where hv (deref H (inc α))) 1818 | (where z (sizeof-dst srs ty hv)) 1819 | (where H_1 (drop-contents-dst srs H ty β hv)) 1820 | (where H_2 (shrink H_1 β z)) 1821 | (side-condition (term (is-DST srs ty)))] 1822 | 1823 | [(drop-contents srs H (struct s ℓs) α) 1824 | (drop-contents-at-offsets srs H α tys zs) 1825 | (where tys (field-tys srs s ℓs)) 1826 | (where zs (field-offsets srs s ℓs))] 1827 | 1828 | [(drop-contents srs H (Option ty) α) 1829 | H 1830 | (where (int 0) (deref H α))] 1831 | 1832 | [(drop-contents srs H (Option ty) α) 1833 | (drop-contents srs H ty ,(add1 (term α))) 1834 | (where (int 1) (deref H α))] 1835 | ) 1836 | 1837 | (define-metafunction Patina-machine 1838 | drop-lv-contents : srs H V T lv -> H 1839 | 1840 | [(drop-lv-contents srs H V T lv) 1841 | (drop-contents srs H ty α) 1842 | (where ty (lvtype srs T lv)) 1843 | (where α (lvaddr srs H V T lv))]) 1844 | 1845 | (test-equal (term (drop-lv-contents ,test-srs ,test-H ,test-V ,test-T p)) 1846 | (term (shrink ,test-H 99 1))) 1847 | 1848 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1849 | ;; free-variables -- pop the stack frame for a block; i.e., shallowly remove the 1850 | ;; memory used by its variables 1851 | 1852 | (define-metafunction Patina-machine 1853 | free-variables : srs H vmap vdecls -> H 1854 | 1855 | [(free-variables srs H [] []) H] 1856 | [(free-variables srs 1857 | H 1858 | [(x_0 α_0) (x_1 α_1) ...] 1859 | [(x_0 ty_0) (x_1 ty_1) ...]) 1860 | (free-variables srs H_1 [(x_1 α_1) ...] [(x_1 ty_1) ...]) 1861 | (where z (sizeof srs ty_0)) 1862 | (where H_1 (shrink H α_0 z))] 1863 | ) 1864 | 1865 | ;; frees the memory used b the local variables, but not what they may reference 1866 | (test-equal (term (free-variables ,test-srs 1867 | [(1 (int 22)) 1868 | (10 (ptr 99)) 1869 | (99 (int 33))] 1870 | [(i 1) (p 10)] 1871 | [(i int) (p (~ int))])) 1872 | (term ((99 (int 33))))) 1873 | 1874 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1875 | ;; alloc-variables -- allocate space for variables upon entry to a block, 1876 | ;; filling the memory with void 1877 | 1878 | (define-metafunction Patina-machine 1879 | alloc-variables : srs H ((x ty) ...) -> (vmap vdecls H) 1880 | 1881 | [(alloc-variables srs H ()) (() () H)] 1882 | [(alloc-variables srs H ((x_0 ty_0) (x_1 ty_1) ...)) 1883 | (((x_0 α_0) (x_2 α_2) ...) 1884 | ((x_0 ty_0) (x_2 ty_2) ...) 1885 | H_2) 1886 | (where z (sizeof srs ty_0)) 1887 | (where (H_1 α_0) (malloc H z)) 1888 | (where (((x_2 α_2) ...) 1889 | ((x_2 ty_2) ...) 1890 | H_2) (alloc-variables srs H_1 ((x_1 ty_1) ...)))]) 1891 | 1892 | ;; this should release all memory but that which pertains to `i` and `p`, 1893 | ;; as well as `97` and `98` which are marked as 'static' 1894 | (test-equal (term (alloc-variables ,test-srs 1895 | ,test-H 1896 | ((j int) 1897 | (k (struct B (static)))))) 1898 | (term (((j 100) (k 101)) 1899 | ((j int) (k (struct B (static)))) 1900 | ,(append (term ((102 void) (101 void) (100 void))) 1901 | test-H)))) 1902 | 1903 | ;; unwrap 1904 | 1905 | (define-metafunction Patina-machine 1906 | unwrap : srs H ℓ mode ty α -> (H ty α) 1907 | 1908 | [(unwrap srs H ℓ (ref ℓ_x mq_x) ty α) 1909 | (H_u ty_m α_m) 1910 | ;; type of variable `x_m` 1911 | (where ty_m (& ℓ_x mq_x ty)) 1912 | ;; generate memory for `x_m` 1913 | (where (H_m α_m) (malloc H (sizeof srs ty_m))) 1914 | ;; update mem location with ptr to payload 1915 | (where H_u (update H_m α_m (ptr α)))] 1916 | 1917 | [(unwrap srs H ℓ by-value ty α) 1918 | (H_u ty α_m) 1919 | ;; generate memory for `x_m` 1920 | (where (H_m α_m) (malloc H (sizeof srs ty))) 1921 | ;; copy payload from α into α_m 1922 | (where H_u (memcopy H_m α_m α (sizeof srs ty)))] 1923 | ) 1924 | 1925 | (test-equal (term (unwrap ,test-srs ,test-H l1 (ref l2 mut) (~ int) 1926 | ,(add1 (term (vaddr ,test-V s))))) 1927 | (term (,(append (term [(100 (ptr 21))]) test-H) 1928 | (& l2 mut (~ int)) 1929 | 100))) 1930 | 1931 | (test-equal (term (unwrap ,test-srs ,test-H l1 by-value (~ int) 1932 | ,(add1 (term (vaddr ,test-V s))))) 1933 | (term (,(append (term [(100 (ptr 95))]) test-H) 1934 | (~ int) 1935 | 100))) 1936 | 1937 | ;; deterministically generate a lifetime not currently in the stack with the provided prefix 1938 | (define-metafunction Patina-machine 1939 | fresh-lifetime-not-on-stack : S ℓ -> ℓ 1940 | [(fresh-lifetime-not-on-stack S ℓ) ,(variable-not-in (map car (term S)) (term ℓ))]) 1941 | 1942 | ;; --> -- machine step from one configuration C to the next 1943 | 1944 | (define machine-step 1945 | (reduction-relation 1946 | Patina-machine #:domain C 1947 | 1948 | ;; Stack frame with no more statements. Free variables. 1949 | [--> ((srs fns) H [vmap_0 vmap_1 ...] [vdecls_0 vdecls_1 ...] 1950 | [(ℓ ()) sf_1 ...]) 1951 | ((srs fns) H_1 [vmap_1 ...] [vdecls_1 ...] [sf_1 ...]) 1952 | (where H_1 (free-variables srs H vmap_0 vdecls_0))] 1953 | 1954 | ;; Assignments. The memory for the lvalue should always be alloc'd, 1955 | ;; but not initialized. 1956 | [--> ((srs fns) H V T [(ℓ ((lv = rv) st ...)) sf ...]) 1957 | ((srs fns) H_1 V T [(ℓ (st ...)) sf ...]) 1958 | (where α (lvaddr srs H V T lv)) 1959 | (where H_1 (rveval srs H V T α rv))] 1960 | 1961 | ;; Overwrites. The memory for the lvalue should always be fully initialized. 1962 | ;; Previous contents will be dropped. 1963 | [--> ((srs fns) H V T [(ℓ ((lv := rv) st ...)) sf ...]) 1964 | ((srs fns) H_2 V T [(ℓ (st ...)) sf ...]) 1965 | (where α (lvaddr srs H V T lv)) 1966 | (where H_1 (drop-lv-contents srs H V T lv)) 1967 | (where H_2 (rveval srs H_1 V T α rv))] 1968 | 1969 | ;; Frees. lv should be a pointer whose contents have been freed. 1970 | [--> ((srs fns) H V T [(ℓ ((free lv) st ...)) sf ...]) 1971 | ((srs fns) H_2 V T [(ℓ (st ...)) sf ...]) 1972 | (where H_1 (free-pointer srs H V T lv))] 1973 | 1974 | ;; Drops. The memory for the lvalue should be fully initialized. 1975 | [--> ((srs fns) H V T [(ℓ ((drop lv) st ...)) sf ...]) 1976 | ((srs fns) H_1 V T [(ℓ (st ...)) sf ...]) 1977 | (where H_1 (drop-lv-contents srs H V T lv))] 1978 | 1979 | ;; Match, None case. 1980 | [--> ((srs fns) H V T [(ℓ [st_a st ...]) sf ...]) 1981 | ((srs fns) H [() vmap ...] [() vdecls ...] [(ℓ_m [bk_n]) (ℓ [st ...]) sf ...]) 1982 | ;; st_a is some kind of match: 1983 | (where (match lv_d (Some mode x_d => bk_s) (None => bk_n)) st_a) 1984 | ;; the discriminant lies at address α_d: 1985 | (where α_d (lvaddr srs H V T lv_d)) 1986 | ;; it is a None value: 1987 | (where (int 0) (deref H α_d)) 1988 | ;; generate a fresh lifetime 1989 | (where ℓ_m (fresh-lifetime-not-on-stack [(ℓ [st ...]) sf ...] lmatch)) 1990 | ;; unpack V and T 1991 | (where ([vmap ...] [vdecls ...]) (V T)) 1992 | ] 1993 | 1994 | ;; Match, some case. 1995 | [--> ((srs fns) H V T [(ℓ [st_a st ...]) sf ...]) 1996 | C_n 1997 | ;; st_a is a match: 1998 | (where (match lv_d (Some mode x_m => bk_s) (None => bk_n)) st_a) 1999 | ;; the discriminant lies at address α_d: 2000 | (where α_d (lvaddr srs H V T lv_d)) 2001 | ;; the discriminant has Option type: 2002 | (where (Option ty) (lvtype srs T lv_d)) 2003 | ;; it is a Some value: 2004 | (where (int 1) (deref H α_d)) 2005 | ;; make a pointer to the payload: 2006 | (where α_v ,(add1 (term α_d))) 2007 | ;; generate a fresh lifetime 2008 | (where ℓ_m (fresh-lifetime-not-on-stack [(ℓ [st ...]) sf ...] lmatch)) 2009 | ;; handle the ref/move into `x_m`: 2010 | (where (H_m ty_m α_m) (unwrap srs H ℓ_m mode ty α_v)) 2011 | ;; create new entry for vmap/vdecls 2012 | (where vmap_m [(x_m α_m)]) 2013 | (where vdecls_m [(x_m ty_m)]) 2014 | ;; unpack V and T 2015 | (where ([vmap ...] [vdecls ...]) (V T)) 2016 | (where C_n ((srs fns) H_m [vmap_m vmap ...] [vdecls_m vdecls ...] 2017 | [(ℓ_m [bk_s]) (ℓ [st ...]) sf ...])) 2018 | ] 2019 | 2020 | ;; Push a new block. 2021 | [--> ((srs fns) H (vmap ...) (vdecls ...) 2022 | [sf_1 sf_2 ...]) 2023 | ((srs fns) H_1 [vmap_b vmap ...] [vdecls_fresh vdecls ...] 2024 | [sf_fresh (ℓ_1 [st_1 ...]) sf_2 ...]) 2025 | 2026 | ;; unpack the top-most stack frame sf_1: 2027 | (where (ℓ_1 [st_0 st_1 ...]) sf_1) 2028 | ;; unpack the next statement st_0, which should be a block: 2029 | (where (block ℓ_b vdecls_b [st_b ...]) st_0) 2030 | ;; substitute a fresh lifetime for ℓ_b 2031 | ; pick a lifetime not in the list of lifetimes on the stack 2032 | (where ℓ_fresh (fresh-lifetime-not-on-stack [sf_1 sf_2 ...] ℓ_b)) 2033 | ; substitute it for ℓ_b in everything 2034 | (where θ ((ℓ_b ℓ_fresh))) 2035 | (where vdecls_fresh (subst-vdecls θ vdecls_b)) 2036 | (where (st_fresh ...) ((subst-st θ st_b) ...)) 2037 | ;; allocate space for block svariables in memory: 2038 | (where (vmap_b vdecls_fresh H_1) (alloc-variables srs H vdecls_fresh)) 2039 | ;; create new stack frame for block 2040 | (where sf_fresh (ℓ_fresh (st_fresh ...))) 2041 | ] 2042 | 2043 | ;; Push a call. 2044 | [--> ((srs fns) H V T S) 2045 | ((srs fns) H_2 [vmap_a vmap ...] [vdecls_a vdecls ...] 2046 | [(ℓ_fresh (bk_a)) (ℓ_1 [st_r ...]) sf_r ...]) 2047 | 2048 | ;; unpack V and T for later expansion 2049 | (where ([vmap ...] [vdecls ...]) (V T)) 2050 | ;; unpack the stack frames: 2051 | (where [(ℓ_1 sts_1) sf_r ...] S) 2052 | ;; unpack the statements sts_1 from top-most activation: 2053 | (where ((call g (ℓ_a ...) lvs_a) st_r ...) sts_1) 2054 | ;; determine the types of the actual args to be passed: 2055 | (where tys_a ,(map (λ (lv) (term (lvtype srs T ,lv))) 2056 | (term lvs_a))) 2057 | ;; determine sizes of those types 2058 | (where zs_a ,(map (λ (ty) (term (sizeof srs ,ty))) 2059 | (term tys_a))) 2060 | ;; determine where lvalues are found in memory 2061 | (where αs_a ,(map (λ (lv) (term (lvaddr srs H V T ,lv))) 2062 | (term lvs_a))) 2063 | ;; lookup the fun def'n 2064 | (where (fun g (ℓ_f ...) vdecls_f bk_f) (fun-defn fns g)) 2065 | ; generate a fresh lifetime for the function call 2066 | (where ℓ_fresh (fresh-lifetime-not-on-stack S lX)) 2067 | ; substitute the actual lifetimes for the formal lifetimes ... 2068 | (where θ ((ℓ_f ℓ_a) ...)) 2069 | ; ... in the types of variables ... 2070 | (where vdecls_a (subst-vdecls θ vdecls_f)) 2071 | ; ... and in the function body 2072 | (where bk_a (subst-bk θ bk_f)) 2073 | ;; allocate space for parameters in memory: 2074 | (where (vmap_a vdecls_a H_1) (alloc-variables srs H vdecls_a)) 2075 | ;; determine addresses for each formal argument: 2076 | (where ((x_f ty_f) ...) vdecls_f) 2077 | (where βs_f ,(map (λ (lv) (term (lvaddr srs H_1 2078 | (vmap_a) (vdecls_a) 2079 | ,lv))) 2080 | (term (x_f ...)))) 2081 | ;; move from actual params into formal params: 2082 | (where H_2 (copymany H_1 zs_a βs_f αs_a)) 2083 | ] 2084 | )) 2085 | 2086 | ;; test stepping where top-most stack frame has no remaining statements 2087 | (test--> machine-step 2088 | (term (,twentytwo-prog () (()) (()) ((l0 ())))) 2089 | (term (,twentytwo-prog () () () ()))) 2090 | 2091 | ;; test popping off a stack frame with vars and another frame beneath 2092 | (test--> machine-step 2093 | (term (,twentytwo-prog 2094 | [(0 (int 22)) (1 (int 23))] 2095 | [[(j 1)] [(i 0)]] 2096 | [[(j int)] [(i int)]] 2097 | [(l0 []) (l1 [])])) 2098 | (term (,twentytwo-prog 2099 | [(0 (int 22))] 2100 | [[(i 0)]] 2101 | [[(i int)]] 2102 | [(l1 [])]))) 2103 | 2104 | ;;;; test pushing a new block 2105 | (test--> machine-step 2106 | (term (,twentytwo-prog 2107 | [(0 (int 22))] 2108 | [[(a 0)]] 2109 | [[(a int)]] 2110 | [(l1 [(block l2 2111 | [(b int) 2112 | (c (~ int))] 2113 | [(i = 2) 2114 | (j = (new i))])])])) 2115 | (term (,twentytwo-prog 2116 | [(2 void) (1 void) (0 (int 22))] 2117 | [[(b 1) (c 2)] [(a 0)]] 2118 | [[(b int) (c (~ int))] [(a int)]] 2119 | [(l2 [(i = 2) (j = (new i))]) 2120 | (l1 [])]))) 2121 | 2122 | ;; test a series of state steps, starting from the initial state. 2123 | ;; This tests: 2124 | ;; - function calls 2125 | ;; - block activation 2126 | ;; - assignment (through a pointer) 2127 | ;; - popping 2128 | 2129 | (define state-0 2130 | (term (,twentytwo-prog ,initial-H ,initial-V ,initial-T ,initial-S))) 2131 | (check-not-false (redex-match Patina-machine C state-0)) 2132 | 2133 | (define state-1 2134 | (term (,twentytwo-prog 2135 | [(2 (ptr 0)) (0 (int 0)) (1 (ptr 0))] 2136 | [[(outp 2)] [(resultp 1)]] 2137 | [[(outp (& l0 mut int))] [(resultp (& l0 mut int))]] 2138 | [(lX [(block l1 [] (((* outp) = 22)))]) 2139 | (l0 [])]))) 2140 | (check-not-false (redex-match Patina-machine C state-1)) 2141 | 2142 | (define state-2 2143 | (term (,twentytwo-prog 2144 | [(2 (ptr 0)) (0 (int 0)) (1 (ptr 0))] 2145 | [[] [(outp 2)] [(resultp 1)]] 2146 | [[] [(outp (& l0 mut int))] [(resultp (& l0 mut int))]] 2147 | [(l1 [((* outp) = 22)]) 2148 | (lX []) 2149 | (l0 [])]))) 2150 | (check-not-false (redex-match Patina-machine C state-2)) 2151 | 2152 | (define state-3 2153 | (term (,twentytwo-prog 2154 | [(2 (ptr 0)) (0 (int 22)) (1 (ptr 0))] 2155 | [[] [(outp 2)] [(resultp 1)]] 2156 | [[] [(outp (& l0 mut int))] [(resultp (& l0 mut int))]] 2157 | [(l1 []) 2158 | (lX []) 2159 | (l0 [])]))) 2160 | (check-not-false (redex-match Patina-machine C state-3)) 2161 | 2162 | (define state-N 2163 | (term (,twentytwo-prog 2164 | [(0 (int 22))] 2165 | [] 2166 | [] 2167 | []))) 2168 | (check-not-false (redex-match Patina-machine C state-N)) 2169 | 2170 | (test--> machine-step state-0 state-1) 2171 | (test--> machine-step state-1 state-2) 2172 | (test--> machine-step state-2 state-3) 2173 | (test-->> machine-step state-0 state-N) 2174 | 2175 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2176 | ;; test summation example 2177 | 2178 | (define sum-state-0 2179 | (term (,sum-prog ,initial-H ,initial-V ,initial-T ,initial-S))) 2180 | (check-not-false (redex-match Patina-machine C sum-state-0)) 2181 | 2182 | (define sum-state-N 2183 | (term (,sum-prog [(0 (int 66))] [] [] []))) 2184 | (check-not-false (redex-match Patina-machine C sum-state-N)) 2185 | 2186 | (test-->> machine-step sum-state-0 sum-state-N) 2187 | 2188 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2189 | ;; test dst example 2190 | 2191 | (define dst-state-0 2192 | (term (,dst-prog ,initial-H ,initial-V ,initial-T ,initial-S))) 2193 | (check-not-false (redex-match Patina-machine C dst-state-0)) 2194 | 2195 | (define dst-state-N 2196 | (term (,dst-prog [(0 (int 69))] [] [] []))) 2197 | (check-not-false (redex-match Patina-machine C dst-state-N)) 2198 | 2199 | (test-->> machine-step dst-state-0 dst-state-N) 2200 | 2201 | ;;;; 2202 | ;; 2203 | ;; TYPING RULES 2204 | ;; 2205 | ;;;; 2206 | 2207 | (define-extended-language Patina-typing Patina-machine 2208 | ;; de-initialization: lists lvalues that have been de-initialized 2209 | (Δ (lv ...)) 2210 | 2211 | ;; lifetime declaration: lifetime ℓ is in scope, and it is a sublifetime 2212 | ;; of ℓs 2213 | (λ (ℓ ℓs)) 2214 | (λs (λ ...)) 2215 | 2216 | ;; lifetime relation: what lifetimes are in scope; in future, what 2217 | ;; is their relation to one another 2218 | (Λ λs) 2219 | 2220 | ;; variable lifetimes: map of maps from variable name to lifetime of 2221 | ;; block where it was defined 2222 | (vl (x ℓ)) 2223 | (vls [vl ...]) 2224 | (VL [vls ...]) 2225 | 2226 | ;; in-scope loans 2227 | (loan (ℓ mq lv)) 2228 | (£ [loan ...]) 2229 | 2230 | ) 2231 | 2232 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2233 | ;; Testing constants 2234 | ;; 2235 | ;; Our test fn is roughly: 2236 | ;; 2237 | ;; fn foo<'p0, 'p1>() 'a: { 2238 | ;; let i: int; 2239 | ;; 'b: { 2240 | ;; let r-imm-B: &'b B<'static>; 2241 | ;; let r-mut-B: &'b B<'static>; 2242 | ;; let owned-B: ~B<'static>; 2243 | ;; let owned-E: ~E; 2244 | ;; let r-mut-int: &'a mut int 2245 | ;; let opt-int: Option 2246 | ;; } 2247 | ;; } 2248 | 2249 | (define test-ty-Λ (term [(p0 []) (p1 []) (a [p0 p1]) (b [a p0 p1])])) 2250 | (define test-ty-T (term [[;; block a 2251 | (i int) 2252 | ] 2253 | [;; block b 2254 | (r-imm-B (& b imm (struct B (static)))) 2255 | (r-mut-B (& b mut (struct B (static)))) 2256 | (owned-B (~ (struct B (static)))) 2257 | (owned-E (~ (struct E ()))) 2258 | (r-mut-int (& a mut int)) 2259 | (opt-int (Option int)) 2260 | ] 2261 | ])) 2262 | (define test-ty-VL (term [[;; block a 2263 | (i a) 2264 | ] 2265 | [;; block b 2266 | (r-imm-B b) 2267 | (r-mut-B b) 2268 | (owned-B b) 2269 | (owned-E b) 2270 | (r-mut-int b) 2271 | (opt-int b) 2272 | ] 2273 | ])) 2274 | 2275 | (define test-ty-srs test-srs) 2276 | (define test-ty-fns 2277 | (term [(fun drop-owned-B [l0] [(x (~ (struct B (l0))))] 2278 | (block l1 2279 | [] 2280 | [(drop x)])) 2281 | ])) 2282 | (define test-ty-prog (term (,test-ty-srs ,test-ty-fns))) 2283 | 2284 | (check-not-false (redex-match Patina-machine prog test-ty-prog)) 2285 | 2286 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2287 | ;; lifetime-=, lifetime-≠ 2288 | 2289 | (define-metafunction Patina-typing 2290 | lifetime-= : ℓ ℓ -> boolean 2291 | 2292 | [(lifetime-= ℓ_1 ℓ_1) #t] 2293 | [(lifetime-= ℓ_1 ℓ_2) #f] 2294 | ) 2295 | 2296 | (define-metafunction Patina-typing 2297 | lifetime-≠ : ℓ ℓ -> boolean 2298 | 2299 | [(lifetime-≠ ℓ_1 ℓ_1) #f] 2300 | [(lifetime-≠ ℓ_1 ℓ_2) #t] 2301 | ) 2302 | 2303 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2304 | ;; lifetime-≤ 2305 | 2306 | (define-judgment-form 2307 | Patina-typing 2308 | #:mode (lifetime-≤ I I I) 2309 | #:contract (lifetime-≤ Λ ℓ ℓ) 2310 | 2311 | [-------------------------------------------------- 2312 | (lifetime-≤ Λ ℓ ℓ)] 2313 | 2314 | [-------------------------------------------------- 2315 | (lifetime-≤ Λ ℓ static)] 2316 | 2317 | [(side-condition (has ℓ_a Λ)) 2318 | (where ℓs (get ℓ_a Λ)) 2319 | (side-condition (∈ ℓ_b ℓs)) 2320 | -------------------------------------------------- 2321 | (lifetime-≤ Λ ℓ_a ℓ_b)] 2322 | 2323 | ) 2324 | 2325 | (test-equal 2326 | (judgment-holds (lifetime-≤ [(a [b c]) (b []) (c [])] a a)) 2327 | #t) 2328 | 2329 | (test-equal 2330 | (judgment-holds (lifetime-≤ [(a [b c]) (b []) (c [])] a b)) 2331 | #t) 2332 | 2333 | (test-equal 2334 | (judgment-holds (lifetime-≤ [(a [b c]) (b []) (c [])] a c)) 2335 | #t) 2336 | 2337 | (test-equal 2338 | (judgment-holds (lifetime-≤ [(a [b c]) (b []) (c [])] b b)) 2339 | #t) 2340 | 2341 | (test-equal 2342 | (judgment-holds (lifetime-≤ [(a [b c]) (b []) (c [])] b c)) 2343 | #f) 2344 | 2345 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2346 | ;; subtype 2347 | 2348 | (define-judgment-form 2349 | Patina-typing 2350 | #:mode (subtype I I I) 2351 | #:contract (subtype Λ ty ty) 2352 | 2353 | [;; FIXME model variance somehow 2354 | -------------------------------------------------- 2355 | (subtype Λ (struct s ℓs) (struct s ℓs))] 2356 | 2357 | [(subtype Λ ty_1 ty_2) 2358 | -------------------------------------------------- 2359 | (subtype Λ (~ ty_1) (~ ty_2))] 2360 | 2361 | [(lifetime-≤ Λ ℓ_2 ℓ_1) 2362 | (subtype Λ ty_1 ty_2) 2363 | -------------------------------------------------- 2364 | (subtype Λ (& ℓ_1 imm ty_1) (& ℓ_2 imm ty_2))] 2365 | 2366 | [(lifetime-≤ Λ ℓ_2 ℓ_1) 2367 | -------------------------------------------------- 2368 | (subtype Λ (& ℓ_1 mut ty) (& ℓ_2 mut ty))] 2369 | 2370 | [-------------------------------------------------- 2371 | (subtype Λ int int)] 2372 | 2373 | [(subtype Λ ty_1 ty_2) 2374 | -------------------------------------------------- 2375 | (subtype Λ (Option ty_1) (Option ty_2))] 2376 | 2377 | [(subtype Λ ty_1 ty_2) 2378 | -------------------------------------------------- 2379 | (subtype Λ (vec ty_1 olen) (vec ty_2 olen))] 2380 | 2381 | ) 2382 | 2383 | (test-equal 2384 | (judgment-holds (subtype ,test-ty-Λ int int)) 2385 | #t) 2386 | 2387 | (test-equal 2388 | (judgment-holds (subtype ,test-ty-Λ (& b mut int) (& a mut int))) 2389 | #f) 2390 | 2391 | (test-equal 2392 | (judgment-holds (subtype ,test-ty-Λ (& static mut int) (& a mut int))) 2393 | #t) 2394 | 2395 | (test-equal 2396 | (judgment-holds (subtype ,test-ty-Λ (& a mut int) (& b mut int))) 2397 | #t) 2398 | 2399 | (test-equal 2400 | (judgment-holds (subtype ,test-ty-Λ (Option (& a mut int)) (Option (& b mut int)))) 2401 | #t) 2402 | 2403 | (test-equal 2404 | (judgment-holds (subtype ,test-ty-Λ (~ (& a mut int)) (~ (& b mut int)))) 2405 | #t) 2406 | 2407 | (test-equal 2408 | (judgment-holds (subtype ,test-ty-Λ (vec (& a mut int) 2) (vec (& b mut int) 2))) 2409 | #t) 2410 | 2411 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2412 | ;; ty-is-pod 2413 | 2414 | (define-metafunction Patina-typing 2415 | ty-is-pod : srs ty -> boolean 2416 | 2417 | [(ty-is-pod srs int) #t] 2418 | 2419 | [(ty-is-pod srs (& ℓ imm ty)) #t] 2420 | 2421 | [(ty-is-pod srs (& ℓ mut ty)) #f] 2422 | 2423 | [(ty-is-pod srs (~ ty)) #f] 2424 | 2425 | [(ty-is-pod srs (Option ty)) (ty-is-pod srs ty)] 2426 | 2427 | [(ty-is-pod srs (struct s ℓs)) 2428 | (∀ [(ty-is-pod srs ty_s) ...]) 2429 | (where [ty_s ...] (field-tys srs s ℓs))] 2430 | 2431 | ) 2432 | 2433 | (test-equal 2434 | (term (ty-is-pod [] int)) 2435 | #t) 2436 | 2437 | (test-equal 2438 | (term (ty-is-pod [] (Option int))) 2439 | #t) 2440 | 2441 | (test-equal 2442 | (term (ty-is-pod [] (~ int))) 2443 | #f) 2444 | 2445 | (test-equal 2446 | (term (ty-is-pod [] (Option (~ int)))) 2447 | #f) 2448 | 2449 | (test-equal 2450 | (term (ty-is-pod [] (& b imm int))) 2451 | #t) 2452 | 2453 | (test-equal 2454 | (term (ty-is-pod [] (& b mut int))) 2455 | #f) 2456 | 2457 | (test-equal 2458 | (term (ty-is-pod ,test-srs (struct A []))) 2459 | #t) 2460 | 2461 | (test-equal 2462 | (term (ty-is-pod ,test-srs (struct E []))) 2463 | #f) 2464 | 2465 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2466 | ;; ty-needs-drop 2467 | 2468 | (define-metafunction Patina-typing 2469 | ty-needs-drop : srs ty -> boolean 2470 | 2471 | [(ty-needs-drop srs int) #f] 2472 | 2473 | [(ty-needs-drop srs (& ℓ imm ty)) #f] 2474 | 2475 | [(ty-needs-drop srs (& ℓ mut ty)) #f] 2476 | 2477 | [(ty-needs-drop srs (~ ty)) #t] 2478 | 2479 | [(ty-needs-drop srs (Option ty)) (ty-needs-drop srs ty)] 2480 | 2481 | [(ty-needs-drop srs (struct s ℓs)) 2482 | (∃ [(ty-needs-drop srs ty_s) ...]) 2483 | (where [ty_s ...] (field-tys srs s ℓs))] 2484 | 2485 | ) 2486 | 2487 | (test-equal 2488 | (term (ty-needs-drop [] int)) 2489 | #f) 2490 | 2491 | (test-equal 2492 | (term (ty-needs-drop [] (Option int))) 2493 | #f) 2494 | 2495 | (test-equal 2496 | (term (ty-needs-drop [] (~ int))) 2497 | #t) 2498 | 2499 | (test-equal 2500 | (term (ty-needs-drop [] (Option (~ int)))) 2501 | #t) 2502 | 2503 | (test-equal 2504 | (term (ty-needs-drop [] (& b imm int))) 2505 | #f) 2506 | 2507 | (test-equal 2508 | (term (ty-needs-drop [] (& b mut int))) 2509 | #f) 2510 | 2511 | (test-equal 2512 | (term (ty-needs-drop ,test-srs (struct A []))) 2513 | #f) 2514 | 2515 | (test-equal 2516 | (term (ty-needs-drop ,test-srs (struct E []))) 2517 | #t) 2518 | 2519 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2520 | ;; in-scope-lifetimes 2521 | ;; 2522 | ;; Convert a Λ to a list ℓs of in-scope lifetimes 2523 | 2524 | (define-metafunction Patina-typing 2525 | in-scope-lifetimes : Λ -> ℓs 2526 | 2527 | [(in-scope-lifetimes ((ℓ ℓs) ...)) (ℓ ...)]) 2528 | 2529 | (test-equal 2530 | (term (in-scope-lifetimes [(a [b c]) (d [e f])])) 2531 | (term [a d])) 2532 | 2533 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2534 | ;; loaned-paths 2535 | 2536 | (define-metafunction Patina-typing 2537 | loaned-paths : £ -> lvs 2538 | 2539 | [(loaned-paths [(ℓ mq lv) ...]) (lv ...)]) 2540 | 2541 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2542 | ;; owning-path srs ty lv -> lv 2543 | ;; 2544 | ;; Returns the largest owned prefix of `lv`. For example, if `lv` is 2545 | ;; `x.f`, then it would return `x.f`. If `lv` were `(*x).f`, then the 2546 | ;; result would either be `(*x).f` if `x` is an owned pointer (i.e., 2547 | ;; `~T`), or `x` if `x` is a reference (e.g., `&T`). 2548 | 2549 | (define-metafunction Patina-typing 2550 | owning-path : srs T lv -> lv 2551 | 2552 | [(owning-path srs T lv) 2553 | (owning-path1 srs T lv lv)] 2554 | 2555 | ) 2556 | 2557 | ;; Helper function. Second argument is the maximal owned path found so 2558 | ;; far. 2559 | (define-metafunction Patina-typing 2560 | owning-path1 : srs T lv lv -> lv 2561 | 2562 | [(owning-path1 srs T x lv_m) lv_m] 2563 | 2564 | [(owning-path1 srs T (lv_0 · f) lv_m) 2565 | (owning-path1 srs T lv_0 lv_m)] 2566 | 2567 | [(owning-path1 srs T (lv_0 @ lv_1) lv_m) 2568 | (owning-path1 srs T lv_0 lv_m)] 2569 | 2570 | [(owning-path1 srs T (* lv_0) lv_m) 2571 | (owning-path1 srs T lv_0 lv_m) 2572 | (where (~ ty) (lvtype srs T lv_0))] 2573 | 2574 | [(owning-path1 srs T (* lv_0) lv_m) 2575 | (owning-path1 srs T lv_0 lv_0) 2576 | (where (& ℓ mq ty) (lvtype srs T lv_0))] 2577 | 2578 | ) 2579 | 2580 | (test-equal 2581 | (term (owning-path ,test-srs ,test-T (* (b · 1)))) 2582 | (term (b · 1))) 2583 | 2584 | (test-equal 2585 | (term (owning-path ,test-srs ,test-T (* r))) 2586 | (term (* r))) 2587 | 2588 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2589 | ;; prefix-paths lv 2590 | ;; 2591 | ;; Given something like (*x).f, yields: [(*x).f, *x, x] 2592 | 2593 | (define-metafunction Patina-typing 2594 | prefix-paths : lv -> lvs 2595 | 2596 | [(prefix-paths x) 2597 | [x] 2598 | ] 2599 | 2600 | [(prefix-paths (lv · f)) 2601 | [(lv · f) lv_1 ...] 2602 | (where [lv_1 ...] (prefix-paths lv)) 2603 | ] 2604 | 2605 | [(prefix-paths (lv_b @ lv_i)) 2606 | [(lv_b @ lv_i) lv_1 ...] 2607 | (where [lv_1 ...] (prefix-paths lv)) 2608 | ] 2609 | 2610 | [(prefix-paths (* lv)) 2611 | [(* lv) lv_1 ...] 2612 | (where [lv_1 ...] (prefix-paths lv)) 2613 | ] 2614 | 2615 | ) 2616 | 2617 | (test-equal 2618 | (term (prefix-paths (* (b · 1)))) 2619 | (term [(* (b · 1)) (b · 1) b])) 2620 | 2621 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2622 | ;; mut-loans £ 2623 | 2624 | (define-metafunction Patina-typing 2625 | mut-loans : £ -> £ 2626 | 2627 | [(mut-loans []) 2628 | []] 2629 | 2630 | [(mut-loans [(ℓ imm lv) loan ...]) 2631 | (mut-loans [loan ...])] 2632 | 2633 | [(mut-loans [(ℓ mut lv) loan ...]) 2634 | [(ℓ mut lv) loan_1 ...] 2635 | (where [loan_1 ...] (mut-loans [loan ...]))] 2636 | 2637 | ) 2638 | 2639 | (test-equal 2640 | (term (mut-loans [(a imm x) (b mut y) (c imm z) (d mut a)])) 2641 | (term [(b mut y) (d mut a)])) 2642 | 2643 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2644 | ;; paths-intersect lv lv 2645 | ;; 2646 | ;; We say that two paths intersect if one is a subpath of the other. 2647 | ;; So, for example, x.y and x intersect, but x.y and x.z do not. 2648 | 2649 | (define-metafunction Patina-typing 2650 | paths-intersect : lv lv -> boolean 2651 | 2652 | [(paths-intersect lv_1 lv_2) 2653 | (∨ (∈ lv_1 (prefix-paths lv_2)) 2654 | (∈ lv_2 (prefix-paths lv_1)))] 2655 | ) 2656 | 2657 | (test-equal 2658 | (term (paths-intersect (x · 0) (x · 1))) 2659 | #f) 2660 | 2661 | (test-equal 2662 | (term (paths-intersect (x · 0) x)) 2663 | #t) 2664 | 2665 | (test-equal 2666 | (term (paths-intersect x (x · 0))) 2667 | #t) 2668 | 2669 | 2670 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2671 | ;; path-is-prefix-of lv_1 lv_2 2672 | ;; 2673 | ;; x is a prefix of x, x.y, and *x. Got it? 2674 | 2675 | (define-metafunction Patina-typing 2676 | path-is-prefix-of : lv lv -> boolean 2677 | 2678 | [(path-is-prefix-of lv_1 lv_2) 2679 | (∈ lv_1 (prefix-paths lv_2))] 2680 | ) 2681 | 2682 | (test-equal 2683 | (term (path-is-prefix-of (x · 0) (x · 1))) 2684 | #f) 2685 | 2686 | (test-equal 2687 | (term (path-is-prefix-of (x · 0) x)) 2688 | #f) 2689 | 2690 | (test-equal 2691 | (term (path-is-prefix-of x x)) 2692 | #t) 2693 | 2694 | (test-equal 2695 | (term (path-is-prefix-of x (* x))) 2696 | #t) 2697 | 2698 | (test-equal 2699 | (term (path-is-prefix-of x (x · 1))) 2700 | #t) 2701 | 2702 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2703 | ;; lv-shallowly-initialized 2704 | ;; 2705 | ;; Holds if the lvalue lv is initialized, though some subpaths may not be 2706 | 2707 | (define-metafunction Patina-typing 2708 | lv-shallowly-initialized : Δ lv -> boolean 2709 | 2710 | [(lv-shallowly-initialized Δ lv) 2711 | (∄ [(∈ lv_b Δ) ...]) 2712 | (where [lv_b ...] (prefix-paths lv))] 2713 | ) 2714 | 2715 | (test-equal 2716 | (term (lv-shallowly-initialized [] p)) 2717 | #t) 2718 | 2719 | (test-equal 2720 | (term (lv-shallowly-initialized [] (* p))) 2721 | #t) 2722 | 2723 | (test-equal 2724 | (term (lv-shallowly-initialized [p] p)) 2725 | #f) 2726 | 2727 | (test-equal 2728 | (term (lv-shallowly-initialized [(* p)] p)) 2729 | #t) 2730 | 2731 | (test-equal 2732 | (term (lv-shallowly-initialized [p] (* p))) 2733 | #f) 2734 | 2735 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2736 | ;; lv-deeply-initialized Δ lv 2737 | ;; 2738 | ;; Hold if the lvalue lv is fully initialized. 2739 | 2740 | (define-metafunction Patina-typing 2741 | lv-deeply-initialized : Δ lv -> boolean 2742 | 2743 | [(lv-deeply-initialized [lv_Δ ...] lv) 2744 | (∄ [(paths-intersect lv lv_Δ) ...])] 2745 | ) 2746 | 2747 | (test-equal 2748 | (term (lv-deeply-initialized [] p)) 2749 | #t) 2750 | 2751 | (test-equal 2752 | (term (lv-deeply-initialized [] (* p))) 2753 | #t) 2754 | 2755 | (test-equal 2756 | (term (lv-deeply-initialized [p] p)) 2757 | #f) 2758 | 2759 | (test-equal 2760 | (term (lv-deeply-initialized [(* p)] p)) 2761 | #f) 2762 | 2763 | (test-equal 2764 | (term (lv-deeply-initialized [p] (* p))) 2765 | #f) 2766 | 2767 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2768 | ;; lv-dropped-if-necessary 2769 | ;; 2770 | ;; True if lv has been dropped or does not need to be dropped. 2771 | 2772 | (define-judgment-form 2773 | Patina-typing 2774 | #:mode (lv-dropped-if-necessary I I I I ) 2775 | #:contract (lv-dropped-if-necessary srs T Δ lv) 2776 | 2777 | [(side-condition (∈ lv Δ)) 2778 | -------------------------------------------------- 2779 | (lv-dropped-if-necessary srs T Δ lv)] 2780 | 2781 | [(where (struct s ℓs) (lvtype srs T lv)) 2782 | (where [f ...] (field-names srs s ℓs)) 2783 | (lv-dropped-if-necessary srs T Δ (lv · f)) ... 2784 | -------------------------------------------------- 2785 | (lv-dropped-if-necessary srs T Δ lv)] 2786 | 2787 | [(where ty (lvtype srs T lv)) 2788 | (side-condition (¬ (ty-needs-drop srs ty))) 2789 | -------------------------------------------------- 2790 | (lv-dropped-if-necessary srs T Δ lv)] 2791 | 2792 | ) 2793 | 2794 | ;; owned pointer and it is not dropped 2795 | (test-equal 2796 | (judgment-holds (lv-dropped-if-necessary ,test-srs ,test-ty-T [] owned-B)) 2797 | #f) 2798 | 2799 | ;; this field has type int 2800 | (test-equal 2801 | (judgment-holds (lv-dropped-if-necessary ,test-srs ,test-ty-T [] ((* owned-B) · 0))) 2802 | #t) 2803 | 2804 | ;; none of the fields of struct B require drop 2805 | (test-equal 2806 | (judgment-holds (lv-dropped-if-necessary ,test-srs ,test-ty-T [] (* owned-B))) 2807 | #t) 2808 | 2809 | ;; but struct E's fields do 2810 | (test-equal 2811 | (judgment-holds (lv-dropped-if-necessary ,test-srs ,test-ty-T [] (* owned-E))) 2812 | #f) 2813 | (test-equal 2814 | (judgment-holds (lv-dropped-if-necessary ,test-srs ,test-ty-T [((* owned-E) · 0)] (* owned-E))) 2815 | #t) 2816 | 2817 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2818 | ;; initialize-lv Δ lv 2819 | ;; 2820 | ;; Returns a modified Δ in which lv is initialized 2821 | 2822 | (define-metafunction Patina-typing 2823 | initialize-lv : Δ lv -> Δ 2824 | 2825 | [(initialize-lv Δ lv) 2826 | (if-true [lv_Δ ...] 2827 | [(¬ (path-is-prefix-of lv lv_Δ)) ...]) 2828 | (where [lv_Δ ...] Δ) 2829 | ] 2830 | 2831 | ) 2832 | 2833 | (test-equal 2834 | (term (initialize-lv [((* p) · 1)] p)) 2835 | (term [])) 2836 | 2837 | (test-equal 2838 | (term (initialize-lv [((* p) · 1)] (* p))) 2839 | (term [])) 2840 | 2841 | (test-equal 2842 | (term (initialize-lv [((* p) · 1)] ((* p) · 2))) 2843 | (term [((* p) · 1)])) 2844 | 2845 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2846 | ;; lifetime-in-scope Λ ℓ 2847 | ;; 2848 | ;; Holds if the lifetime ℓ is in scope 2849 | 2850 | (define-judgment-form 2851 | Patina-typing 2852 | #:mode (lifetime-in-scope I I) 2853 | #:contract (lifetime-in-scope Λ ℓ) 2854 | 2855 | [-------------------------------------------------- 2856 | (lifetime-in-scope Λ static)] 2857 | 2858 | [(side-condition (∈ ℓ (in-scope-lifetimes Λ))) 2859 | -------------------------------------------------- 2860 | (lifetime-in-scope Λ ℓ)] 2861 | 2862 | ) 2863 | 2864 | (test-equal 2865 | (judgment-holds (lifetime-in-scope [(a []) (b [])] a)) 2866 | #t) 2867 | 2868 | (test-equal 2869 | (judgment-holds (lifetime-in-scope [(a []) (b [])] b)) 2870 | #t) 2871 | 2872 | (test-equal 2873 | (judgment-holds (lifetime-in-scope [(a []) (b [])] c)) 2874 | #f) 2875 | 2876 | (test-equal 2877 | (judgment-holds (lifetime-in-scope [] static)) 2878 | #t) 2879 | 2880 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2881 | ;; ty-bound-by-lifetime Λ ℓ ty 2882 | ;; 2883 | ;; If this judgement holds, then the type `ty` is bound by the 2884 | ;; lifetime ℓ. 2885 | 2886 | (define-judgment-form 2887 | Patina-typing 2888 | #:mode (ty-bound-by-lifetime I I I ) 2889 | #:contract (ty-bound-by-lifetime Λ ℓ ty) 2890 | 2891 | [------------------------------ 2892 | (ty-bound-by-lifetime Λ ℓ int)] 2893 | 2894 | [(ty-bound-by-lifetime Λ ℓ ty) 2895 | -------------------------------------- 2896 | (ty-bound-by-lifetime Λ ℓ (Option ty))] 2897 | 2898 | [(ty-bound-by-lifetime Λ ℓ ty) 2899 | ---------------------------------------- 2900 | (ty-bound-by-lifetime Λ ℓ (vec ty olen))] 2901 | 2902 | [(ty-bound-by-lifetime Λ ℓ ty) 2903 | --------------------------------- 2904 | (ty-bound-by-lifetime Λ ℓ (~ ty))] 2905 | 2906 | [(lifetime-≤ Λ ℓ_0 ℓ_1) ; ℓ_1 cannot be shorter than ℓ_0 2907 | (ty-bound-by-lifetime Λ ℓ_0 ty) 2908 | ------------------------------------------ 2909 | (ty-bound-by-lifetime Λ ℓ_0 (& ℓ_1 mq ty))] 2910 | 2911 | [(lifetime-≤ Λ ℓ_0 ℓ_1) ... ; ℓ_1s cannot be shorter than ℓ_0 2912 | ; all the fields in s are bounded by the lifetime parameters 2913 | ; thus, if the lifetimes all outlive ℓ_0, then so too do the fields 2914 | ------------------------------------------------- 2915 | (ty-bound-by-lifetime Λ ℓ_0 (struct s (ℓ_1 ...)))] 2916 | ) 2917 | 2918 | (test-equal #t (judgment-holds (ty-bound-by-lifetime ((l0 ()) (l1 (l0))) l1 (& l1 imm int)))) 2919 | (test-equal #t (judgment-holds (ty-bound-by-lifetime ((l0 ()) (l1 (l0))) l1 (& l0 imm int)))) 2920 | (test-equal #f (judgment-holds (ty-bound-by-lifetime ((l0 ()) (l1 (l0))) l0 (& l1 imm int)))) 2921 | (test-equal #t (judgment-holds (ty-bound-by-lifetime ((l0 ()) (l1 (l0))) l0 (& l0 imm int)))) 2922 | 2923 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2924 | ;; unencumbered £ lv 2925 | ;; 2926 | ;; True if lv has not been loaned out. 2927 | 2928 | (define-judgment-form 2929 | Patina-typing 2930 | #:mode (unencumbered I I ) 2931 | #:contract (unencumbered £ lv) 2932 | 2933 | [(side-condition (∉ lv (loaned-paths £))) 2934 | -------------------------------------------------- 2935 | (unencumbered £ lv)] 2936 | 2937 | ) 2938 | 2939 | (test-equal 2940 | (judgment-holds (unencumbered [(a imm x)] y)) 2941 | #t) 2942 | 2943 | (test-equal 2944 | (judgment-holds (unencumbered [(a imm x)] x)) 2945 | #f) 2946 | 2947 | (test-equal 2948 | (judgment-holds (unencumbered [(a imm x)] (* x))) 2949 | #t) 2950 | 2951 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2952 | ;; owned-path srs T lv 2953 | ;; 2954 | ;; Holds if the path `lv` is an *owned path*. 2955 | 2956 | (define-judgment-form 2957 | Patina-typing 2958 | #:mode (owned-path I I I ) 2959 | #:contract (owned-path srs T lv) 2960 | 2961 | [(where lv (owning-path srs T lv)) 2962 | -------------------------------------------------- 2963 | (owned-path srs T lv)] 2964 | 2965 | ) 2966 | 2967 | (test-equal 2968 | (judgment-holds (owned-path ,test-srs ,test-T (* (b · 1)))) 2969 | #f) 2970 | 2971 | (test-equal 2972 | (judgment-holds (owned-path ,test-srs ,test-T (b · 1))) 2973 | #t) 2974 | 2975 | (test-equal 2976 | (judgment-holds (owned-path ,test-srs ,test-T (* r))) 2977 | #t) 2978 | 2979 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2980 | ;; paths-restricted-by-loans 2981 | ;; 2982 | ;; If a loan affects the lvalue `lv`, this function returns a set of 2983 | ;; paths for `lv` that are *restricted* as a result. A path is 2984 | ;; restricted if accessing it would violate the terms of the loan. 2985 | ;; 2986 | ;; More concretely, for a mutable loan of `lv`, `restricted-paths lv` 2987 | ;; yields the set of paths that cannot be read or written as a result. 2988 | ;; This includes not only `lv` itself but base paths of `lv`, because 2989 | ;; reading those paths would either copy `lv` (as part of a larger 2990 | ;; copy) or else create a second path to the same memory that was 2991 | ;; borrowed. Similar concerns hold for writing. 2992 | 2993 | (define-metafunction Patina-typing 2994 | paths-restricted-by-loans : srs T £ -> lvs 2995 | 2996 | [(paths-restricted-by-loans srs T [(ℓ mq lv) ...]) 2997 | ,(append* (term [(paths-restricted-by-loan-of srs T lv) ...]))]) 2998 | 2999 | (define-metafunction Patina-typing 3000 | paths-restricted-by-loan-of : srs T lv -> lvs 3001 | 3002 | [(paths-restricted-by-loan-of srs T x) 3003 | [x] 3004 | ] 3005 | 3006 | [(paths-restricted-by-loan-of srs T (lv · f)) 3007 | [(lv · f) lv_1 ...] 3008 | (where [lv_1 ...] (paths-restricted-by-loan-of srs T lv)) 3009 | ] 3010 | 3011 | [(paths-restricted-by-loan-of srs T (lv_a @ lv_i)) 3012 | [(lv_a @ lv_i) lv_1 ...] 3013 | (where [lv_1 ...] (paths-restricted-by-loan-of srs T lv_a)) 3014 | ] 3015 | 3016 | [(paths-restricted-by-loan-of srs T (* lv)) 3017 | [(* lv) lv_1 ...] 3018 | (where (~ ty) (lvtype srs T lv)) 3019 | (where [lv_1 ...] (paths-restricted-by-loan-of srs T lv)) 3020 | ] 3021 | 3022 | ;; If we borrowed `*x` and `x` is a `&T`, that need not prevent us 3023 | ;; from reading (or writing) `x`. I would eventually like to extend 3024 | ;; this rule to handle writes to &mut borrowed lvalues too, but that 3025 | ;; needs a bit more infrastructure and for time being I want to 3026 | ;; model what rustc currently allows (or should allow). 3027 | [(paths-restricted-by-loan-of srs T (* lv)) 3028 | [(* lv)] 3029 | (where (& ℓ imm ty) (lvtype srs T lv)) 3030 | ] 3031 | 3032 | [(paths-restricted-by-loan-of srs T (* lv)) 3033 | [(* lv) lv_1 ...] 3034 | (where (& ℓ mut ty) (lvtype srs T lv)) 3035 | (where [lv_1 ...] (paths-restricted-by-loan-of srs T lv)) 3036 | ] 3037 | 3038 | ) 3039 | 3040 | (test-equal 3041 | (term (paths-restricted-by-loan-of ,test-srs ,test-T (* (b · 1)))) 3042 | (term [(* (b · 1)) (b · 1) b])) 3043 | 3044 | (test-equal 3045 | (term (paths-restricted-by-loan-of ,test-srs ,test-T (* q))) 3046 | (term [(* q)])) 3047 | 3048 | (test-equal 3049 | (term (paths-restricted-by-loans ,test-srs ,test-T [(a imm (* q)) 3050 | (a mut (* (b · 1)))])) 3051 | (term [(* q) (* (b · 1)) (b · 1) b])) 3052 | 3053 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3054 | ;; path-unique-for srs T Λ ℓ lv 3055 | ;; 3056 | ;; Holds if the path `lv` is a *unique path* during the lifetime ℓ. 3057 | ;; This means that, during the lifetime ℓ, `lv` is the only 3058 | ;; *accessible* path that would evaluate to that particular address. 3059 | 3060 | (define-judgment-form 3061 | Patina-typing 3062 | #:mode (reject-x I) 3063 | #:contract (reject-x any) 3064 | 3065 | [-------------------------------------------------- 3066 | (reject-x debug-me)] 3067 | 3068 | ) 3069 | 3070 | (define-judgment-form 3071 | Patina-typing 3072 | #:mode (path-unique-for I I I I I ) 3073 | #:contract (path-unique-for srs T Λ ℓ lv) 3074 | 3075 | [-------------------------------------------------- 3076 | (path-unique-for srs T Λ ℓ x)] 3077 | 3078 | [(path-unique-for srs T Λ ℓ lv) 3079 | -------------------------------------------------- 3080 | (path-unique-for srs T Λ ℓ (lv · f))] 3081 | 3082 | [(path-unique-for srs T Λ ℓ lv) 3083 | -------------------------------------------------- 3084 | (path-unique-for srs T Λ ℓ (lv @ lv_1))] 3085 | 3086 | [(where (~ ty) (lvtype srs T lv)) 3087 | (path-unique-for srs T Λ ℓ lv) 3088 | -------------------------------------------------- 3089 | (path-unique-for srs T Λ ℓ (* lv))] 3090 | 3091 | [(where (& ℓ_lv mut ty) (lvtype srs T lv)) 3092 | (lifetime-≤ Λ ℓ ℓ_lv) 3093 | (path-unique-for srs T Λ ℓ lv) 3094 | -------------------------------------------------- 3095 | (path-unique-for srs T Λ ℓ (* lv))] 3096 | 3097 | ) 3098 | 3099 | (test-equal 3100 | (judgment-holds (path-unique-for ,test-srs ,test-ty-T ,test-ty-Λ 3101 | b r-imm-B)) 3102 | #t) 3103 | 3104 | (test-equal 3105 | (judgment-holds (path-unique-for ,test-srs ,test-ty-T ,test-ty-Λ 3106 | b (* ((* r-imm-B) · 1)))) 3107 | #f) 3108 | 3109 | (test-equal 3110 | (judgment-holds (path-unique-for ,test-srs ,test-ty-T ,test-ty-Λ 3111 | b (* ((* r-mut-B) · 1)))) 3112 | #t) 3113 | 3114 | (test-equal 3115 | (judgment-holds (path-unique-for ,test-srs ,test-ty-T ,test-ty-Λ 3116 | a (* ((* r-mut-B) · 1)))) 3117 | #f) 3118 | 3119 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3120 | ;; path-freezable-for srs T Λ ℓ lv 3121 | ;; 3122 | ;; Holds if the path `lv` is a *freezable path* during the lifetime ℓ. 3123 | ;; I am not quite sure how best to phrase this predicate in English. 3124 | ;; Roughly speaking, the path-freezable-for predicte guarantees that the 3125 | ;; memory which `lv` evaluates to will not be mutated during the 3126 | ;; lifetime ℓ, assuming that the path `lv` is not itself assigned to 3127 | ;; (if that is even possible). Often this corresponds to the underlying 3128 | ;; memory referenced by `lv` but not always. 3129 | ;; 3130 | ;; Here are some interesting and representative examples: 3131 | ;; 3132 | ;; 1. `fn foo(x: &'a &'b mut T) -> &'a T { &**x }` 3133 | ;; 3134 | ;; This example is legal because the path **x is freezable-for the 3135 | ;; lifetime 'a. If however the return type were `&'b T`, the 3136 | ;; example would be an error, because `**x` is not freezable-for 3137 | ;; 'b. This is true *even though* we know that the memory will not yet 3138 | ;; be freed. 3139 | ;; 3140 | ;; The reason is that, so long as the `&mut` *x is considered 3141 | ;; aliased, it cannot be changed. But that alias expires after 'a, 3142 | ;; and hence the memory in 'b would be considered mutable 3143 | ;; again. 3144 | ;; 3145 | ;; 2. `fn foo(x: &'a mut T) -> &'a T { &*x }` 3146 | ;; 3147 | ;; In this case, the path `*x` is freezable-for the lifetime `'a`. 3148 | ;; The reason is that `x` is the only pointer that can mutate `*x` 3149 | ;; during the lifetime `'a`, and hence if we freeze `*x` we can be 3150 | ;; sure that the memory will not change until after `'a`. 3151 | ;; 3152 | ;; 3. `fn foo() -> &'a int { let x = 3; &x }` 3153 | ;; 3154 | ;; Naturally, this case yields an error, but NOT because of 3155 | ;; freezable-for. This is crucial to the previous two examples, in 3156 | ;; fact. The idea here is that while the memory pointed at by `x` 3157 | ;; isn't valid for the entire lifetime 'a, if we ignore memory 3158 | ;; reuse, we can still say that it won't be assigned to. I'm not 3159 | ;; sure how best to express this part in English. Maybe this rule 3160 | ;; can be made more tidy. In any case, there is another predicate 3161 | ;; `path-outlives` that would catch this sort of error. 3162 | 3163 | (define-judgment-form 3164 | Patina-typing 3165 | #:mode (path-freezable-for I I I I I ) 3166 | #:contract (path-freezable-for srs T Λ ℓ lv) 3167 | 3168 | [-------------------------------------------------- 3169 | (path-freezable-for srs T Λ ℓ x)] 3170 | 3171 | [(path-freezable-for srs T Λ ℓ lv) 3172 | -------------------------------------------------- 3173 | (path-freezable-for srs T Λ ℓ (lv · f))] 3174 | 3175 | [(path-freezable-for srs T Λ ℓ lv) 3176 | -------------------------------------------------- 3177 | (path-freezable-for srs T Λ ℓ (lv @ lv_1))] 3178 | 3179 | [(where (~ ty) (lvtype srs T lv)) 3180 | (path-freezable-for srs T Λ ℓ lv) 3181 | -------------------------------------------------- 3182 | (path-freezable-for srs T Λ ℓ (* lv))] 3183 | 3184 | [(where (& ℓ_lv mut ty) (lvtype srs T lv)) 3185 | (lifetime-≤ Λ ℓ ℓ_lv) 3186 | (path-freezable-for srs T Λ ℓ lv) 3187 | -------------------------------------------------- 3188 | (path-freezable-for srs T Λ ℓ (* lv))] 3189 | 3190 | [(where (& ℓ_lv imm ty) (lvtype srs T lv)) 3191 | (lifetime-≤ Λ ℓ ℓ_lv) 3192 | -------------------------------------------------- 3193 | (path-freezable-for srs T Λ ℓ (* lv))] 3194 | 3195 | ) 3196 | 3197 | (test-equal 3198 | (judgment-holds (path-freezable-for ,test-srs ,test-ty-T ,test-ty-Λ 3199 | b r-imm-B)) 3200 | #t) 3201 | 3202 | (test-equal 3203 | (judgment-holds (path-freezable-for ,test-srs ,test-ty-T ,test-ty-Λ 3204 | b (* ((* r-imm-B) · 1)))) 3205 | #t) 3206 | 3207 | (test-equal 3208 | (judgment-holds (path-freezable-for ,test-srs ,test-ty-T ,test-ty-Λ 3209 | b (* ((* r-mut-B) · 1)))) 3210 | #t) 3211 | 3212 | (test-equal 3213 | (judgment-holds (path-freezable-for ,test-srs ,test-ty-T ,test-ty-Λ 3214 | a (* ((* r-mut-B) · 1)))) 3215 | #f) 3216 | 3217 | (test-equal 3218 | (judgment-holds (path-freezable-for ,test-srs ,test-ty-T ,test-ty-Λ 3219 | a (* owned-B))) 3220 | #t) 3221 | 3222 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3223 | ;; can-access 3224 | 3225 | (define-judgment-form 3226 | Patina-typing 3227 | #:mode (can-access I I I I I I ) 3228 | #:contract (can-access srs T Λ £ Δ lv) 3229 | 3230 | [;; Data must be initialized: 3231 | (side-condition (lv-deeply-initialized Δ lv)) 3232 | 3233 | ;; The path lv cannot be restricted by a loan: 3234 | ;; 3235 | ;; This covers cases like these: 3236 | ;; 3237 | ;; let x = &mut a.b.c; // restricts a, a.b, and a.b.c 3238 | ;; a.b = ...; // would overwrite c as part 3239 | ;; 3240 | ;; let x = &a.b.c; // restricts a, a.b, and a.b.c 3241 | ;; a.b = ...; // would overwrite c as part 3242 | ;; 3243 | ;; let x = &mut a.b.c; // restricts a, a.b, and a.b.c 3244 | ;; let y = a.b; // would read c as part 3245 | (where [lv_r ...] (paths-restricted-by-loans srs T £_l)) 3246 | (side-condition (∉ lv [lv_r ...])) 3247 | 3248 | ;; Neither the path lv nor any base path of lv can be borrowed: 3249 | ;; 3250 | ;; This covers cases like this: 3251 | ;; 3252 | ;; let x = &mut a; 3253 | ;; a.b = ...; // would overwrite part of a 3254 | ;; 3255 | ;; let x = &a; 3256 | ;; a.b = ...; // would overwrite part of a 3257 | ;; 3258 | ;; let x = &mut a; 3259 | ;; let y = a.b; // would read part of a 3260 | (where [lv_b ...] (prefix-paths lv)) 3261 | (unencumbered £_l lv_b) ... 3262 | -------------------------------------------------- 3263 | (can-access srs T Λ £_l Δ lv)] 3264 | 3265 | ) 3266 | 3267 | ;; can't access loaned variable 3268 | (test-equal 3269 | (judgment-holds (can-access ,test-srs ,test-ty-T ,test-ty-Λ 3270 | [(a mut r-imm-B)] [] r-imm-B)) 3271 | #f) 3272 | 3273 | ;; can't access variable r-mut-B when (* r-mut-B) was loaned 3274 | (test-equal 3275 | (judgment-holds (can-access ,test-srs ,test-ty-T ,test-ty-Λ 3276 | [(a mut (* r-mut-B))] [] r-mut-B)) 3277 | #f) 3278 | 3279 | ;; can't access variable (* r-mut-B) when r-mut-B was loaned 3280 | (test-equal 3281 | (judgment-holds (can-access ,test-srs ,test-ty-T ,test-ty-Λ 3282 | [(a mut r-mut-B)] [] (* r-mut-B))) 3283 | #f) 3284 | 3285 | ;; accessing (*r-mut-B).1 when (*r-mut-B).0 was loaned is ok 3286 | (test-equal 3287 | (judgment-holds (can-access ,test-srs ,test-ty-T ,test-ty-Λ 3288 | [(a mut ((* r-mut-B) · 0))] [] 3289 | ((* r-mut-B) · 1))) 3290 | #t) 3291 | 3292 | ;; can't access uninitialized variable 3293 | (test-equal 3294 | (judgment-holds (can-access ,test-srs ,test-ty-T ,test-ty-Λ 3295 | [(a mut r-imm-B)] [r-mut-B] r-mut-B)) 3296 | #f) 3297 | 3298 | ;; can't access uninitialized referent 3299 | (test-equal 3300 | (judgment-holds (can-access ,test-srs ,test-ty-T ,test-ty-Λ 3301 | [] [(* owned-B)] (* owned-B))) 3302 | #f) 3303 | 3304 | ;; can't access referent of uninitialized pointer 3305 | (test-equal 3306 | (judgment-holds (can-access ,test-srs ,test-ty-T ,test-ty-Λ 3307 | [] [owned-B] (* owned-B))) 3308 | #f) 3309 | 3310 | ;; otherwise ok 3311 | (test-equal 3312 | (judgment-holds (can-access ,test-srs ,test-ty-T ,test-ty-Λ 3313 | [(a mut r-imm-B)] [] r-mut-B)) 3314 | #t) 3315 | 3316 | (test-equal 3317 | (judgment-holds (can-access ,test-srs ,test-ty-T ,test-ty-Λ 3318 | [] [] (* owned-B))) 3319 | #t) 3320 | 3321 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3322 | ;; can-read-from 3323 | 3324 | (define-judgment-form 3325 | Patina-typing 3326 | #:mode (can-read-from I I I I I I ) 3327 | #:contract (can-read-from srs T Λ £ Δ lv) 3328 | 3329 | [;; Only mutable loans prevent reads: 3330 | (can-access srs T Λ (mut-loans £) Δ lv) 3331 | -------------------------------------------------- 3332 | (can-read-from srs T Λ £ Δ lv)] 3333 | 3334 | ) 3335 | 3336 | ;; imm loans do not prevent reads 3337 | (test-equal 3338 | (judgment-holds (can-read-from ,test-srs ,test-ty-T ,test-ty-Λ 3339 | [(a imm r-imm-B)] [] r-imm-B)) 3340 | #t) 3341 | 3342 | ;; but mut loans do 3343 | (test-equal 3344 | (judgment-holds (can-read-from ,test-srs ,test-ty-T ,test-ty-Λ 3345 | [(a mut r-imm-B)] [] r-imm-B)) 3346 | #f) 3347 | 3348 | ;; read from (* owned-B) 3349 | (test-equal 3350 | (judgment-holds (can-read-from ,test-srs ,test-ty-T ,test-ty-Λ 3351 | [] [] (* owned-B))) 3352 | #t) 3353 | 3354 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3355 | ;; can-write-to 3356 | 3357 | (define-judgment-form 3358 | Patina-typing 3359 | #:mode (can-write-to I I I I I I ) 3360 | #:contract (can-write-to srs T Λ £ Δ lv) 3361 | 3362 | [;; All loans prevent writes: 3363 | (can-access srs T Λ £ Δ lv) 3364 | -------------------------------------------------- 3365 | (can-write-to srs T Λ £ Δ lv)] 3366 | 3367 | ) 3368 | 3369 | ;; imm loans do prevent writes 3370 | (test-equal 3371 | (judgment-holds (can-write-to ,test-srs ,test-ty-T ,test-ty-Λ 3372 | [(a imm r-imm-B)] [] r-imm-B)) 3373 | #f) 3374 | 3375 | ;; as do mut loans 3376 | (test-equal 3377 | (judgment-holds (can-write-to ,test-srs ,test-ty-T ,test-ty-Λ 3378 | [(a mut r-imm-B)] [] r-imm-B)) 3379 | #f) 3380 | 3381 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3382 | ;; can-move-from 3383 | 3384 | (define-judgment-form 3385 | Patina-typing 3386 | #:mode (can-move-from I I I I I I ) 3387 | #:contract (can-move-from srs T Λ £ Δ lv) 3388 | 3389 | [;; Can only move from things we own: 3390 | (owned-path srs T lv) 3391 | 3392 | ;; Otherwise same as write: 3393 | (can-write-to srs T Λ £ Δ lv) 3394 | -------------------------------------------------- 3395 | (can-move-from srs T Λ £ Δ lv)] 3396 | 3397 | ) 3398 | 3399 | ;; imm loans prevent moves 3400 | (test-equal 3401 | (judgment-holds (can-move-from ,test-srs ,test-ty-T ,test-ty-Λ 3402 | [(b imm r-imm-B)] [] r-imm-B)) 3403 | #f) 3404 | (test-equal 3405 | (judgment-holds (can-move-from ,test-srs ,test-ty-T ,test-ty-Λ 3406 | [(b imm owned-B)] [] (* owned-B))) 3407 | #f) 3408 | (test-equal 3409 | (judgment-holds (can-move-from ,test-srs ,test-ty-T ,test-ty-Λ 3410 | [(b imm (* owned-B))] [] (* owned-B))) 3411 | #f) 3412 | (test-equal 3413 | (judgment-holds (can-move-from ,test-srs ,test-ty-T ,test-ty-Λ 3414 | [(b imm ((* owned-B) · 0))] [] (* owned-B))) 3415 | #f) 3416 | (test-equal 3417 | (judgment-holds (can-move-from ,test-srs ,test-ty-T ,test-ty-Λ 3418 | [(b imm owned-B)] [] (* owned-B))) 3419 | #f) 3420 | 3421 | ;; as do mut loans 3422 | (test-equal 3423 | (judgment-holds (can-move-from ,test-srs ,test-ty-T ,test-ty-Λ 3424 | [(b mut r-imm-B)] [] r-imm-B)) 3425 | #f) 3426 | (test-equal 3427 | (judgment-holds (can-move-from ,test-srs ,test-ty-T ,test-ty-Λ 3428 | [(b mut owned-B)] [] (* owned-B))) 3429 | #f) 3430 | 3431 | ;; otherwise ok 3432 | (test-equal 3433 | (judgment-holds (can-move-from ,test-srs ,test-ty-T ,test-ty-Λ 3434 | [] [] r-imm-B)) 3435 | #t) 3436 | (test-equal 3437 | (judgment-holds (can-move-from ,test-srs ,test-ty-T ,test-ty-Λ 3438 | [] [] owned-B)) 3439 | #t) 3440 | 3441 | ;; but can't move from deref of borrowed pointer 3442 | (test-equal 3443 | (judgment-holds (can-move-from ,test-srs ,test-ty-T ,test-ty-Λ 3444 | [] [] (* r-imm-B))) 3445 | #f) 3446 | 3447 | ;; can move from deref of owned pointer 3448 | (test-equal 3449 | (judgment-holds (can-move-from ,test-srs ,test-ty-T ,test-ty-Λ 3450 | [] [] (* owned-B))) 3451 | #t) 3452 | 3453 | ;; unless uninitialized 3454 | (test-equal 3455 | (judgment-holds (can-move-from ,test-srs ,test-ty-T ,test-ty-Λ 3456 | [] [owned-B] (* owned-B))) 3457 | #f) 3458 | (test-equal 3459 | (judgment-holds (can-move-from ,test-srs ,test-ty-T ,test-ty-Λ 3460 | [] [(* owned-B)] (* owned-B))) 3461 | #f) 3462 | (test-equal 3463 | (judgment-holds (can-move-from ,test-srs ,test-ty-T ,test-ty-Λ 3464 | [] [((* owned-B) · 1)] (* owned-B))) 3465 | #f) 3466 | 3467 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3468 | ;; can-init 3469 | 3470 | (define-judgment-form 3471 | Patina-typing 3472 | #:mode (can-init I I I I I ) 3473 | #:contract (can-init srs T Λ Δ lv) 3474 | 3475 | [(side-condition (∈ x Δ)) 3476 | -------------------------------------------------- 3477 | (can-init srs T Λ Δ x)] 3478 | 3479 | [(side-condition (lv-shallowly-initialized Δ lv)) 3480 | (side-condition (∈ (lv · f) Δ)) 3481 | -------------------------------------------------- 3482 | (can-init srs T Λ Δ (lv · f))] 3483 | 3484 | [(side-condition (lv-shallowly-initialized Δ lv)) 3485 | (side-condition (∈ (* lv) Δ)) 3486 | (where (~ ty) (lvtype srs T lv)) 3487 | -------------------------------------------------- 3488 | (can-init srs T Λ Δ (* lv))] 3489 | 3490 | ) 3491 | 3492 | ;; cannot initiatialize something already written 3493 | (test-equal 3494 | (judgment-holds (can-init ,test-srs ,test-ty-T ,test-ty-Λ 3495 | [] r-mut-B)) 3496 | #f) 3497 | 3498 | ;; cannot initiatialize borrowed data 3499 | (test-equal 3500 | (judgment-holds (can-init ,test-srs ,test-ty-T ,test-ty-Λ 3501 | [] (* r-mut-B))) 3502 | #f) 3503 | 3504 | ;; but can initialize something that is deinitialized 3505 | (test-equal 3506 | (judgment-holds (can-init ,test-srs ,test-ty-T ,test-ty-Λ 3507 | [r-imm-B] r-imm-B)) 3508 | #t) 3509 | 3510 | (test-equal 3511 | (judgment-holds (can-init ,test-srs ,test-ty-T ,test-ty-Λ 3512 | [(* owned-B)] (* owned-B))) 3513 | #t) 3514 | 3515 | (test-equal 3516 | (judgment-holds (can-init ,test-srs ,test-ty-T ,test-ty-Λ 3517 | [((* owned-B) · 1)] ((* owned-B) · 1))) 3518 | #t) 3519 | 3520 | ;; as long as the base path is initialized 3521 | 3522 | (test-equal 3523 | (judgment-holds (can-init ,test-srs ,test-ty-T ,test-ty-Λ 3524 | [owned-B (* owned-B)] (* owned-B))) 3525 | #f) 3526 | 3527 | (test-equal 3528 | (judgment-holds (can-init ,test-srs ,test-ty-T ,test-ty-Λ 3529 | [owned-B ((* owned-B) · 1)] ((* owned-B) · 1))) 3530 | #f) 3531 | 3532 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3533 | ;; path-valid-for-lifetime 3534 | ;; 3535 | ;; Holds if the memory directly referenced by `lv` 3536 | ;; will outlive `ℓ`. 3537 | 3538 | (define-judgment-form 3539 | Patina-typing 3540 | #:mode (path-valid-for-lifetime I I I I I I ) 3541 | #:contract (path-valid-for-lifetime srs T Λ VL ℓ lv) 3542 | 3543 | [(where ℓ_x ,(get* (term x) (term VL))) 3544 | (lifetime-≤ Λ ℓ ℓ_x) 3545 | -------------------------------------------------- 3546 | (path-valid-for-lifetime srs T Λ VL ℓ x)] 3547 | 3548 | [(path-valid-for-lifetime srs T Λ VL ℓ lv) 3549 | -------------------------------------------------- 3550 | (path-valid-for-lifetime srs T Λ VL ℓ (lv · f))] 3551 | 3552 | [(path-valid-for-lifetime srs T Λ VL ℓ lv) 3553 | -------------------------------------------------- 3554 | (path-valid-for-lifetime srs T Λ VL ℓ (lv @ lv_i))] 3555 | 3556 | [(where (~ ty) (lvtype srs T lv)) 3557 | (path-valid-for-lifetime srs T Λ VL ℓ lv) 3558 | -------------------------------------------------- 3559 | (path-valid-for-lifetime srs T Λ VL ℓ (* lv))] 3560 | 3561 | [(where (& ℓ_lv mq ty) (lvtype srs T lv)) 3562 | (lifetime-≤ Λ ℓ ℓ_lv) 3563 | -------------------------------------------------- 3564 | (path-valid-for-lifetime srs T Λ VL ℓ (* lv))] 3565 | 3566 | ) 3567 | 3568 | (test-equal 3569 | (judgment-holds (path-valid-for-lifetime 3570 | ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL 3571 | static (* ((* r-mut-B) · 1)))) 3572 | #t) 3573 | 3574 | (test-equal 3575 | (judgment-holds (path-valid-for-lifetime 3576 | ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL 3577 | static r-mut-B)) 3578 | #f) 3579 | 3580 | (test-equal 3581 | (judgment-holds (path-valid-for-lifetime 3582 | ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL 3583 | a (* ((* r-mut-B) · 1)))) 3584 | #t) 3585 | 3586 | (test-equal 3587 | (judgment-holds (path-valid-for-lifetime 3588 | ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL 3589 | static (* r-mut-B))) 3590 | #f) 3591 | 3592 | (test-equal 3593 | (judgment-holds (path-valid-for-lifetime 3594 | ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL 3595 | a (* r-mut-B))) 3596 | #f) 3597 | 3598 | (test-equal 3599 | (judgment-holds (path-valid-for-lifetime 3600 | ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL 3601 | b (* r-mut-B))) 3602 | #t) 3603 | 3604 | (test-equal 3605 | (judgment-holds (path-valid-for-lifetime 3606 | ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL 3607 | b owned-B)) 3608 | #t) 3609 | 3610 | (test-equal 3611 | (judgment-holds (path-valid-for-lifetime 3612 | ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL 3613 | b (* owned-B))) 3614 | #t) 3615 | 3616 | (test-equal 3617 | (judgment-holds (path-valid-for-lifetime 3618 | ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL 3619 | b ((* owned-B) · 0))) 3620 | #t) 3621 | 3622 | (test-equal 3623 | (judgment-holds (path-valid-for-lifetime 3624 | ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL 3625 | p0 (* owned-B))) 3626 | #f) 3627 | 3628 | (test-equal 3629 | (judgment-holds (path-valid-for-lifetime 3630 | ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL 3631 | p0 (* owned-B))) 3632 | #f) 3633 | 3634 | (test-equal 3635 | (judgment-holds (path-valid-for-lifetime 3636 | ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL 3637 | p0 ((* owned-B) · 0))) 3638 | #f) 3639 | 3640 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3641 | ;; path-outlives 3642 | 3643 | (define-judgment-form 3644 | Patina-typing 3645 | #:mode (path-outlives I I I I I I ) 3646 | #:contract (path-outlives srs T Λ VL ℓ lv) 3647 | 3648 | [;; At present, we require that the borrow be for some lifetime that 3649 | ;; is in scope. I'd like to lift this requirement in the future, 3650 | ;; though I can't recall just what gets more complicated as a 3651 | ;; result! 3652 | (lifetime-in-scope Λ ℓ) 3653 | 3654 | ;; Determine from the path whether we be sure that the path outlives ℓ. 3655 | (path-valid-for-lifetime srs T Λ VL ℓ lv) 3656 | 3657 | ;; Data cannot have a lifetime shorter than the loan ℓ. 3658 | ;; 3659 | ;; FIXME I feel like this check is unnecessary and implied by other 3660 | ;; requirements. In other words, the memory has an ultimate local 3661 | ;; variable in a block with lifetime ℓ, and presumably we wouldn't 3662 | ;; allow that owner to gain access to data with some lifetime less 3663 | ;; than ℓ. (Ah, perhaps this is what becomes complicated if we want 3664 | ;; to allow data to be borrowed for a lifetime not currently in 3665 | ;; scope, actually.) 3666 | (where ty (lvtype srs T lv)) 3667 | (ty-bound-by-lifetime Λ ℓ ty) 3668 | -------------------------------------------------- 3669 | (path-outlives srs T Λ VL ℓ lv)] 3670 | 3671 | ) 3672 | 3673 | (test-equal 3674 | (judgment-holds (path-outlives ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL 3675 | b (* owned-B))) 3676 | #t) 3677 | 3678 | (test-equal 3679 | (judgment-holds (path-outlives ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL 3680 | a (* owned-B))) 3681 | #f) 3682 | 3683 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3684 | ;; use-lv-ok and use-lvs-ok 3685 | 3686 | (define-judgment-form 3687 | Patina-typing 3688 | #:mode (use-lv-ok I I I I I I O O) 3689 | #:contract (use-lv-ok srs T Λ £ Δ lv ty Δ) 3690 | 3691 | ;; If `lv` is POD, it is not moved but rather copied. 3692 | [(where ty (lvtype srs T lv)) 3693 | (can-read-from srs T Λ £ Δ lv) 3694 | (side-condition (ty-is-pod srs ty)) 3695 | -------------------------------------------------- 3696 | (use-lv-ok srs T Λ £ Δ lv ty Δ)] 3697 | 3698 | ;; Otherwise, each use deinitializes the value: 3699 | [(where ty (lvtype srs T lv)) 3700 | (can-move-from srs T Λ £ Δ lv) 3701 | (side-condition (¬ (ty-is-pod srs ty))) 3702 | -------------------------------------------------- 3703 | (use-lv-ok srs T Λ £ Δ lv ty (∪ Δ [lv]))] 3704 | 3705 | ) 3706 | 3707 | ;; using a ~ or &mut pointer kills that pointer (resp. referent) 3708 | (test-equal 3709 | (judgment-holds (use-lv-ok ,test-srs ,test-ty-T ,test-ty-Λ [] 3710 | [] 3711 | owned-B ty Δ) 3712 | (ty / Δ)) 3713 | (term [((~ (struct B (static))) / [owned-B])])) 3714 | (test-equal 3715 | (judgment-holds (use-lv-ok ,test-srs ,test-ty-T ,test-ty-Λ [] 3716 | [] 3717 | (* owned-B) ty Δ) 3718 | (ty / Δ)) 3719 | (term [((struct B (static)) / [(* owned-B)])])) 3720 | (test-equal 3721 | (judgment-holds (use-lv-ok ,test-srs ,test-ty-T ,test-ty-Λ [] 3722 | [] 3723 | ((* owned-B) · 1) ty Δ) 3724 | (ty / Δ)) 3725 | (term [((& static mut int) / [((* owned-B) · 1)])])) 3726 | 3727 | ;; naturally it must be initialized 3728 | (test-equal 3729 | (judgment-holds (use-lv-ok ,test-srs ,test-ty-T ,test-ty-Λ [] 3730 | [owned-B] 3731 | owned-B ty Δ) 3732 | (ty / Δ)) 3733 | (term [])) 3734 | 3735 | ;; using an int doesn't kill anything 3736 | (test-equal 3737 | (judgment-holds (use-lv-ok ,test-srs ,test-ty-T ,test-ty-Λ [] 3738 | [] 3739 | ((* owned-B) · 0) ty Δ) 3740 | (ty / Δ)) 3741 | (term [(int / [])])) 3742 | 3743 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3744 | ;; use-lvs-ok -- uses a sequence of lvalues in order 3745 | 3746 | (define-judgment-form 3747 | Patina-typing 3748 | #:mode (use-lvs-ok I I I I I I O O) 3749 | #:contract (use-lvs-ok srs T Λ £ Δ lvs tys Δ) 3750 | 3751 | [-------------------------------------------------- 3752 | (use-lvs-ok srs T Λ £ Δ [] [] Δ)] 3753 | 3754 | [(use-lv-ok srs T Λ £ Δ lv_0 ty_0 Δ_0) 3755 | (use-lvs-ok srs T Λ £ Δ_0 [lv_1 ...] [ty_1 ...] Δ_1) 3756 | -------------------------------------------------- 3757 | (use-lvs-ok srs T Λ £ Δ [lv_0 lv_1 ...] [ty_0 ty_1 ...] Δ_1)] 3758 | 3759 | ) 3760 | 3761 | (test-equal 3762 | (judgment-holds (use-lvs-ok ,test-srs ,test-ty-T ,test-ty-Λ [] 3763 | [] 3764 | [owned-B] tys Δ) 3765 | (tys / Δ)) 3766 | (term [([(~ (struct B (static)))] / [owned-B])])) 3767 | 3768 | (test-equal 3769 | (judgment-holds (use-lvs-ok ,test-srs ,test-ty-T ,test-ty-Λ [] 3770 | [] 3771 | [owned-B r-imm-B] tys Δ) 3772 | (tys / Δ)) 3773 | (term [([(~ (struct B (static))) 3774 | (& b imm (struct B (static)))] 3775 | / [owned-B])])) 3776 | 3777 | ;; using a ~ pointer kills both that pointer and any owned subpaths 3778 | (test-equal 3779 | (judgment-holds (use-lvs-ok ,test-srs ,test-ty-T ,test-ty-Λ [] 3780 | [] 3781 | [owned-B (* owned-B)] tys Δ) 3782 | (tys / Δ)) 3783 | (term [])) 3784 | 3785 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3786 | ;; expire-loans 3787 | 3788 | (define-metafunction Patina-typing 3789 | expire-loans : ℓ £ -> £ 3790 | 3791 | [(expire-loans ℓ_e [(ℓ mq lv) ...]) 3792 | (if-true [(ℓ mq lv) ...] 3793 | [(lifetime-≠ ℓ ℓ_e) ...])] 3794 | ) 3795 | 3796 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3797 | ;; expire-paths 3798 | 3799 | (define-metafunction Patina-typing 3800 | expire-paths : lvs Δ -> Δ 3801 | 3802 | [(expire-paths lvs [lv_Δ ...]) 3803 | (if-true [lv_Δ ...] 3804 | [(should-expire-path lvs lv_Δ) ...])] 3805 | ) 3806 | 3807 | (define-metafunction Patina-typing 3808 | should-expire-path : lvs lv -> boolean 3809 | 3810 | [(should-expire-path [lv_e ...] lv) 3811 | (∄ [(path-is-prefix-of lv_e lv) ...])] 3812 | ) 3813 | 3814 | (test-equal 3815 | (term (expire-paths [x] [(* x) x (* y) y])) 3816 | (term [(* y) y])) 3817 | 3818 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3819 | ;; rv-ok 3820 | 3821 | (define-judgment-form 3822 | Patina-typing 3823 | #:mode (rv-ok I I I I I I I O O O) 3824 | #:contract (rv-ok srs T Λ VL £ Δ rv ty £ Δ) 3825 | 3826 | ;; lv 3827 | [(use-lv-ok srs T Λ £ Δ lv ty_out Δ_out) 3828 | -------------------------------------------------- 3829 | (rv-ok srs T Λ VL £ Δ lv ty_out £ Δ_out)] 3830 | 3831 | ;; & ℓ imm lv 3832 | [(where ty (lvtype srs T lv)) 3833 | (can-read-from srs T Λ £ Δ lv) 3834 | (path-freezable-for srs T Λ ℓ lv) 3835 | (path-outlives srs T Λ VL ℓ lv) 3836 | -------------------------------------------------- 3837 | (rv-ok srs T Λ VL £ Δ (& ℓ imm lv) (& ℓ imm ty) (∪ £ [(ℓ imm lv)]) Δ)] 3838 | 3839 | ;; & ℓ mut lv 3840 | [(where ty (lvtype srs T lv)) 3841 | (can-write-to srs T Λ £ Δ lv) 3842 | (path-unique-for srs T Λ ℓ lv) 3843 | (path-outlives srs T Λ VL ℓ lv) 3844 | (where ty_rv (& ℓ mut ty)) 3845 | -------------------------------------------------- 3846 | (rv-ok srs T Λ VL £ Δ (& ℓ mut lv) ty_rv (∪ £ [(ℓ mut lv)]) Δ)] 3847 | 3848 | ;; struct s ℓs [lv ...] 3849 | [(where [ty_f ...] (field-tys srs s [ℓ ...])) 3850 | (use-lvs-ok srs T Λ £ Δ [lv ...] [ty_a ...] Δ_a) 3851 | (lifetime-in-scope Λ ℓ) ... 3852 | (subtype Λ ty_a ty_f) ... 3853 | -------------------------------------------------- 3854 | (rv-ok srs T Λ VL £ Δ (struct s [ℓ ...] [lv ...]) (struct s [ℓ ...]) £ Δ_a)] 3855 | 3856 | ;; int 3857 | [-------------------------------------------------- 3858 | (rv-ok srs T Λ VL £ Δ number int £ Δ)] 3859 | 3860 | ;; lv + lv 3861 | [(use-lvs-ok srs T Λ £ Δ [lv_1 lv_2] [int int] Δ) 3862 | -------------------------------------------------- 3863 | (rv-ok srs T Λ VL £ Δ (lv_1 + lv_2) int £ Δ)] 3864 | 3865 | ;; (new lv) 3866 | [(use-lv-ok srs T Λ £ Δ lv ty Δ_1) 3867 | -------------------------------------------------- 3868 | (rv-ok srs T Λ VL £ Δ (new lv) (~ ty) £ Δ_1)] 3869 | 3870 | ;; (Some lv) 3871 | [(use-lv-ok srs T Λ £ Δ lv ty Δ_1) 3872 | -------------------------------------------------- 3873 | (rv-ok srs T Λ VL £ Δ (Some lv) (Option ty) £ Δ_1)] 3874 | 3875 | ;; (None ty) 3876 | [;; FIXME: check ty well-formed 3877 | -------------------------------------------------- 3878 | (rv-ok srs T Λ VL £ Δ (None ty) (Option ty) £ Δ)] 3879 | 3880 | ;; (vec ty lv ...) 3881 | [;; check ty well-formed 3882 | (where l (len [lv ...])) 3883 | (use-lvs-ok srs T Λ £ Δ [lv ...] [ty_lv ...] Δ_1) 3884 | (subtype Λ ty_lv ty) ... 3885 | -------------------------------------------------- 3886 | (rv-ok srs T Λ VL £ Δ (vec ty lv ...) (vec ty l) £ Δ_1)] 3887 | 3888 | ;; (vec-len lv ...) 3889 | [(where (& ℓ imm (vec ty olen)) (lvtype srs T lv)) 3890 | (can-read-from srs T Λ £ Δ lv) 3891 | -------------------------------------------------- 3892 | (rv-ok srs T Λ VL £ Δ (vec-len lv) int £ Δ)] 3893 | 3894 | ;; (pack lv ty) 3895 | [(use-lv-ok srs T Λ £ Δ lv ty Δ_1) 3896 | -------------------------------------------------- 3897 | (rv-ok srs T Λ VL £ Δ (pack lv ty) ty £ Δ_1)] 3898 | 3899 | ) 3900 | 3901 | ; Referencing a ~ pointer is a move 3902 | (test-equal 3903 | (judgment-holds 3904 | (rv-ok ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [] owned-B ty £ Δ) 3905 | (ty £ Δ)) 3906 | (term [((~ (struct B [static])) [] [owned-B])])) 3907 | 3908 | ; And illegal if it is borrowed. 3909 | (test-equal 3910 | (judgment-holds 3911 | (rv-ok ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL [(a imm owned-B)] [] owned-B ty £ Δ) 3912 | (ty £ Δ)) 3913 | (term [])) 3914 | 3915 | ; Test a simple, well-typed struct expression: `A { i }` 3916 | (test-equal 3917 | (judgment-holds 3918 | (rv-ok ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [] (struct A [] [i]) ty £ Δ) 3919 | (ty £ Δ)) 3920 | (term [((struct A []) [] [])])) 3921 | 3922 | ; Like previous, but with an invalid type for the field. 3923 | (test-equal 3924 | (judgment-holds 3925 | (rv-ok ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [] (struct A [] [r-imm-B]) ty £ Δ) 3926 | (ty £ Δ)) 3927 | (term [])) 3928 | 3929 | ; Like previous, but with uninitialized i 3930 | (test-equal 3931 | (judgment-holds 3932 | (rv-ok ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [i] (struct A [] [i]) ty £ Δ) 3933 | (ty £ Δ)) 3934 | (term [])) 3935 | 3936 | ; Struct B<'a> { i r-mut-int } -- consumes the r-mut-int 3937 | (test-equal 3938 | (judgment-holds 3939 | (rv-ok ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [] 3940 | (struct B [a] [i r-mut-int]) ty £ Δ) 3941 | (ty £ Δ)) 3942 | (term [( (struct B [a]) [] [r-mut-int] )])) 3943 | 3944 | ; Struct B<'b> { i r-mut-int } -- same as previous 3945 | (test-equal 3946 | (judgment-holds 3947 | (rv-ok ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [] 3948 | (struct B [b] [i r-mut-int]) ty £ Δ) 3949 | (ty £ Δ)) 3950 | (term [( (struct B [b]) [] [r-mut-int] )])) 3951 | 3952 | ; Struct B<'static> { i r-mut-int } -- lifetime error, 'static > 'a 3953 | (test-equal 3954 | (judgment-holds 3955 | (rv-ok ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [] 3956 | (struct B [static] [i r-mut-int]) ty £ Δ) 3957 | (ty £ Δ)) 3958 | (term [])) 3959 | 3960 | ;; test borrowing immutably when already borrowed 3961 | (test-equal 3962 | (judgment-holds 3963 | (rv-ok ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL [(a imm i)] [] 3964 | (& a imm i) ty £ Δ) 3965 | (ty £ Δ)) 3966 | (term [((& a imm int) [(a imm i)] [])])) 3967 | 3968 | ;; test borrowing of deref of owned pointer 3969 | (test-equal 3970 | (judgment-holds 3971 | (rv-ok ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [] 3972 | (& b imm (* owned-B)) ty £ Δ) 3973 | (ty £ Δ)) 3974 | (term [( (& b imm (struct B (static))) [(b imm (* owned-B))] [] )])) 3975 | 3976 | ;; test borrowing of deref of owned pointer when already borrowed 3977 | (test-equal 3978 | (judgment-holds 3979 | (rv-ok ,test-srs ,test-ty-T ,test-ty-Λ ,test-ty-VL [(b imm (* owned-B))] [] 3980 | (& b imm (* owned-B)) ty £ Δ) 3981 | (ty £ Δ)) 3982 | (term [( (& b imm (struct B (static))) [(b imm (* owned-B))] [] )])) 3983 | 3984 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3985 | ;; join-after-match 3986 | ;; 3987 | ;; Given the state after the some and none branch of a match, produces 3988 | ;; the final state in terms of what loans and deinitializations have 3989 | ;; occured. Checks that both states are consistent in that they have 3990 | ;; deinitialized the same paths. 3991 | 3992 | (define-judgment-form 3993 | Patina-typing 3994 | ; initial some none out 3995 | ; +-----+ +---+ +---+ +-+ 3996 | ; | | | | | | | | 3997 | #:mode (join-after-match I I I I I I I I I O O) 3998 | #:contract (join-after-match srs T x T £ Δ T £ Δ £ Δ) 3999 | 4000 | [;; check that the some block drops x if necessary 4001 | (lv-dropped-if-necessary srs T_some Δ_some x) 4002 | 4003 | ;; filter out x from the list of deinitialized paths 4004 | ;; since it is out of scope after match 4005 | (where Δ_some1 (expire-paths [x] Δ_some)) 4006 | 4007 | ;; loans from both sides are still in scope 4008 | (where £_match (∪ £_some £_none)) 4009 | 4010 | ;; anything dropped on either side must be considered dropped afterwards 4011 | (where Δ_match (∪ Δ_some1 Δ_none)) 4012 | 4013 | ;; check that anything dropped afterwards is dropped on *both* sides 4014 | (where [lv_match ...] Δ_match) 4015 | (lv-dropped-if-necessary srs T Δ_some1 lv_match) ... 4016 | (lv-dropped-if-necessary srs T Δ_none lv_match) ... 4017 | -------------------------------------------------- 4018 | (join-after-match srs T x 4019 | T_some £_some Δ_some 4020 | T_none £_none Δ_none 4021 | £_match Δ_match) 4022 | ]) 4023 | 4024 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4025 | ;; st-ok 4026 | 4027 | (define-judgment-form 4028 | Patina-typing 4029 | #:mode (st-ok I I I I I I I O O) 4030 | #:contract (st-ok prog T Λ VL £ Δ st £ Δ) 4031 | 4032 | [(rv-ok srs T Λ VL £ Δ rv ty_rv £_rv Δ_rv) 4033 | (can-init srs T Λ Δ_rv lv) 4034 | (subtype Λ ty_rv (lvtype srs T lv)) 4035 | (where Δ_lv (initialize-lv Δ_rv lv)) 4036 | -------------------------------------------------- 4037 | (st-ok (srs fns) T Λ VL £ Δ (lv = rv) £_rv Δ_lv)] 4038 | 4039 | [(rv-ok srs T Λ VL £ Δ rv ty_rv £_rv Δ_rv) 4040 | (can-write-to srs T Λ £_rv Δ_rv lv) 4041 | (subtype Λ ty_rv (lvtype srs T lv)) 4042 | -------------------------------------------------- 4043 | (st-ok (srs fns) T Λ VL £ Δ (lv := rv) £_rv Δ_rv)] 4044 | 4045 | [(where (~ ty) (lvtype srs T lv)) 4046 | (lv-dropped-if-necessary srs T Δ (* lv)) 4047 | -------------------------------------------------- 4048 | (st-ok (srs fns) T Λ VL £ Δ (free lv) £ (∪ Δ [lv]))] 4049 | 4050 | [(use-lv-ok srs T Λ £ Δ lv ty Δ_1) 4051 | -------------------------------------------------- 4052 | (st-ok (srs fns) T Λ VL £ Δ (drop lv) £ Δ_1)] 4053 | 4054 | [;; lookup the fun def'n 4055 | (where (fun g [ℓ_f ...] [(x_f ty_f) ...] bk_f) (fun-defn fns g)) 4056 | ;; subst from formal lifetime to actual lifetimes 4057 | (where θ [(ℓ_f ℓ_a) ...]) 4058 | ;; evaluate actual arguments provided 4059 | (use-lvs-ok srs T Λ £ Δ lvs_a [ty_a ...] Δ_a) 4060 | ;; check that each argument is a subtype of the expected type 4061 | (subtype Λ ty_a (subst-ty θ ty_f)) ... 4062 | -------------------------------------------------- 4063 | (st-ok (srs fns) T Λ VL £ Δ (call g [ℓ_a ...] lvs_a) £ Δ_a)] 4064 | 4065 | [(use-lv-ok srs T Λ £ Δ lv_discr ty_discr Δ_discr) 4066 | (where (Option ty_x) ty_discr) 4067 | 4068 | (where (block ℓ_some vdecls_some sts_some) bk_some) 4069 | 4070 | ;; check the some block with x in scope 4071 | (where [vdecls ...] T) 4072 | (where [vls ...] VL) 4073 | (where T_some [[(x ty_x)] vdecls ...]) 4074 | (where VL_some [[(x ℓ_some)] vls ...]) 4075 | (bk-ok (srs fns) T_some Λ VL_some £ Δ_discr bk_some £_some Δ_some) 4076 | 4077 | ;; check the none block without x in scope 4078 | (bk-ok (srs fns) T Λ VL £ Δ_discr bk_none £_none Δ_none) 4079 | 4080 | (join-after-match srs T x ;; initial state 4081 | T_some £_some Δ_some ;; state after some 4082 | T £_none Δ_none ;; state after none 4083 | £_match Δ_match) ;; outputs 4084 | -------------------------------------------------- 4085 | (st-ok (srs fns) T Λ VL £ Δ (match 4086 | lv_discr 4087 | (Some by-value x => bk_some) 4088 | (None => bk_none)) 4089 | £_match Δ_match)] 4090 | 4091 | [;; check that we can borrow the Option 4092 | (rv-ok srs T Λ VL £ Δ (& ℓ mq lv_discr) ty_discr £_discr Δ_discr) 4093 | (where (& ℓ mq (Option ty_*x)) ty_discr) 4094 | 4095 | (where (block ℓ_some vdecls_some sts_some) bk_some) 4096 | 4097 | ;; check the some block with x in scope 4098 | (where [vdecls ...] T) 4099 | (where [vls ...] VL) 4100 | (where T_some [[(x (& ℓ mq ty_*x))] vdecls ...]) 4101 | (where VL_some [[(x ℓ_some)] vls ...]) 4102 | (bk-ok (srs fns) T_some Λ VL_some £_discr Δ_discr bk_some £_some Δ_some) 4103 | 4104 | ;; check the none block without x in scope 4105 | (bk-ok (srs fns) T Λ VL £ Δ_discr bk_none £_none Δ_none) 4106 | 4107 | (join-after-match srs T x ;; initial state 4108 | T_some £_some Δ_some ;; state after some 4109 | T £_none Δ_none ;; state after none 4110 | £_match Δ_match) ;; outputs 4111 | -------------------------------------------------- 4112 | (st-ok (srs fns) T Λ VL £ Δ (match 4113 | lv_discr 4114 | (Some (ref ℓ mq) x => bk_some) 4115 | (None => bk_none)) 4116 | £_match Δ_match)] 4117 | 4118 | [(bk-ok prog T Λ VL £ Δ bk £_1 Δ_1) 4119 | -------------------------------------------------- 4120 | (st-ok prog T Λ VL £ Δ bk £_1 Δ_1)] 4121 | 4122 | ) 4123 | 4124 | ;; test initializing an uninitialized i with a constant 4125 | (test-equal 4126 | (judgment-holds 4127 | (st-ok (,test-srs []) ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [i] 4128 | (i = 3) £ Δ) 4129 | (£ Δ)) 4130 | (term [([] [])])) 4131 | 4132 | ;; can only initialize if uninitialized 4133 | (test-equal 4134 | (judgment-holds 4135 | (st-ok (,test-srs []) ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [] 4136 | (i = 3) £ Δ) 4137 | (£ Δ)) 4138 | (term [])) 4139 | 4140 | ;; test overwriting i with a new value 4141 | (test-equal 4142 | (judgment-holds 4143 | (st-ok (,test-srs []) ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [] 4144 | (i := 3) £ Δ) 4145 | (£ Δ)) 4146 | (term [([] [])])) 4147 | 4148 | ;; test overwriting i with a new value of wrong type 4149 | (test-equal 4150 | (judgment-holds 4151 | (st-ok (,test-srs []) ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [] 4152 | (i := (struct A [] [i])) £ Δ) 4153 | (£ Δ)) 4154 | (term [])) 4155 | 4156 | ;; test borrowing i 4157 | #;(test-equal 4158 | (judgment-holds 4159 | (st-ok (,test-srs []) ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [r-mut-int] 4160 | (r-mut-int = (& a mut i)) £ Δ) 4161 | (£ Δ)) 4162 | (term [([(a mut i)] [])])) 4163 | 4164 | ;; test freeing owned-B; since contents do not need drop, should be legal 4165 | (test-equal 4166 | (judgment-holds 4167 | (st-ok (,test-srs []) ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [] 4168 | (free owned-B) £ Δ) 4169 | (£ Δ)) 4170 | (term [([] [owned-B])])) 4171 | 4172 | ;; test dropping owned-B 4173 | (test-equal 4174 | (judgment-holds 4175 | (st-ok (,test-srs []) ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [] 4176 | (drop owned-B) £ Δ) 4177 | (£ Δ)) 4178 | (term [([] [owned-B])])) 4179 | 4180 | ;; test freeing owned-E with and without having dropped contents first 4181 | (test-equal 4182 | (judgment-holds 4183 | (st-ok (,test-srs []) ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [((* owned-E) · 0)] 4184 | (free owned-E) £ Δ) 4185 | (£ Δ)) 4186 | (term [(() [((* owned-E) · 0) owned-E])])) 4187 | (test-equal 4188 | (judgment-holds 4189 | (st-ok (,test-srs []) ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [] 4190 | (free owned-E) £ Δ) 4191 | (£ Δ)) 4192 | (term [])) 4193 | 4194 | ;; test dropping owned-E when fully/partially initialized 4195 | (test-equal 4196 | (judgment-holds 4197 | (st-ok (,test-srs []) ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [] 4198 | (drop owned-E) £ Δ) 4199 | (£ Δ)) 4200 | (term [([] [owned-E])])) 4201 | (test-equal 4202 | (judgment-holds 4203 | (st-ok (,test-srs []) ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [((* owned-E) · 1)] 4204 | (drop owned-E) £ Δ) 4205 | (£ Δ)) 4206 | (term [])) 4207 | 4208 | ;; test calls to a function 4209 | (test-equal 4210 | (judgment-holds 4211 | (st-ok ,test-ty-prog ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [] 4212 | (call drop-owned-B [static] [owned-B]) 4213 | £ Δ) 4214 | (£ Δ)) 4215 | (term [([] [owned-B])])) 4216 | 4217 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4218 | ;; sts-ok 4219 | 4220 | (define-judgment-form 4221 | Patina-typing 4222 | #:mode (sts-ok I I I I I I I O O) 4223 | #:contract (sts-ok prog T Λ VL £ Δ sts £ Δ) 4224 | 4225 | [-------------------------------------------------- 4226 | (sts-ok prog T Λ VL £ Δ [] £ Δ)] 4227 | 4228 | [(st-ok prog T Λ VL £_0 Δ_0 st_1 £_1 Δ_1) 4229 | (sts-ok prog T Λ VL £_1 Δ_1 [st_2 ...] £_2 Δ_2) 4230 | -------------------------------------------------- 4231 | (sts-ok prog T Λ VL £_0 Δ_0 [st_1 st_2 ...] £_2 Δ_2)] 4232 | ) 4233 | 4234 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4235 | ;; bk-ok 4236 | 4237 | (define-judgment-form 4238 | Patina-typing 4239 | #:mode (bk-ok I I I I I I I O O) 4240 | #:contract (bk-ok prog T Λ VL £ Δ bk £ Δ) 4241 | 4242 | [(where (block ℓ_b [(x_b ty_b) ...] sts_b) bk) 4243 | 4244 | ;; variables types for new block: 4245 | (where [vdecls ...] T) 4246 | (where T_b [[(x_b ty_b) ...] vdecls ...]) 4247 | 4248 | ;; add block lifetime ℓ_b, make it a sublifetime of all others in scope: 4249 | (where Λ_b (∪ Λ [(ℓ_b (in-scope-lifetimes Λ))])) 4250 | 4251 | ;; lifetime of block variables is always ℓ_b: 4252 | (where [vls ...] VL) 4253 | (where VL_b [[(x_b ℓ_b) ...] vls ...]) 4254 | 4255 | ;; all block variables initially uninitialized: 4256 | (where Δ_b (∪ Δ [x_b ...])) 4257 | 4258 | (sts-ok (srs fns) T_b Λ_b VL_b £ Δ_b sts_b £_sts Δ_sts) 4259 | 4260 | ;; all local variables must be dropped by user (if needed) 4261 | (lv-dropped-if-necessary srs T_b Δ_sts x_b) ... 4262 | 4263 | ;; remove loans and paths that are specific to this block 4264 | (where Δ_bk (expire-paths [x_b ...] Δ_sts)) 4265 | (where £_bk (expire-loans ℓ_b £_sts)) 4266 | -------------------------------------------------- 4267 | (bk-ok (srs fns) T Λ VL £ Δ bk £_bk Δ_bk)] 4268 | 4269 | ) 4270 | 4271 | (test-equal 4272 | (judgment-holds 4273 | (bk-ok [,test-srs []] [] [] [] [] [] 4274 | (block l0 4275 | [(r int)] 4276 | [(r = 3) 4277 | (r := 4)]) 4278 | £ Δ) 4279 | (£ Δ)) 4280 | (term [([] [])])) 4281 | 4282 | (test-equal 4283 | (judgment-holds 4284 | (bk-ok [,test-srs []] [] [] [] [] [] 4285 | (block l0 4286 | [(r int) 4287 | (s int)] 4288 | [(r = 3) 4289 | (r := s)]) 4290 | £ Δ) 4291 | (£ Δ)) 4292 | (term [])) 4293 | 4294 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4295 | ;; Test for statements that involve blocks 4296 | 4297 | ; test match where one side drops more than the other 4298 | (test-equal 4299 | (judgment-holds 4300 | (st-ok ,test-ty-prog ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [] 4301 | (match opt-int 4302 | (Some by-value x => (block l1 4303 | [] 4304 | [(drop owned-B)])) 4305 | (None => (block l2 4306 | [] 4307 | []))) 4308 | £ Δ) 4309 | (£ Δ)) 4310 | (term [])) 4311 | 4312 | ;; test match where both sides drop the same 4313 | (test-equal 4314 | (judgment-holds 4315 | (st-ok ,test-ty-prog ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [] 4316 | (match opt-int 4317 | (Some by-value x => (block l1 4318 | [(y int)] 4319 | [(y = x) 4320 | (drop owned-B)])) 4321 | (None => (block l2 4322 | [] 4323 | [(drop owned-B)]))) 4324 | £ Δ) 4325 | (£ Δ)) 4326 | (term [([] [owned-B])])) 4327 | 4328 | ;; test match with a by-ref check 4329 | #;(test-equal 4330 | (judgment-holds 4331 | (st-ok ,test-ty-prog ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [] 4332 | (match opt-int 4333 | (Some (ref b imm) x => (block l1 4334 | [(y int)] 4335 | [(y = (* x))])) 4336 | (None => (block l2 4337 | [] 4338 | []))) 4339 | £ Δ) 4340 | (£ Δ)) 4341 | (term [([(b imm opt-int)] 4342 | [])])) 4343 | 4344 | ;; test match with a by-ref check and a type error 4345 | #;(test-equal 4346 | (judgment-holds 4347 | (st-ok ,test-ty-prog ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [] 4348 | (match opt-int 4349 | (Some (ref b imm) x => (block l1 4350 | [(y int)] 4351 | [(y = x)])) ;; should be (* x) 4352 | (None => (block l2 4353 | [] 4354 | []))) 4355 | £ Δ) 4356 | (£ Δ)) 4357 | (term [])) 4358 | 4359 | ;; test recursive match with a by-ref mut check 4360 | #;(test-equal 4361 | (judgment-holds 4362 | (st-ok ,test-ty-prog ,test-ty-T ,test-ty-Λ ,test-ty-VL [] [] 4363 | (match opt-int 4364 | (Some (ref b mut) x => (block l1 4365 | [] 4366 | [(match opt-int 4367 | (Some (ref b mut) y => (block l2 [] [])) 4368 | (None => (block l2 [] [])))])) 4369 | (None => (block l2 [] []))) 4370 | £ Δ) 4371 | (£ Δ)) 4372 | (term [])) 4373 | 4374 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4375 | ;; fn-ok 4376 | 4377 | (define-judgment-form 4378 | Patina-typing 4379 | #:mode (fn-ok I I ) 4380 | #:contract (fn-ok prog fn) 4381 | 4382 | [;; check the block with an initial environment that assumes 4383 | ;; parameters are initialized and not borrowed 4384 | (where (block ℓ_bk vdecls_bk sts_bk) bk) 4385 | (where T [[(x ty) ...]]) 4386 | (where Λ [(ℓ []) ...]) ;; FIXME - establish initial relations between lifetimes 4387 | (where VL [[(x ℓ_bk)] ...]) 4388 | (bk-ok (srs fns) T Λ VL [] [] bk £ Δ) 4389 | 4390 | ;; all parameters must be dropped 4391 | (lv-dropped-if-necessary srs T Δ x) ... 4392 | -------------------------------------------------- 4393 | (fn-ok (srs fns) (fun g [ℓ ...] [(x ty) ...] bk))] 4394 | ) 4395 | 4396 | ;; borrow same value twice immutably 4397 | (test-equal 4398 | (judgment-holds (fn-ok 4399 | ,test-ty-prog 4400 | (fun test-fn [l0] [(x (~ (struct B (l0))))] 4401 | (block l1 4402 | [] 4403 | [(block l2 4404 | [(y (& l2 imm (struct B (l0)))) 4405 | (z (& l2 imm (struct B (l0)))) 4406 | ] 4407 | [(y = (& l2 imm (* x))) 4408 | (z = (& l2 imm (* x))) 4409 | ]) 4410 | (drop x)])))) 4411 | #t) 4412 | 4413 | (test-equal 4414 | (judgment-holds (fn-ok 4415 | ,test-ty-prog 4416 | (fun drop-owned-B [l0] [(x (~ (struct B (l0))))] 4417 | (block l1 4418 | [] 4419 | [(drop x)])))) 4420 | #t) 4421 | 4422 | ;; can't type check if I forget to (drop x) 4423 | (test-equal 4424 | (judgment-holds (fn-ok 4425 | ,test-ty-prog 4426 | (fun drop-owned-B [l0] [(x (~ (struct B (l0))))] 4427 | (block l1 4428 | [] 4429 | [])))) 4430 | #f) 4431 | 4432 | ;; but it's ok if we don't own `x` 4433 | (test-equal 4434 | (judgment-holds (fn-ok 4435 | ,test-ty-prog 4436 | (fun drop-owned-B [l0] [(x (& l0 imm (struct B (l0))))] 4437 | (block l1 4438 | [] 4439 | [])))) 4440 | #t) 4441 | 4442 | ;; test call to drop-owned-B where data is borrowed 4443 | (test-equal 4444 | (judgment-holds (fn-ok 4445 | ,test-ty-prog 4446 | (fun test-fn [l0] [(x (~ (struct B (l0))))] 4447 | (block l1 4448 | [(y (& l1 imm (struct B (l0))))] 4449 | [(y = (& l1 imm (* x))) 4450 | (call drop-owned-B [l0] [x]) 4451 | ])))) 4452 | #f) 4453 | 4454 | ;; confine borrow to a subblock 4455 | (test-equal 4456 | (judgment-holds (fn-ok 4457 | ,test-ty-prog 4458 | (fun test-fn [l0] [(x (~ (struct B (l0))))] 4459 | (block l1 4460 | [] 4461 | [(block l2 4462 | [(y (& l2 imm (struct B (l0))))] 4463 | [(y = (& l2 imm (* x))) 4464 | ]) 4465 | (call drop-owned-B [l0] [x]) 4466 | ])))) 4467 | #t) 4468 | 4469 | ;; take and a linear subfield then try to drop 4470 | (test-equal 4471 | (judgment-holds (fn-ok 4472 | ,test-ty-prog 4473 | (fun test-fn [l0] [(x (~ (struct B (l0))))] 4474 | (block l1 4475 | [(y (& l0 mut int))] 4476 | [(y = ((* x) · 1)) 4477 | (call drop-owned-B [l0] [x]) 4478 | ])))) 4479 | #f) 4480 | 4481 | ;; take and a linear subfield, replace it, then drop 4482 | (test-equal 4483 | (judgment-holds (fn-ok 4484 | ,test-ty-prog 4485 | (fun test-fn [l0] [(x (~ (struct B (l0))))] 4486 | (block l1 4487 | [(y (& l0 mut int))] 4488 | [(y = ((* x) · 1)) 4489 | (((* x) · 1) = y) 4490 | (call drop-owned-B [l0] [x]) 4491 | ])))) 4492 | #t) 4493 | 4494 | (test-equal 4495 | (judgment-holds (fn-ok ,sum-prog 4496 | ,sum-main)) 4497 | #t) 4498 | 4499 | (test-equal 4500 | (judgment-holds (fn-ok ,sum-prog 4501 | (fun sum-list [a b] [(inp (& a imm (struct List []))) 4502 | (outp (& b mut int))] 4503 | (block l0 4504 | [(r int)] 4505 | [(r = ((* inp) · 0)) 4506 | (match ((* inp) · 1) 4507 | (Some (ref l0 imm) next1 => 4508 | (block l1 4509 | [(next2 (& l1 imm (struct List []))) 4510 | (b int)] 4511 | [(next2 = (& l1 imm (* (* next1)))) 4512 | (b = 0) 4513 | (block l3 4514 | [(c (& l3 mut int))] 4515 | [(c = (& l3 mut b)) 4516 | (call sum-list [l1 l3] [next2 c])]) 4517 | ((* outp) := (r + b))])) 4518 | (None => 4519 | (block l1 4520 | [] 4521 | [((* outp) := r)])))])))) 4522 | #t) 4523 | 4524 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4525 | ;; prog-ok 4526 | 4527 | (define-judgment-form 4528 | Patina-typing 4529 | #:mode (prog-ok I ) 4530 | #:contract (prog-ok prog) 4531 | 4532 | [(where (srs [fn ...]) prog) 4533 | (fn-ok prog fn) ... 4534 | -------------------------------------------------- 4535 | (prog-ok prog)] 4536 | 4537 | ) 4538 | --------------------------------------------------------------------------------