├── .gitignore ├── .travis.yml ├── LVish ├── LVish.rkt ├── Makefile ├── README.md ├── nat.rkt ├── natpair-ivars.rkt └── test-helpers.rkt ├── README.md ├── lambdaLVar ├── Makefile ├── README.md ├── lambdaLVar.rkt ├── nat.rkt ├── natpair-ivars.rkt ├── natpair.rkt └── test-helpers.rkt └── lambdaLVish ├── Makefile ├── README.md ├── lambdaLVish.rkt ├── nat.rkt └── test-helpers.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | */compiled/* 2 | *~ 3 | *# 4 | .#* 5 | *.bak -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | # Optional: To use Travis CI's newer container infrastucture, 4 | # un-comment the following line. (Also be sure RACKET_DIR is set to 5 | # somewhere like ~/racket that doesn't require sudo.) 6 | # 7 | # sudo: false 8 | 9 | env: 10 | global: 11 | # Supply a global RACKET_DIR environment variable. This is where 12 | # Racket will be installed. A good idea is to use ~/racket because 13 | # that doesn't require sudo to install and is therefore compatible 14 | # with Travis CI's newer container infrastructure. 15 | - RACKET_DIR=~/racket 16 | matrix: 17 | # Supply at least one RACKET_VERSION environment variable. This is 18 | # used by the install-racket.sh script (run at before_install, 19 | # below) to select the version of Racket to download and install. 20 | # 21 | # Supply more than one RACKET_VERSION (as in the example below) to 22 | # create a Travis-CI build matrix to test against multiple Racket 23 | # versions. 24 | - RACKET_VERSION=5.3.4 25 | - RACKET_VERSION=5.3.5 26 | - RACKET_VERSION=5.92 27 | - RACKET_VERSION=6.0 28 | - RACKET_VERSION=6.1 29 | - RACKET_VERSION=6.1.1 30 | - RACKET_VERSION=HEAD 31 | 32 | # You may want to test against certain versions of Racket, without 33 | # having them count against the overall success/failure. 34 | matrix: 35 | allow_failures: 36 | - env: RACKET_VERSION=HEAD 37 | # Fast finish: Overall build result is determined as soon as any of 38 | # its rows have failed, or, all of its rows that aren't allowed to 39 | # fail have succeeded. 40 | fast_finish: true 41 | 42 | 43 | before_install: 44 | - git clone https://github.com/greghendershott/travis-racket.git 45 | - cat travis-racket/install-racket.sh | bash # pipe to bash not sh! 46 | - export PATH="${RACKET_DIR}/bin:${PATH}" #install-racket.sh can't set for us 47 | 48 | install: 49 | 50 | before_script: 51 | 52 | # Here supply steps such as raco make, raco test, etc. 53 | # 54 | # Tip: Use `raco pkg install --deps search-auto ` to install any 55 | # required packages without getting stuck on a confirmation prompt. 56 | script: 57 | - cd lambdaLVar && travis_wait make 58 | - cd .. 59 | - cd LVish && travis_wait make all 60 | - cd .. 61 | - cd lambdaLVish && travis_wait make all 62 | 63 | # NOTE: If your repo is a Racket package with an info.rkt that 64 | # includes some `deps`, the following is more elegant: 65 | # 66 | # script: 67 | # - cd .. # Travis did a cd into the dir. Back up, for the next: 68 | # - raco pkg install --deps search-auto --link 69 | # - raco test -x -p 70 | 71 | after_script: 72 | -------------------------------------------------------------------------------- /LVish/LVish.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;; A Redex model of the LVish language. 3 | 4 | (provide define-LVish-language) 5 | 6 | ;; define-LVish-language takes the following arguments: 7 | ;; 8 | ;; * a name, e.g. LVish-nat, which becomes the `lang-name` passed to 9 | ;; Redex's `define-language` form. 10 | ;; 11 | ;; * a "downset" operation, a Racket-level procedure that takes a 12 | ;; lattice element and returns the (finite) set of all lattice 13 | ;; elements that are below that element. 14 | ;; 15 | ;; * a lub operation, a Racket-level procedure that takes two 16 | ;; lattice elements and returns a lattice element. 17 | ;; 18 | ;; * some number of lattice elements represented as Redex patterns, 19 | ;; not including top and bottom elements, since we add those 20 | ;; automatically. (Therefore, if we wanted a lattice consisting 21 | ;; only of Top and Bot, we wouldn't pass any lattice elements to 22 | ;; define-LVish-language.) 23 | 24 | (define-syntax-rule (define-LVish-language 25 | name 26 | downset-op 27 | lub-op 28 | lattice-elements ...) 29 | (begin 30 | (require redex/reduction-semantics) 31 | (require srfi/1) 32 | 33 | ;; rr is the reduction relation; most of the other operations here 34 | ;; are exported for testing purposes only. 35 | (provide rr 36 | exists-p 37 | lub 38 | lub-p 39 | leq 40 | extend-H 41 | contains-all-Q 42 | first-unhandled-d-in-Q 43 | store-dom 44 | lookup-val 45 | lookup-status 46 | lookup-state 47 | update-state 48 | incomp 49 | store-dom-diff 50 | top? 51 | subst) 52 | 53 | ;; A template for the generated Redex language definition. 54 | (define-language name 55 | 56 | ;; ============================================================= 57 | ;; LVish syntax 58 | 59 | ;; Configurations on which the reduction relation operates. 60 | (Config (S e) 61 | Error) 62 | 63 | ;; Expressions. 64 | (e x 65 | v 66 | (e e) 67 | (get e e) 68 | (put e e) 69 | new 70 | (freeze e) 71 | (freeze e after e with e) 72 | 73 | ;; An intermediate language form -- this doesn't show up in 74 | ;; user programs. 75 | (freeze l after Q with ((callback (lambda (x) e)) 76 | (running (e (... ...))) 77 | (handled H))) 78 | 79 | ;; Derived forms; these immediately desugar to application 80 | ;; and lambda. 81 | (let ((x e) (x e) (... ...)) e) 82 | (let par ((x e) (x e) (x e) (... ...)) e)) 83 | 84 | ;; Variables. 85 | (x variable-not-otherwise-mentioned) 86 | 87 | ;; Values. 88 | (v () ;; unit value 89 | StoreVal ;; return value of `freeze ... after ... with ...` 90 | ;; (we use StoreVal instead of d here because it 91 | ;; will never be Top) 92 | 93 | (StoreVal status) ;; return value of `get` (we use (StoreVal 94 | ;; status) instead of p here because it 95 | ;; will never be Top-p) 96 | 97 | l ;; locations (pointers to LVars in the store) 98 | P ;; threshold sets 99 | Q ;; event sets 100 | (lambda (x) e)) 101 | 102 | ;; Lattice elements, representing the "value" part of the state 103 | ;; of an LVar (the other part being "status"). We assume Top 104 | ;; and Bot lattice elements in addition to the user-specified 105 | ;; set of lattice elements. A StoreVal can be any element of 106 | ;; the lattice except Top. 107 | 108 | ;; N.B. In the LaTeX grammar, we leave out these next two rules. 109 | ;; That's because in that grammar, the user-provided lattice 110 | ;; already comes with Bot and Top, and d is any element of that 111 | ;; user-provided lattice. We just use d in the LaTeX grammar in 112 | ;; every place we use StoreVal here. 113 | (d StoreVal Top) 114 | (StoreVal lattice-elements ... Bot) 115 | 116 | ;; Handled element sets. A handled element set is a finite, 117 | ;; potentially empty set of lattice elements excluding Top. 118 | ;; Used to keep track of handled lattice elements in `freeze 119 | ;; ... after`. 120 | (H (d (... ...))) 121 | 122 | ;; Stores. A store is either a finite set of LVars (that is, a 123 | ;; finite partial mapping from locations l to pairs of StoreVals 124 | ;; and status flags) or a distinguished value TopS. 125 | (S (LVar (... ...)) TopS) 126 | (LVar (l (StoreVal status))) 127 | (status #t #f) 128 | (l variable-not-otherwise-mentioned) 129 | 130 | ;; Threshold sets. A threshold set is the set we pass to a 131 | ;; `get` expression that specifies a non-empty, pairwise 132 | ;; incompatible subset of the states of the LVar being queried. 133 | 134 | ;; N.B. Threshold sets are potentially infinite, but we don't 135 | ;; have a good way to express infinite threshold sets in Redex. 136 | ;; In the paper, we sometimes define infinite threshold sets 137 | ;; using predicates. 138 | (P (p p (... ...))) 139 | 140 | ;; Event sets. In `freeze l after Q with (lambda (x) e)`, Q is 141 | ;; the event set. It's a set of lattice elements on which we 142 | ;; want (lambda (x) e) to be invoked when l reaches them. It 143 | ;; doesn't have to be pairwise incompatible in the way that a 144 | ;; threshold set does; It's just a set of lattice states. 145 | 146 | ;; N.B. Event sets are potentially infinite, but we don't have a 147 | ;; good way to express infinite event sets in Redex. 148 | (Q (d d (... ...))) 149 | 150 | ;; States. 151 | (p (StoreVal status) Top-p) 152 | 153 | ;; Like P, but potentially empty. Used in the type of the 154 | ;; exists-p metafunction. 155 | (P/null P ()) 156 | 157 | ;; Codomains for a couple of metafunctions. 158 | (Maybe-p p #f) 159 | (Maybe-d d #f) 160 | 161 | ;; Evaluation contexts. 162 | (E hole 163 | (E e) 164 | (e E) 165 | (get E e) 166 | (get e E) 167 | (put E e) 168 | (put e E) 169 | (freeze E) 170 | (freeze E after e with e) 171 | (freeze e after E with e) 172 | (freeze e after e with E) 173 | (freeze v after v with ((callback v) 174 | (running (e (... ...) E e (... ...))) 175 | (handled H))) 176 | 177 | ;; Special context for desugaring only. 178 | (let par ((x e) (... ...) (x E) (x e) (... ...)) e))) 179 | 180 | ;; ============================================================= 181 | ;; LVish reduction relation 182 | 183 | (define rr 184 | (reduction-relation 185 | name 186 | 187 | ;; Beta-reduction. 188 | (--> (S (in-hole E ((lambda (x) e) v))) 189 | (S (in-hole E (subst x v e))) 190 | "E-Beta") 191 | 192 | ;; Allocation of new LVars. 193 | (--> (S (in-hole E new)) 194 | ((update-state S l (Bot #f)) (in-hole E l)) 195 | (where l (variable-not-in-store S)) 196 | "E-New") 197 | 198 | ;; Least-upper-bound writes to LVars. 199 | 200 | ;; If an LVar is frozen, putting a value that is less than or 201 | ;; equal to the current value has no effect... 202 | (--> (S (in-hole E (put l d_2))) 203 | ((update-state S l p_2) (in-hole E ())) 204 | (where p_1 (lookup-state S l)) 205 | (where p_2 (lub-p p_1 (d_2 #f))) 206 | (where (StoreVal status) p_2) 207 | "E-Put") 208 | 209 | ;; ...but putting a value that is greater than the current 210 | ;; value, or has no order with the current value, raises an 211 | ;; error. 212 | (--> (S (in-hole E (put l d_2))) 213 | Error 214 | (where p_1 (lookup-state S l)) 215 | (where Top-p (lub-p p_1 (d_2 #f))) 216 | "E-Put-Err") 217 | 218 | ;; Threshold reads from LVars. 219 | (--> (S (in-hole E (get l P))) 220 | (S (in-hole E p_2)) 221 | (where p_1 (lookup-state S l)) 222 | (where #t (incomp P)) 223 | (where p_2 (exists-p p_1 P)) 224 | "E-Get") 225 | 226 | ;; Creation of the intermediate language forms that 227 | ;; E-Spawn-Handler and E-Finalize-Freeze need to operate on. 228 | (--> (S (in-hole E (freeze l after Q with (lambda (x) e)))) 229 | (S (in-hole E (freeze l after Q with ((callback (lambda (x) e)) 230 | (running ()) 231 | (handled ()))))) 232 | "E-Freeze-Init") 233 | 234 | ;; Launching of handlers. This rule can fire potentially many 235 | ;; times for a given `freeze ... after` expression. It fires 236 | ;; once for each lattice element d_2 that is: 237 | ;; 238 | ;; * <= the current value d_1 of l. 239 | ;; * not a member of the current handled set H. 240 | ;; * a member of the event set Q. 241 | ;; 242 | ;; For each such d_2, it launches a handler in the `running` 243 | ;; set and adds d_2 to the `handled` set. 244 | (--> (S (in-hole E (freeze l after Q with ((callback (lambda (x) e_0)) 245 | (running (e (... ...))) 246 | (handled H))))) 247 | (S (in-hole E (freeze l after Q with ((callback (lambda (x) e_0)) 248 | (running ((subst x d_2 e_0) e (... ...))) 249 | (handled H_2))))) 250 | (where d_1 (lookup-val S l)) 251 | (where d_2 (first-unhandled-d-in-Q d_1 H Q)) 252 | (where H_2 (extend-H H d_2)) 253 | "E-Spawn-Handler") 254 | 255 | ;; Last step in the evaluation of `freeze ... after`. When all 256 | ;; expressions in the `running` set have reached values and all 257 | ;; lattice elements at or below l's current value have been 258 | ;; handled, this rule freezes and returns that value. 259 | 260 | ;; N.B.: If we haven't done any writes to an LVar yet (i.e., 261 | ;; its value is Bot), then the callback must still run once, to 262 | ;; add Bot to the `handled` set. Only then will the premises 263 | ;; of E-Freeze-Final be satisfied, allowing it to run. 264 | (--> (S (in-hole E (freeze l after Q with ((callback (lambda (x) e)) 265 | (running (v (... ...))) 266 | (handled H))))) 267 | ((freeze-helper S l) (in-hole E d_1)) 268 | (where d_1 (lookup-val S l)) 269 | (where #t (contains-all-Q d_1 H Q)) 270 | "E-Freeze-Final") 271 | 272 | ;; Special case of freeze-after, where there are no handlers to 273 | ;; run. 274 | (--> (S (in-hole E (freeze l))) 275 | ((freeze-helper S l) (in-hole E d_1)) 276 | (where d_1 (lookup-val S l)) 277 | "E-Freeze-Simple") 278 | 279 | ;; ============================================================ 280 | 281 | ;; Desugaring of `let`. 282 | (--> (S (in-hole E (let ((x_1 e_1)) e_2))) 283 | (S (in-hole E ((lambda (x_1) e_2) e_1))) 284 | "Desugaring of let") 285 | 286 | ;; Desugaring of `let par`. 287 | (--> (S (in-hole E (let par ((x_1 e_1) (x_2 e_2)) e_3))) 288 | (S (in-hole E (((lambda (x_1) (lambda (x_2) e_3)) e_1) e_2))) 289 | "Desugaring of let par") 290 | 291 | ;; Desugaring of multi-binding `let` 292 | (--> (S (in-hole E (let ((x_1 e_1) 293 | (x_2 e_2) 294 | (x_3 e_3) (... ...)) 295 | e_4))) 296 | (S (in-hole E (let ((x_1 e_1)) 297 | (let ((x_2 e_2)) 298 | (let ((x_3 e_3) (... ...)) 299 | e_4))))) 300 | "Desugaring of multi-binding `let`") 301 | 302 | ;; Desugaring of multi-binding `let par` 303 | (--> (S (in-hole E (let par ((x_1 e_1) 304 | (x_2 e_2) 305 | (x_3 e_3) 306 | (x_4 x_4) (... ...)) 307 | e_5))) 308 | (S (in-hole E (let par ((x_1 e_1) 309 | (x (let par ((x_2 e_2) 310 | (x_3 e_3) 311 | (x_4 x_4) (... ...)) 312 | e_5))) 313 | x))) 314 | (fresh x) 315 | "Desugaring of multi-binding `let par`"))) 316 | 317 | ;; ============================================================= 318 | ;; LVish metafunctions 319 | 320 | ;; Some convenience functions: LVar accessors and constructor. 321 | 322 | (define-metafunction name 323 | lvloc : LVar -> l 324 | [(lvloc LVar) ,(first (term LVar))]) 325 | 326 | (define-metafunction name 327 | lvstate : LVar -> p 328 | [(lvstate LVar) ,(second (term LVar))]) 329 | 330 | (define-metafunction name 331 | lvvalue : LVar -> StoreVal 332 | [(lvvalue LVar) ,(first (second (term LVar)))]) 333 | 334 | (define-metafunction name 335 | lvstatus : LVar -> status 336 | [(lvstatus LVar) ,(second (second (term LVar)))]) 337 | 338 | (define-metafunction name 339 | build-lv : l StoreVal status -> LVar 340 | [(build-lv l StoreVal status) 341 | (l (StoreVal status))]) 342 | 343 | ;; Returns a store that is the same as the original store S, but 344 | ;; with S(l) modified to be frozen. 345 | (define-metafunction name 346 | freeze-helper : S l -> S 347 | [(freeze-helper S l) 348 | ,(let ([lv (assq (term l) (term S))] 349 | [update (lambda (lv) 350 | (if (equal? (term (lvloc ,lv)) (term l)) 351 | (term (build-lv (lvloc ,lv) (lvvalue ,lv) #t)) 352 | lv))]) 353 | (if lv 354 | (term ,(map update (term S))) 355 | (error "freeze-helper: lookup failed")))]) 356 | 357 | ;; Takes a handled set H and returns a new one with d added. 358 | ;; Assumes that d is not already a member of H. 359 | (define-metafunction name 360 | extend-H : H d -> H 361 | [(extend-H H d) ,(cons (term d) (term H))]) 362 | 363 | ;; Checks to see that, for all lattice elements that are less than 364 | ;; or equal to d and a member of Q, they're a member of H. In 365 | ;; other words, (contains-all-Q d H Q) returns true exactly when 366 | ;; the set (intersection (downset-op d) Q) is a subset of H. 367 | (define-metafunction name 368 | contains-all-Q : d H Q -> boolean 369 | [(contains-all-Q d H Q) 370 | ,(lset<= equal? 371 | (lset-intersection equal? 372 | (downset-op (term d)) 373 | (term Q)) 374 | (term H))]) 375 | 376 | ;; A helper for the E-Spawn-Handler reduction rule. Takes a 377 | ;; lattice element d_1, a finite set H of elements, and a finite 378 | ;; set Q of elements of interest. returns the first element that 379 | ;; is <= d_1 in the lattice that is *not* a member of H and *is* a 380 | ;; member of Q, if such an element exists; returns #f otherwise. 381 | (define-metafunction name 382 | first-unhandled-d-in-Q : d H Q -> Maybe-d 383 | [(first-unhandled-d-in-Q d_1 H Q) 384 | ,(let ([ls (filter (lambda (x) 385 | (and (not (member x (term H))) 386 | (member x (term Q)))) 387 | (downset-op (term d_1)))]) 388 | (if (null? ls) 389 | #f 390 | (term ,(first ls))))]) 391 | 392 | (define-metafunction name 393 | store-dom : S -> (l (... ...)) 394 | [(store-dom ()) ()] 395 | [(store-dom ((l_1 (StoreVal_1 status_1)) 396 | (l_2 (StoreVal_2 status_2)) (... ...))) 397 | ,(cons (term l_1) 398 | (term (store-dom ((l_2 (StoreVal_2 status_2)) (... ...)))))]) 399 | 400 | ;; Return a list of locations in dom(S_1) that are not in dom(S_2). 401 | (define-metafunction name 402 | store-dom-diff : S S -> (l (... ...)) 403 | [(store-dom-diff S_1 S_2) 404 | ,(lset-difference equal? 405 | (term (store-dom S_1)) 406 | (term (store-dom S_2)))]) 407 | 408 | (define-metafunction name 409 | top? : d -> boolean 410 | [(top? Top) #t] 411 | [(top? d) #f]) 412 | 413 | ;; N.B.: The lub of d_1 and d_2 is the element d_3 such that: 414 | ;; -- (leq d_1 d_3) 415 | ;; -- (leq d_2 d_3) 416 | ;; -- for all d_4 s.t. (leq d_1 d_4) and (leq d_2 d_4), (leq d_3 d_4). 417 | ;; 418 | ;; But we can't get Redex to compute that, so instead, we ask the user 419 | ;; to provide lub, then compute leq in terms of lub. 420 | ;; 421 | ;; Intended to be extended by a user-provided operation. 422 | (define-metafunction name 423 | lub : d d -> d 424 | [(lub Bot d_2) d_2] 425 | [(lub d_1 Bot) d_1] 426 | [(lub Top d_2) Top] 427 | [(lub d_1 Top) Top] 428 | [(lub d_1 d_2) ,(lub-op (term d_1) (term d_2))]) 429 | 430 | ;; Defined in terms of lub. 431 | (define-metafunction name 432 | leq : d d -> boolean 433 | [(leq Bot d_2) #t] 434 | [(leq d_1 Bot) #f] 435 | [(leq Top d_2) #f] 436 | [(leq d_1 Top) #t] 437 | 438 | ;; If d_1 = d_2, then (leq d_1 d_2). 439 | [(leq d_1 d_2) #t 440 | (side-condition (equal? (term d_1) (term d_2)))] 441 | 442 | ;; If (lub d_1 d_2) = d_2, then (leq d_1 d_2). 443 | [(leq d_1 d_2) #t 444 | (side-condition (equal? (term (lub d_1 d_2)) (term d_2)))] 445 | 446 | ;; If (lub d_1 d_2) = d_1, then (not (leq d_1 d_2)). (This assumes 447 | ;; that d_1 != d_2, but we've already covered the case where they're 448 | ;; equal.) 449 | [(leq d_1 d_2) #f 450 | (side-condition (equal? (term (lub d_1 d_2)) (term d_1)))] 451 | 452 | ;; The only case left: (lub d_1 d_2) = d_3, where d_3 is greater 453 | ;; than both d_1 and d_2. In this case, (not (leq d_1 d_2)). 454 | [(leq d_1 d_2) #f]) 455 | 456 | ;; The lub operation, but extended to handle status bits: 457 | (define-metafunction name 458 | lub-p : p p -> p 459 | 460 | ;; Neither frozen: 461 | [(lub-p (d_1 #f) (d_2 #f)) 462 | ,(let ([d (term (lub d_1 d_2))]) 463 | (if (equal? d (term Top)) 464 | (term Top-p) 465 | `(,d #f)))] 466 | 467 | ;; Both frozen: 468 | [(lub-p (d_1 #t) (d_2 #t)) 469 | ,(if (equal? (term d_1) (term d_2)) 470 | (term (d_1 #t)) 471 | (term Top-p))] 472 | 473 | ;; d_1 unfrozen, d_2 frozen: 474 | [(lub-p (d_1 #f) (d_2 #t)) 475 | ,(if (term (leq d_1 d_2)) 476 | (term (d_2 #t)) 477 | (term Top-p))] 478 | 479 | ;; d_1 frozen, d_2 unfrozen: 480 | [(lub-p (d_1 #t) (d_2 #f)) 481 | ,(if (term (leq d_2 d_1)) 482 | (term (d_1 #t)) 483 | (term Top-p))]) 484 | 485 | ;; The leq operation, but extended to handle status bits: 486 | (define-metafunction name 487 | leq-p : p p -> boolean 488 | 489 | ;; Neither frozen: 490 | [(leq-p (d_1 #f) (d_2 #f)) 491 | (leq d_1 d_2)] 492 | 493 | ;; Both frozen: 494 | [(leq-p (d_1 #t) (d_2 #t)) 495 | ,(equal? (term d_1) (term d_2))] 496 | 497 | ;; d_1 unfrozen, d_2 frozen: 498 | [(leq-p (d_1 #f) (d_2 #t)) 499 | (leq d_1 d_2)] 500 | 501 | ;; d_1 frozen, d_2 unfrozen: 502 | [(leq-p (d_1 #t) (d_2 #f)) 503 | ,(equal? (term d_1) (term Top))]) 504 | 505 | (define-metafunction name 506 | variable-not-in-store : S -> l 507 | [(variable-not-in-store S) 508 | ,(variable-not-in (term S) (term l))]) 509 | 510 | (define-metafunction name 511 | lookup-val : S l -> StoreVal 512 | [(lookup-val S l) ,(let ([lv (assq (term l) (term S))]) 513 | (if lv 514 | (term (lvvalue ,lv)) 515 | (error "lookup-val: lookup failed")))]) 516 | 517 | (define-metafunction name 518 | lookup-status : S l -> status 519 | [(lookup-status S l) ,(let ([lv (assq (term l) (term S))]) 520 | (if lv 521 | (term (lvstatus ,lv)) 522 | (error "lookup-status: lookup failed")))]) 523 | 524 | (define-metafunction name 525 | lookup-state : S l -> p 526 | [(lookup-state S l) ,(let ([lv (assq (term l) (term S))]) 527 | (if lv 528 | (term (lvstate ,lv)) 529 | (error "lookup-state: lookup failed")))]) 530 | 531 | ;; Actually handles both updates and extensions. 532 | (define-metafunction name 533 | update-state : S l p -> S 534 | [(update-state () l p) ((l p))] 535 | 536 | [(update-state ((l_2 p_2) 537 | (l_3 p_3) (... ...)) l_1 p_1 ) 538 | ,(if (equal? (term l_1) (term l_2)) 539 | ;; The side conditions on E-Put should ensure that the 540 | ;; call to update-state only happens when the lub of the 541 | ;; old and new values is non-Top-p. 542 | (cons (term (l_2 (lub-p p_1 p_2))) 543 | (term ((l_3 p_3) (... ...)))) 544 | (cons (term (l_2 p_2)) 545 | (term (update-state ((l_3 p_3) (... ...)) l_1 p_1))))]) 546 | 547 | ;; Used as a premise of the E-Get rule. Returns #t if, for any 548 | ;; two distinct elements in P, the lub of them is Top-p, and #f 549 | ;; otherwise. 550 | (define-metafunction name 551 | incomp : P -> boolean 552 | [(incomp ()) #t] 553 | [(incomp (p)) #t] 554 | [(incomp (p_1 p_2)) ,(equal? (term (lub-p p_1 p_2)) (term Top-p))] 555 | [(incomp (p_1 p_2 p_3 (... ...))) 556 | ,(and (equal? (term (lub-p p_1 p_2)) (term Top-p)) 557 | (term (incomp (p_1 p_3 (... ...)))) 558 | (term (incomp (p_2 p_3 (... ...)))))]) 559 | 560 | ;; Used as a premise of the E-Get rule. If there exists a p_2 561 | ;; that is a member of P and is less than or equal to p_1, returns 562 | ;; that p_2. Otherwise, returns #f. 563 | (define-metafunction name 564 | exists-p : p P/null -> Maybe-p 565 | 566 | ;; If the second argument is null, then there definitely isn't a p_2. 567 | [(exists-p p_1 ()) #f] 568 | 569 | ;; If the first item in P is less than p_1, return it. 570 | [(exists-p p_1 (p_21 p_22 (... ...))) p_21 571 | (where #t (leq-p p_21 p_1))] 572 | 573 | ;; Otherwise, check the rest. 574 | [(exists-p p_1 (p_21 p_22 (... ...))) (exists-p p_1 (p_22 (... ...))) 575 | (where #f (leq-p p_21 p_1))]) 576 | 577 | ;; subst and subst-vars: capture-avoiding substitution, due to 578 | ;; redex.racket-lang.org/lam-v.html. 579 | 580 | (define-metafunction name 581 | subst : x any any -> any 582 | ;; 1. x_1 bound, so don't continue in lambda body 583 | [(subst x_1 any_1 (lambda (x_2 (... ...) x_1 x_3 (... ...)) any_2)) 584 | (lambda (x_2 (... ...) x_1 x_3 (... ...)) any_2) 585 | (side-condition (not (member (term x_1) (term (x_2 (... ...))))))] 586 | 587 | ;; 2. general purpose capture-avoiding case 588 | [(subst x_1 any_1 (lambda (x_2 (... ...)) any_2)) 589 | (lambda (x_new (... ...)) 590 | (subst x_1 any_1 (subst-vars (x_2 x_new) (... ...) any_2))) 591 | (where (x_new (... ...)) ,(variables-not-in (term (x_1 any_1 any_2)) 592 | (term (x_2 (... ...)))))] 593 | 594 | ;; 3. replace x_1 with e_1 595 | [(subst x_1 any_1 x_1) any_1] 596 | 597 | ;; 4. x_1 and x_2 are different, so don't replace 598 | [(subst x_1 any_1 x_2) x_2] 599 | 600 | ;; the last cases cover all other expressions 601 | [(subst x_1 any_1 (any_2 (... ...))) 602 | ((subst x_1 any_1 any_2) (... ...))] 603 | [(subst x_1 any_1 any_2) any_2]) 604 | 605 | (define-metafunction name 606 | subst-vars : (x any) (... ...) any -> any 607 | [(subst-vars (x_1 any_1) x_1) any_1] 608 | [(subst-vars (x_1 any_1) (any_2 (... ...))) 609 | ((subst-vars (x_1 any_1) any_2) (... ...))] 610 | [(subst-vars (x_1 any_1) any_2) any_2] 611 | [(subst-vars (x_1 any_1) (x_2 any_2) (... ...) any_3) 612 | (subst-vars (x_1 any_1) 613 | (subst-vars (x_2 any_2) (... ...) any_3))] 614 | [(subst-vars any) any]))) 615 | -------------------------------------------------------------------------------- /LVish/Makefile: -------------------------------------------------------------------------------- 1 | default: all 2 | 3 | all: nat-lang-all natpair-ivars-lang-all 4 | 5 | nat-lang-all: 6 | raco test -s test-all nat.rkt 7 | 8 | natpair-ivars-lang-all: 9 | raco test -s test-all natpair-ivars.rkt 10 | 11 | clean: 12 | rm -rf compiled/ -------------------------------------------------------------------------------- /LVish/README.md: -------------------------------------------------------------------------------- 1 | # LVish in Redex 2 | 3 | The code in this directory is a PLT Redex model of the lambdaLVar calculus in the paper ["Freeze After Writing: Quasi-Deterministic Parallel Programming with LVars"][http://www.cs.indiana.edu/~lkuper/papers/lvish-popl14.pdf]. 4 | 5 | ### Version requirements 6 | 7 | The code has been tested under [various versions of Racket](https://travis-ci.org/lkuper/lvar-semantics). Other versions may also work. 8 | 9 | It will _not_ work under versions prior to 5.3.2 (released January 2013). This is because version 5.3.2 added support for the Redex `boolean` pattern, which the code makes use of. 10 | 11 | ### Building and running 12 | 13 | Running `make all` in this directory will build all the LVish languages and run their test suites. 14 | -------------------------------------------------------------------------------- /LVish/nat.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (module language racket 4 | (require "LVish.rkt") 5 | (require srfi/1) 6 | (provide LVish-nat) 7 | 8 | (define-LVish-language LVish-nat downset-op max natural) 9 | 10 | ;; To figure out at some point: maybe we could actually write 11 | ;; downset-op with Redex patterns? 12 | 13 | (define downset-op 14 | (lambda (d) 15 | (if (number? d) 16 | (append '(Bot) (iota d) `(,d)) 17 | '(Bot))))) 18 | 19 | (module test-suite racket 20 | (require redex/reduction-semantics) 21 | (require (submod ".." language)) 22 | (require "test-helpers.rkt") 23 | 24 | (provide 25 | test-all) 26 | 27 | (define (test-all) 28 | (display "Running metafunction tests...") 29 | (flush-output) 30 | (time (meta-test-suite)) 31 | 32 | (display "Running test suite...") 33 | (flush-output) 34 | (time (program-test-suite rr))) 35 | 36 | ;; Test suite 37 | 38 | (define (meta-test-suite) 39 | (test-equal 40 | (term (exists-p (6 #f) ())) 41 | (term #f)) 42 | 43 | (test-equal 44 | (term (exists-p (6 #f) ((3 #f)))) 45 | (term (3 #f))) 46 | 47 | (test-equal 48 | (term (exists-p (6 #f) ((9 #f)))) 49 | (term #f)) 50 | 51 | (test-equal 52 | (term (exists-p (3 #f) ((3 #f)))) 53 | (term (3 #f))) 54 | 55 | ;; These next three are unrealistic for this lattice because Q would 56 | ;; be a singleton set, but it's here to exercise exists-p. 57 | (test-equal 58 | (term (exists-p (6 #f) ((7 #f) (8 #f) (9 #f)))) 59 | (term #f)) 60 | 61 | (test-equal 62 | (term (exists-p (6 #f) ((7 #f) (8 #f) (9 #f) (6 #f)))) 63 | (term (6 #f))) 64 | 65 | (test-equal 66 | (term (exists-p (6 #f) ((7 #f) (8 #f) (9 #f) (5 #f)))) 67 | (term (5 #f))) 68 | 69 | (test-equal 70 | (term (lub Bot Bot)) 71 | (term Bot)) 72 | 73 | (test-equal 74 | (term (lub Top 3)) 75 | (term Top)) 76 | 77 | (test-equal 78 | (term (lub 3 4)) 79 | (term 4)) 80 | 81 | (test-equal 82 | (term (lub 3 3)) 83 | (term 3)) 84 | 85 | (test-equal 86 | (term (lub-p (3 #f) (4 #f))) 87 | (term ((lub 3 4) #f))) 88 | 89 | (test-equal 90 | (term (lub-p (3 #t) (3 #t))) 91 | (term (3 #t))) 92 | 93 | (test-equal 94 | (term (lub-p (3 #t) (4 #t))) 95 | (term Top-p)) 96 | 97 | (test-equal 98 | (term (lub-p (3 #f) (4 #t))) 99 | (term (4 #t))) 100 | 101 | (test-equal 102 | (term (lub-p (4 #f) (3 #t))) 103 | (term Top-p)) 104 | 105 | (test-equal 106 | (term (lub-p (4 #t) (3 #f))) 107 | (term (4 #t))) 108 | 109 | (test-equal 110 | (term (lub-p (3 #t) (4 #f))) 111 | (term Top-p)) 112 | 113 | (test-equal 114 | (term (leq 3 3)) 115 | (term #t)) 116 | 117 | (test-equal 118 | (term (leq Top 3)) 119 | (term #f)) 120 | 121 | (test-equal 122 | (term (leq 3 Top)) 123 | (term #t)) 124 | 125 | (test-equal 126 | (term (leq Bot 3)) 127 | (term #t)) 128 | 129 | (test-equal 130 | (term (leq 3 Bot)) 131 | (term #f)) 132 | 133 | (test-equal 134 | (term (leq Top Bot)) 135 | (term #f)) 136 | 137 | (test-equal 138 | (term (leq Bot Top)) 139 | (term #t)) 140 | 141 | (test-equal 142 | (term (leq 3 4)) 143 | (term #t)) 144 | 145 | (test-equal 146 | (term (leq 4 3)) 147 | (term #f)) 148 | 149 | (test-equal 150 | (term (extend-H () 3)) 151 | (term (3))) 152 | 153 | (test-equal 154 | (term (extend-H (3 4 5) 6)) 155 | (term (6 3 4 5))) 156 | 157 | ;; For the remaining tests, note that (downset 3) => (Bot 0 1 2 3). 158 | 159 | ;; The following tests all use the entire downset as Q: 160 | 161 | (test-equal 162 | (term (contains-all-Q 3 163 | (Bot 0 1 2 3) 164 | (Bot 0 1 2 3))) 165 | (term #t)) 166 | 167 | (test-equal 168 | (term (contains-all-Q 3 169 | (Bot 1 2 3) 170 | (Bot 0 1 2 3))) 171 | (term #f)) 172 | 173 | (test-equal 174 | (term (contains-all-Q 3 175 | (Bot 2 3) 176 | (Bot 0 1 2 3))) 177 | (term #f)) 178 | 179 | (test-equal 180 | (term (contains-all-Q 3 181 | (Bot 2 3 4 5) 182 | (Bot 0 1 2 3))) 183 | (term #f)) 184 | 185 | (test-equal 186 | (term (contains-all-Q 3 187 | (Bot 0 1 2 3 4 5) 188 | (Bot 0 1 2 3))) 189 | (term #t)) 190 | 191 | ;; And these use smaller sets as Q: 192 | 193 | (test-equal 194 | (term (contains-all-Q 3 195 | (Bot 0 1 2 3) 196 | (Bot))) 197 | (term #t)) 198 | 199 | (test-equal 200 | (term (contains-all-Q 3 201 | (Bot 1 2 3) 202 | (Bot 0))) 203 | (term #f)) 204 | 205 | (test-equal 206 | (term (contains-all-Q 3 207 | (Bot 2 3) 208 | (Bot 2 3))) 209 | (term #t)) 210 | 211 | (test-equal 212 | (term (contains-all-Q 3 213 | (Bot 2 3 4 5) 214 | (0 1 2 3))) 215 | (term #f)) 216 | 217 | (test-equal 218 | (term (contains-all-Q 3 219 | (Bot 0 1 2 3 4 5) 220 | (Bot 0))) 221 | (term #t)) 222 | 223 | ;; The following tests all use the entire downset as Q: 224 | 225 | ;; "Return the first element <= 3 that is *not* in (0 1 2 3 4 5) 226 | ;; but *is* in (Bot 0 1 2 3)." 227 | (test-equal 228 | (term (first-unhandled-d-in-Q 3 (0 1 2 3 4 5) (Bot 0 1 2 3))) 229 | (term Bot)) 230 | 231 | (test-equal 232 | (term (first-unhandled-d-in-Q 3 (Bot 1 2 3 4 5) (Bot 0 1 2 3))) 233 | (term 0)) 234 | 235 | (test-equal 236 | (term (first-unhandled-d-in-Q 3 (Bot 0 1 2 3 4 5) (Bot 0 1 2 3))) 237 | (term #f)) 238 | 239 | (test-equal 240 | (term (first-unhandled-d-in-Q 3 (Bot 0 1 2 3) (Bot 0 1 2 3))) 241 | (term #f)) 242 | 243 | (test-equal 244 | (term (first-unhandled-d-in-Q 3 (Bot 2 3) (Bot 0 1 2 3))) 245 | (term 0)) 246 | 247 | (test-equal 248 | (term (first-unhandled-d-in-Q 3 (Bot 0 2 3) (Bot 0 1 2 3))) 249 | (term 1)) 250 | 251 | (test-equal 252 | (term (first-unhandled-d-in-Q 3 (Bot 0 1 2) (Bot 0 1 2 3))) 253 | (term 3)) 254 | 255 | (test-equal 256 | (term (first-unhandled-d-in-Q 3 (Bot 0 1 2 4 5 6 7) (Bot 0 1 2 3))) 257 | (term 3)) 258 | 259 | (test-equal 260 | (term (first-unhandled-d-in-Q 3 (7 0 2 6 Bot 3 1 5 4) (Bot 0 1 2 3))) 261 | (term #f)) 262 | 263 | (test-equal 264 | (term (first-unhandled-d-in-Q 3 (7 6 5 4 3 0 Bot) (Bot 0 1 2 3))) 265 | (term 1)) 266 | 267 | ;; And these use smaller sets as Q: 268 | 269 | ;; "Return the first element <= 3 that is *not* in (0 1 2 3 4 5) 270 | ;; but *is* in (1 2 3)." 271 | (test-equal 272 | (term (first-unhandled-d-in-Q 3 (0 1 2 3 4 5) (1 2 3))) 273 | (term #f)) 274 | 275 | (test-equal 276 | (term (first-unhandled-d-in-Q 3 (Bot 1 2 3 4 5) (1 2 3))) 277 | (term #f)) 278 | 279 | (test-equal 280 | (term (first-unhandled-d-in-Q 3 (Bot 0 1 2 3 4 5) (1 2 3))) 281 | (term #f)) 282 | 283 | (test-equal 284 | (term (first-unhandled-d-in-Q 3 (Bot 0 1 2 3) (1 2 3))) 285 | (term #f)) 286 | 287 | (test-equal 288 | (term (first-unhandled-d-in-Q 3 (Bot 2 3) (0 1 2))) 289 | (term 0)) 290 | 291 | (test-equal 292 | (term (first-unhandled-d-in-Q 3 (Bot 0 2 3) (0 1 2))) 293 | (term 1)) 294 | 295 | (test-equal 296 | (term (first-unhandled-d-in-Q 1 (Bot 0 3) (2))) 297 | (term #f)) 298 | 299 | (test-equal 300 | (term (first-unhandled-d-in-Q 3 (Bot 0 3) (2))) 301 | (term 2)) 302 | 303 | (test-equal 304 | (term (first-unhandled-d-in-Q 3 (Bot 0 2 3) (2))) 305 | (term #f)) 306 | 307 | (test-equal 308 | (term (store-dom ((l1 (4 #f)) (l2 (5 #f)) (l3 (Bot #f))))) 309 | (term (l1 l2 l3))) 310 | 311 | (test-equal 312 | (term (lookup-val ((l (2 #f))) l)) 313 | (term 2)) 314 | 315 | (test-equal 316 | (term (lookup-status ((l (2 #f))) l)) 317 | (term #f)) 318 | 319 | (test-equal 320 | (term (lookup-status ((l (2 #t))) l)) 321 | (term #t)) 322 | 323 | (test-equal 324 | (term (lookup-state ((l (2 #t))) l)) 325 | (term (2 #t))) 326 | 327 | (test-equal 328 | (term (lookup-state ((l (2 #t)) (l1 (3 #f))) l1)) 329 | (term (3 #f))) 330 | 331 | (test-equal 332 | (term (update-state () l (4 #f))) 333 | (term ((l (4 #f))))) 334 | 335 | (test-equal 336 | (term (update-state ((l (3 #f))) l (4 #f))) 337 | (term ((l (4 #f))))) 338 | 339 | (test-equal 340 | (term (update-state () l (Bot #f))) 341 | (term ((l (Bot #f))))) 342 | 343 | (test-equal 344 | (term (store-dom ())) 345 | (term ())) 346 | 347 | (test-equal 348 | (term (store-dom ((l (3 #f)) (l1 (4 #f))))) 349 | (term (l l1))) 350 | 351 | (test-equal 352 | (term (store-dom-diff ((l (3 #f)) (l1 (4 #f))) 353 | ((l (4 #f)) (l1 (3 #f))))) 354 | (term ())) 355 | 356 | (test-equal 357 | (term (store-dom-diff ((l (3 #f))) 358 | ((l (4 #f)) (l1 (3 #f))))) 359 | (term ())) 360 | 361 | (test-equal 362 | (term (store-dom-diff ((l (4 #f)) (l1 (3 #f))) 363 | ((l (3 #f))))) 364 | (term (l1))) 365 | 366 | (test-equal 367 | (term (store-dom-diff ((l (4 #f))) 368 | ())) 369 | (term (l))) 370 | 371 | (test-equal 372 | (term (top? Top)) 373 | (term #t)) 374 | 375 | (test-equal 376 | (term (top? Bot)) 377 | (term #f)) 378 | 379 | (test-equal 380 | (term (top? 3)) 381 | (term #f)) 382 | 383 | (test-equal 384 | (cfgs-equal-modulo-perms? 385 | '(((l (4 #f)) (l1 (3 #f))) ()) 386 | '(((l1 (3 #f)) (l (4 #f))) ())) 387 | #t) 388 | 389 | (test-equal 390 | (cfgs-equal-modulo-perms? 391 | '(((l1 (3 #f)) (l (4 #f))) ()) 392 | '(((l1 (3 #f)) (l (4 #f))) (3))) 393 | #f) 394 | 395 | (test-equal 396 | (cfgs-equal-modulo-perms? 397 | '(((l (4 #f)) (l1 (3 #f))) ()) 398 | '(((l1 (3 #f)) (l (4 #f))) (3))) 399 | #f) 400 | 401 | (test-equal 402 | (cfgs-equal-modulo-perms? 403 | '(((l (3 #f)) (l1 (4 #f))) ()) 404 | '(((l1 (3 #f)) (l (4 #f))) ())) 405 | #f) 406 | 407 | (test-equal 408 | (term (subst l l1 (((l (Bot #f))) 409 | (put l 3)))) 410 | (term (((l1 (Bot #f))) 411 | (put l1 3)))) 412 | 413 | (test-results)) 414 | 415 | (define (program-test-suite rr) 416 | 417 | (test-->> rr 418 | (term 419 | (() ;; empty store 420 | ((lambda (x_1) x_1) 421 | ((lambda (x_1) x_1) (lambda (x_2) x_2))))) 422 | (term 423 | (() 424 | (lambda (x_2) x_2)))) 425 | 426 | (test-->> rr 427 | (term 428 | (() ;; empty store 429 | (((lambda (x_1) x_1) (lambda (x_2) x_2)) 430 | (lambda (x_1) x_1)))) 431 | (term 432 | (() 433 | (lambda (x_1) x_1)))) 434 | 435 | (test-->> rr 436 | (term 437 | (() ;; empty store 438 | (((lambda (x_1) x_1) (lambda (x_2) x_2)) 439 | ((lambda (x_1) x_1) (lambda (x_2) x_2))))) 440 | (term 441 | (() 442 | (lambda (x_2) x_2)))) 443 | 444 | (test-->> rr 445 | (term 446 | (() ;; empty store 447 | ((lambda (x_1) x_1) ()))) 448 | (term 449 | (() 450 | ()))) 451 | 452 | (test-->> rr 453 | (term 454 | (() ;; empty store 455 | ((lambda (x_1) x_1) (lambda (x_2) x_2)))) 456 | (term 457 | (() 458 | (lambda (x_2) x_2)))) 459 | 460 | (test-->> rr 461 | (term 462 | (((l (3 #f))) 463 | new)) 464 | (term 465 | (((l (3 #f)) (l1 (Bot #f))) 466 | l1))) 467 | 468 | (test-->> rr 469 | (term 470 | (((l (3 #f)) (l1 (4 #f))) 471 | new)) 472 | (term 473 | (((l (3 #f)) (l1 (4 #f)) (l2 (Bot #f))) 474 | l2))) 475 | 476 | (test-->> rr 477 | (term 478 | (((l (Bot #f))) 479 | (put l 3))) 480 | (term 481 | (((l (3 #f))) 482 | ()))) 483 | 484 | (test-->> rr 485 | (term 486 | (((l (2 #f))) 487 | (put l 3))) 488 | (term 489 | (((l (3 #f))) 490 | ()))) 491 | 492 | ;; This should work because put just puts the max of the current 493 | ;; value and the new value. 494 | (test-->> rr 495 | (term 496 | (((l (2 #f))) 497 | (put l 1))) 498 | (term 499 | (((l (2 #f))) 500 | ()))) 501 | 502 | ;; let 503 | (test-->> rr 504 | (term 505 | (() ;; empty store 506 | (let ((x_1 (lambda (x_1) x_1))) 507 | (let ((x_2 (lambda (x_1) x_1))) 508 | (x_1 x_2))))) 509 | (term 510 | (() 511 | (lambda (x_1) x_1)))) 512 | 513 | ;; let par 514 | (test-->> rr 515 | (term 516 | (() ;; empty store 517 | (let par ((x_1 (lambda (x_1) x_1)) 518 | (x_2 (lambda (x_1) x_1))) 519 | (x_1 x_2)))) 520 | (term 521 | (() 522 | (lambda (x_1) x_1)))) 523 | 524 | (test-->> rr 525 | (term 526 | (() ;; empty store 527 | ((lambda (x) x) new))) 528 | (term 529 | (((l (Bot #f))) 530 | l))) 531 | 532 | (test-->> rr 533 | (term 534 | (() ;; empty store 535 | (let ((x_1 new)) 536 | (let ((x_2 (put x_1 3))) 537 | (let ((x_3 (get x_1 ((2 #f))))) 538 | x_3))))) 539 | (term 540 | (((l (3 #f))) 541 | (2 #f)))) 542 | 543 | (test-->> rr 544 | (term 545 | (() ;; empty store 546 | (let ((x_1 new)) 547 | (let par ((x_2 (put x_1 2)) 548 | (x_3 (put x_1 3))) 549 | (get x_1 ((2 #f))))))) 550 | (term 551 | (((l (3 #f))) 552 | (2 #f)))) 553 | 554 | ;; Another aspect of E-Put's behavior 555 | (test-->> rr 556 | (term 557 | (() ;; empty store 558 | (let ((x_1 new)) 559 | (let ((x_2 (put x_1 5))) 560 | ;; This should just take the lub of the old and new 561 | ;; values, i.e., 5. 562 | (let ((x_3 (put x_1 4))) 563 | (get x_1 ((5 #f)))))))) 564 | (term 565 | (((l (5 #f))) 566 | (5 #f)))) 567 | 568 | (test-->> rr 569 | #:equiv cfgs-equal-modulo-perms? 570 | (term 571 | (() 572 | (let par ([x_1 new] 573 | [x_2 new]) 574 | (let par ([x_3 (put x_1 3)] 575 | [x_4 (put x_2 4)]) 576 | (get x_2 ((4 #f))))))) 577 | (term 578 | (((l (3 #f)) 579 | (l1 (4 #f))) 580 | (4 #f))) 581 | (term 582 | (((l (4 #f)) 583 | (l1 (3 #f))) 584 | (4 #f)))) 585 | 586 | (test-->> rr 587 | (term 588 | (() ;; empty store 589 | (let ((x_1 new)) 590 | (let par ((x_2 (put x_1 2)) 591 | (x_3 (get x_1 ((2 #f))))) 592 | (get x_1 ((2 #f))))))) 593 | (term 594 | (((l (2 #f))) 595 | (2 #f)))) 596 | 597 | (test-->> rr 598 | (term 599 | (() ;; empty store 600 | (let ((x_1 new)) 601 | (let par 602 | ;; Gets stuck trying to get 4 out of x_1, then 603 | ;; unstuck after the other subexpression finishes. 604 | ((x_4 (let par ((x_2 (put x_1 2)) 605 | (x_3 (put x_1 3))) 606 | (get x_1 ((4 #f))))) 607 | ;; Eventually puts 4 in x_1 after several dummy 608 | ;; beta-reductions. 609 | (x_5 ((lambda (x_2) 610 | ((lambda (x_2) 611 | ((lambda (x_2) 612 | ((lambda (x_2) 613 | ((lambda (x_2) 614 | (put x_1 4)) ())) ())) ())) ())) ()))) 615 | x_4)))) 616 | (term 617 | (((l (4 #f))) 618 | (4 #f)))) 619 | 620 | (test-->> rr 621 | (term 622 | (() ;; empty store 623 | (let ((x_1 new)) 624 | (let ((x_2 (put x_1 3))) 625 | (freeze x_1))))) 626 | (term 627 | (((l (3 #t))) 628 | 3))) 629 | 630 | ;; Thresholding on frozenness. The actual state of the LVar will 631 | ;; reach 3 (and so it will eventually have a downset of (Bot 0 1 2 632 | ;; 3), but the only elements in that set that need to be handled 633 | ;; are those that are members of the event set (Bot). Hence the 634 | ;; callback will run only once. 635 | (test-->> rr 636 | (term 637 | (() ;; empty store 638 | (let ((x_1 new)) 639 | (let par 640 | ((x_2 (get x_1 ((1 #t) (2 #t) (3 #t) (4 #t)))) 641 | (x_3 (freeze x_1 after (Bot) with (lambda (x) 642 | (put x_1 3))))) 643 | x_2)))) 644 | (term 645 | (((l (3 #t))) 646 | (3 #t)))) 647 | 648 | ;; Here we have a quasi-deterministic program where a freeze-after 649 | ;; and a put are racing with each other. One of two things will 650 | ;; happen: (put x_1 (4)) will complete first, so x_2 will be (4), 651 | ;; or the freeze-after will complete first, so the program will 652 | ;; raise an error. 653 | (test-->> rr 654 | (term 655 | (() ;; empty store 656 | (let ((x_1 new)) 657 | (let par 658 | ((x_2 (let ((x_4 (put x_1 3))) 659 | (freeze x_1))) 660 | (x_3 (put x_1 4))) 661 | x_2)))) 662 | (term 663 | (((l (4 #t))) 664 | 4)) 665 | (term 666 | Error)) 667 | 668 | ;; Fancier freezing. This one will actually never raise an error 669 | ;; because the racing put is less than 2! 670 | 671 | (test-->> rr 672 | (term 673 | (() ;; empty store 674 | (let ((x_1 new)) 675 | (let par 676 | ((x_2 (let ((x_4 (put x_1 0))) 677 | (freeze x_1 after (Bot) with (lambda (x) 678 | (put x_1 2))))) 679 | (x_3 (put x_1 1))) 680 | x_2)))) 681 | (term 682 | (((l (2 #t))) 683 | 2))) 684 | 685 | ;; But this one is quasi-deterministic: if the racing put wins, 686 | ;; we'll finish with 3 and no error; otherwise we'll get a 687 | ;; put-after-freeze error. 688 | (test-->> rr 689 | (term 690 | (() ;; empty store 691 | (let ((x_1 new)) 692 | (let par 693 | ((x_2 (let ((x_4 (put x_1 0))) 694 | (freeze x_1 after (Bot) with (lambda (x) 695 | (put x_1 2))))) 696 | (x_3 (put x_1 3))) 697 | x_2)))) 698 | (term 699 | (((l (3 #t))) 700 | 3)) 701 | (term 702 | Error)) 703 | 704 | ;; Suppose we don't do any writes to an LVar, but then we do a 705 | ;; freeze-after with a callback. The callback must still run at 706 | ;; least once, in order to add Bot to the `handled` set. 707 | (test-->> rr 708 | (term 709 | (() ;; empty store 710 | (let ((x_1 new)) 711 | (let ((x_2 new)) 712 | (let par 713 | ((x_3 (freeze x_1 after (Bot) with (lambda (x) 714 | (put x_2 7)))) 715 | (x_4 (put x_2 5))) 716 | x_3))))) 717 | (term 718 | (((l (Bot #t)) 719 | (l1 (7 #f))) 720 | Bot))) 721 | 722 | ;; Just trying some weird things. This program will fault if one 723 | ;; of the callback-triggered `put`s completes after the other LVar 724 | ;; gets frozen, but it's also possible for the program to complete 725 | ;; successfully! 726 | (test-->> rr 727 | (term 728 | (() ;; empty store 729 | (let ((x_1 new)) 730 | (let ((x_2 new)) 731 | (let par 732 | ((x_3 (freeze x_1 after (Bot) with (lambda (x) 733 | (put x_2 0)))) 734 | (x_4 (freeze x_2 after (Bot) with (lambda (x) 735 | (put x_1 1))))) 736 | x_3))))) 737 | (term 738 | (((l (1 #t)) 739 | (l1 (0 #t))) 740 | 1)) 741 | (term 742 | Error)) 743 | 744 | ;; Trying out more interesting eval contexts. 745 | (test-->> rr 746 | (term 747 | (() ;; empty store 748 | (let ((x_1 new)) 749 | (let ((x_2 new)) 750 | (let ((x_3 (freeze ((lambda (x) x) x_2)))) 751 | x_3))))) 752 | (term 753 | (((l (Bot #f)) 754 | (l1 (Bot #t))) 755 | Bot))) 756 | 757 | (test-->> rr 758 | (term 759 | (() ;; empty store 760 | (let ((x_1 new)) 761 | (let ((x_2 new)) 762 | (let par 763 | ((x_3 (freeze x_1 after (Bot) with ((lambda (x) 764 | (lambda (x) 765 | (put x_2 0))) 766 | ()))) 767 | (x_4 (freeze x_2 after (Bot) with ((lambda (x) 768 | (lambda (x) 769 | (put x_1 1))) 770 | ())))) 771 | x_3))))) 772 | (term 773 | (((l (1 #t)) 774 | (l1 (0 #t))) 775 | 1)) 776 | (term 777 | Error)) 778 | 779 | (test-->> rr 780 | (term 781 | (() ;; empty store 782 | (let ((x_1 new)) 783 | (let ((x_2 new)) 784 | (let ((x_3 new)) 785 | (let par 786 | ((x_3 (freeze x_1 after (Bot) with ((lambda (x) 787 | (lambda (x) 788 | (put x_2 0))) 789 | (put x_3 4)))) 790 | (x_4 (freeze x_2 after (Bot) with ((lambda (x) 791 | (lambda (x) 792 | (put x_1 1))) 793 | (put x_3 3))))) 794 | x_3)))))) 795 | (term 796 | (((l (1 #t)) 797 | (l1 (0 #t)) 798 | (l2 (4 #f))) 799 | 1)) 800 | (term 801 | Error)) 802 | 803 | ;; Freezing an LVar twice with different values is 804 | ;; quasi-deterministic. 805 | (test-->> rr 806 | (term 807 | (() ;; empty store 808 | (let ((x_1 new)) 809 | (let par 810 | ((x_3 (freeze x_1 after (Bot) with (lambda (x) 811 | (put x_1 0)))) 812 | (x_4 (freeze x_1 after (Bot) with (lambda (x) 813 | (put x_1 1))))) 814 | x_3)))) 815 | (term 816 | (((l (1 #t))) 817 | 1)) 818 | (term 819 | Error)) 820 | 821 | (test-results))) 822 | 823 | (module test-all racket 824 | (require (submod ".." test-suite)) 825 | (test-all)) 826 | -------------------------------------------------------------------------------- /LVish/natpair-ivars.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (module language racket 4 | (require "LVish.rkt") 5 | (require srfi/1) 6 | (require racket/match) 7 | (provide LVish-natpair-ivars) 8 | (provide downset-op) 9 | 10 | (define-LVish-language LVish-natpair-ivars 11 | downset-op 12 | my-lub 13 | (natural natural) 14 | (natural Bot) 15 | (Bot natural)) 16 | 17 | ;; downset-op: Takes a pair p and returns a list of everything below 18 | ;; or equal to p in the lattice. (Note that we're dealing with 19 | ;; pairs of IVars, not pairs of counters.) 20 | 21 | ;; (downset-op '(2 1)) => 22 | ;; '(Bot 23 | ;; (2 Bot) 24 | ;; (Bot 1) 25 | ;; (2 1)) 26 | 27 | (define downset-op 28 | (lambda (p) 29 | (append '(Bot) 30 | (match p 31 | ['Bot '()] 32 | [`(,(? number? a) Bot) 33 | `(,p)] 34 | [`(Bot ,(? number? d)) 35 | `(,p)] 36 | [`(,(? number? a) ,(? number? d)) 37 | `((,a Bot) 38 | (Bot ,d) 39 | ,p)])))) 40 | 41 | ;; my-lub: A function that takes two pairs (they might be of the 42 | ;; form (natural natural), (natural Bot), or (Bot natural)) and 43 | ;; returns a pair that is their least upper bound. 44 | 45 | ;; Because they're IVars, we can only safely combine two pairs if 46 | ;; one of them has only the car filled in, and the other has only 47 | ;; the cadr filled in -- or, if they've filled in something 48 | ;; overlapping, if it's equal. 49 | 50 | (define lub-helper 51 | (lambda (a1 a2) 52 | (match `(,a1 ,a2) 53 | [`(Bot Bot) 'Bot] 54 | [`(Bot ,(? number? n)) n] 55 | [`(,(? number? n) Bot) n] 56 | [`(,(? number? n) ,(? number? n)) n] 57 | [`(,(? number? n) ,(? number? m)) 'Top]))) 58 | 59 | (define my-lub 60 | (lambda (p1 p2) 61 | (let ([p `(,(lub-helper (car p1) (car p2)) 62 | ,(lub-helper (cadr p1) (cadr p2)))]) 63 | (match p 64 | [`(Top ,_) 'Top] 65 | [`(,_ Top) 'Top] 66 | [`(Bot Bot) 'Bot] 67 | [_ p]))))) 68 | 69 | (module test-suite racket 70 | (require redex/reduction-semantics) 71 | (require (submod ".." language)) 72 | (require "test-helpers.rkt") 73 | 74 | (provide 75 | test-all) 76 | 77 | (define (test-all) 78 | (display "Running metafunction tests...") 79 | (flush-output) 80 | (time (meta-test-suite)) 81 | 82 | (display "Running test suite...") 83 | (flush-output) 84 | (time (program-test-suite rr))) 85 | 86 | ;; Test suite 87 | 88 | (define (meta-test-suite) 89 | 90 | (test-equal 91 | (downset-op '(2 1)) 92 | '(Bot 93 | (2 Bot) 94 | (Bot 1) 95 | (2 1))) 96 | 97 | (test-equal 98 | (downset-op 'Bot) 99 | '(Bot)) 100 | 101 | (test-equal 102 | (downset-op '(2 Bot)) 103 | '(Bot 104 | (2 Bot))) 105 | 106 | (test-equal 107 | (downset-op '(Bot 1)) 108 | '(Bot 109 | (Bot 1))) 110 | 111 | (test-equal 112 | (term (lub-p ((3 Bot) #f) ((3 6) #f))) 113 | (term ((3 6) #f))) 114 | 115 | (test-equal 116 | (term (incomp (((3 Bot) #f) ((Bot 4) #f)))) 117 | (term #f)) 118 | 119 | (test-equal 120 | (term (incomp (((2 Bot) #f) ((3 Bot) #f) ((Bot 4) #f)))) 121 | (term #f)) 122 | 123 | (test-equal 124 | (term (incomp ((Bot #f) ((4 Bot) #f)))) 125 | (term #f)) 126 | 127 | (test-equal 128 | (term (incomp (((3 Bot) #f) ((4 Bot) #f)))) 129 | (term #t)) 130 | 131 | (test-equal 132 | (term (incomp (((Bot 3) #f) ((Bot 4) #f)))) 133 | (term #t)) 134 | 135 | (test-equal 136 | (term (incomp (((Bot 1) #f) ((Bot 2) #f) ((Bot 3) #f) ((Bot 4) #f) ((Bot 5) #f)))) 137 | (term #t)) 138 | 139 | (test-equal 140 | (term (incomp (((Bot 1) #f) ((Bot 2) #f) ((Bot 3) #f) ((Bot 4) #f) ((Bot 5) #f) ((1 Bot) #f)))) 141 | (term #f)) 142 | 143 | (test-equal 144 | (term (incomp (((3 Bot) #t) ((Bot 4) #t)))) 145 | (term #t)) 146 | 147 | (test-equal 148 | (term (incomp (((Bot 1) #t) ((1 Bot) #t)))) 149 | (term #t)) 150 | 151 | (test-equal 152 | (term (lookup-status ((l ((2 3) #f))) l)) 153 | (term #f)) 154 | 155 | (test-equal 156 | (term (lookup-status ((l ((2 3) #t))) l)) 157 | (term #t)) 158 | 159 | (test-equal 160 | (term (extend-H () (3 3))) 161 | (term ((3 3)))) 162 | 163 | (test-equal 164 | (term (extend-H ((3 3) (4 4) (5 5)) (6 6))) 165 | (term ((6 6) (3 3) (4 4) (5 5)))) 166 | 167 | ;; For the rest of the tests, note that (downset (1 1)) => 168 | ;; '(Bot 169 | ;; (1 Bot) 170 | ;; (Bot 1) 171 | ;; (1 1)) 172 | 173 | ;; The following tests all just use the entire downset as Q: 174 | 175 | (test-equal 176 | (term (contains-all-Q (1 1) 177 | (Bot (Bot 1) (1 Bot) (1 1)) 178 | (Bot (1 Bot) (Bot 1) (1 1)))) 179 | (term #t)) 180 | 181 | (test-equal 182 | (term (contains-all-Q (1 1) 183 | ((Bot 1) (1 Bot) (1 1)) 184 | (Bot (1 Bot) (Bot 1) (1 1)))) 185 | (term #f)) 186 | 187 | (test-equal 188 | (term (contains-all-Q (1 1) 189 | (Bot (Bot 1) (1 Bot) (2 Bot) (2 0) (2 1)) 190 | (Bot (1 Bot) (Bot 1) (1 1)))) 191 | (term #f)) 192 | 193 | ;; And these ones use various smaller sets for Q: 194 | 195 | (test-equal 196 | (term (contains-all-Q (1 1) 197 | (Bot (Bot 1) (1 Bot) (1 1)) 198 | ((1 1)))) 199 | (term #t)) 200 | 201 | (test-equal 202 | (term (contains-all-Q (1 1) 203 | ((Bot 1) (1 Bot) (1 1)) 204 | ((1 1)))) 205 | (term #t)) 206 | 207 | (test-equal 208 | (term (contains-all-Q (1 1) 209 | (Bot (Bot 1) (1 Bot) (2 Bot) (2 0) (2 1)) 210 | ((1 1) (2 2)))) 211 | (term #f)) 212 | 213 | (test-equal 214 | (term (contains-all-Q (1 1) 215 | (Bot (Bot 1) (1 Bot) (2 Bot) (2 0) (2 1)) 216 | (Bot (1 Bot)))) 217 | (term #t)) 218 | 219 | (test-equal 220 | (term (contains-all-Q (1 1) 221 | (Bot (Bot 1) (1 Bot) (2 Bot) (2 0) (2 1)) 222 | ((1 Bot)))) 223 | (term #t)) 224 | 225 | (test-equal 226 | (term (contains-all-Q (1 1) 227 | (Bot (Bot 1) (2 Bot) (2 0) (2 1)) 228 | ((1 Bot)))) 229 | (term #f)) 230 | 231 | ;; The following tests all just use the entire downset as Q: 232 | 233 | (test-equal 234 | (term (first-unhandled-d-in-Q (1 1) 235 | ((Bot 0) (Bot 1)) 236 | (Bot (1 Bot) (Bot 1) (1 1)))) 237 | (term Bot)) 238 | 239 | (test-equal 240 | (term (first-unhandled-d-in-Q (1 1) 241 | (Bot (0 Bot) (1 Bot)) 242 | (Bot (1 Bot) (Bot 1) (1 1)))) 243 | (term (Bot 1))) 244 | 245 | (test-equal 246 | (term (first-unhandled-d-in-Q (1 1) 247 | (Bot (Bot 1) (1 Bot) (1 1) (5 5) (6 6) (7 7)) 248 | (Bot (1 Bot) (Bot 1) (1 1)))) 249 | (term #f)) 250 | 251 | (test-equal 252 | (term (first-unhandled-d-in-Q (1 1) 253 | (Bot (Bot 1) (1 Bot) (1 0) (1 1)) 254 | (Bot (1 Bot) (Bot 1) (1 1)))) 255 | (term #f)) 256 | 257 | (test-equal 258 | (term (first-unhandled-d-in-Q (1 1) 259 | (Bot (1 Bot) (1 0) (1 1)) 260 | (Bot (1 Bot) (Bot 1) (1 1)))) 261 | (term (Bot 1))) 262 | 263 | (test-equal 264 | (term (first-unhandled-d-in-Q (1 1) 265 | (Bot (Bot 0) (Bot 1) 266 | (0 Bot) (0 0) (0 1) 267 | (1 Bot) (1 0)) 268 | (Bot (1 Bot) (Bot 1) (1 1)))) 269 | 270 | (term (1 1))) 271 | 272 | (test-equal 273 | (term (first-unhandled-d-in-Q (1 1) 274 | (Bot (Bot 0) (Bot 1) 275 | (0 Bot) (0 0) (0 1) 276 | (1 Bot) (1 0) 277 | (5 5) (6 6) (7 7)) 278 | (Bot (1 Bot) (Bot 1) (1 1)))) 279 | (term (1 1))) 280 | 281 | (test-equal 282 | (term (first-unhandled-d-in-Q (1 1) 283 | ((1 Bot) (0 0) (7 7) 284 | (5 5) Bot (1 0) 285 | (Bot 0) (1 1) (Bot 1) 286 | (0 Bot) (6 6) (0 1)) 287 | (Bot (1 Bot) (Bot 1) (1 1)))) 288 | (term #f)) 289 | 290 | ;; And these ones use various smaller sets for Q: 291 | 292 | (test-equal 293 | (term (first-unhandled-d-in-Q (1 1) 294 | ((Bot 0) (Bot 1)) 295 | ((1 Bot) (Bot 1) (1 1)))) 296 | (term (1 Bot))) 297 | 298 | (test-equal 299 | (term (first-unhandled-d-in-Q (1 1) 300 | (Bot (0 Bot) (1 Bot)) 301 | ((Bot 1) (1 1)))) 302 | (term (Bot 1))) 303 | 304 | (test-equal 305 | (term (first-unhandled-d-in-Q (1 1) 306 | (Bot (Bot 1) (1 Bot) (1 1) (5 5) (6 6) (7 7)) 307 | ((1 1)))) 308 | (term #f)) 309 | 310 | (test-equal 311 | (term (first-unhandled-d-in-Q (1 1) 312 | (Bot (Bot 1) (1 Bot) (1 0) (1 1)) 313 | ((1 Bot) (Bot 1) (1 1)))) 314 | (term #f)) 315 | 316 | (test-results)) 317 | 318 | (define (program-test-suite rr) 319 | 320 | (test-->> rr 321 | (term 322 | (() ;; empty store 323 | (let ((x_1 new)) 324 | (let ((x_2 (put x_1 (3 4)))) 325 | (freeze x_1))))) 326 | (term 327 | (((l ((3 4) #t))) 328 | (3 4)))) 329 | 330 | ;; Quasi-determinism with freezing. 331 | (test-->> rr 332 | (term 333 | (() ;; empty store 334 | (let ((x_1 new)) 335 | (let par 336 | ((x_2 (let ((x_4 (put x_1 (3 Bot)))) 337 | (freeze x_1))) 338 | (x_3 (put x_1 (Bot 6)))) 339 | x_2)))) 340 | (term 341 | (((l ((3 6) #t))) 342 | (3 6))) 343 | (term 344 | Error)) 345 | 346 | ;; Should deterministically raise an error, since it never uses 347 | ;; freezing. 348 | (test-->> rr 349 | (term 350 | (() ;; empty store 351 | (let ((x_1 new)) 352 | (let par 353 | ((x_2 (let ((x_4 (put x_1 (3 4)))) 354 | ;; legal, incompatible 2-element 355 | ;; threshold set 356 | (get x_4 ((3 4) (6 6))))) 357 | (x_3 (put x_1 (6 6)))) 358 | x_2)))) 359 | (term 360 | Error)) 361 | 362 | ;; Trying out more interesting eval contexts. 363 | (test-->> rr 364 | (term 365 | (() ;; empty store 366 | (let ((x_1 new)) 367 | (let ((x_2 new)) 368 | (let par 369 | ((x_3 (freeze x_1 after (Bot) with ((lambda (x) 370 | (lambda (x) 371 | (put x_2 (Bot 0)))) 372 | ()))) 373 | (x_4 (freeze x_2 after (Bot) with ((lambda (x) 374 | (lambda (x) 375 | (put x_1 (0 Bot)))) 376 | ())))) 377 | x_3))))) 378 | (term 379 | (((l ((0 Bot) #t)) 380 | (l1 ((Bot 0) #t))) 381 | (0 Bot))) 382 | (term 383 | Error)) 384 | 385 | ;; Should get stuck reducing, since ((3 Bot) (Bot 6)) is an 386 | ;; illegal threshold set. (Actually, this isn't quite right; such 387 | ;; programs should be ruled out from the start somehow.) 388 | (test-->> rr 389 | (term 390 | (() ;; empty store 391 | (let ((x_1 new)) 392 | (let par 393 | ((x_2 (get x_1 ((3 Bot) (Bot 6)))) 394 | (x_3 (put x_1 (6 6)))) 395 | x_2)))) 396 | 397 | ;; N.B.: Here I wish I could just test for the property 398 | ;; "gets stuck reducing" (since I don't really care 399 | ;; *how* it gets stuck, just that it does get stuck), 400 | ;; but the best way I can think of to test this in Redex 401 | ;; is by actually specifying the term at which it gets 402 | ;; stuck. 403 | (term 404 | (((l ((6 6) #f))) 405 | (((lambda (x_2) 406 | (lambda (x_3) x_2)) 407 | (get l ((3 Bot) (Bot 6)))) 408 | ())))) 409 | 410 | (test-results))) 411 | 412 | (module test-all racket 413 | (require (submod ".." test-suite)) 414 | (test-all)) 415 | 416 | 417 | -------------------------------------------------------------------------------- /LVish/test-helpers.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide cfgs-equal-modulo-perms? 4 | stores-equal-modulo-perms?) 5 | (require srfi/1) 6 | 7 | ;; Takes two (S e) configurations and returns #t if they're equal 8 | ;; modulo permutations of store bindings. 9 | (define cfgs-equal-modulo-perms? 10 | (lambda (cfg1 cfg2) 11 | (and (stores-equal-modulo-perms? (car cfg1) (car cfg2)) 12 | (equal? (cdr cfg1) (cdr cfg2))))) 13 | 14 | ;; Takes two stores and returns #t if they're equal modulo 15 | ;; permutations. 16 | (define stores-equal-modulo-perms? 17 | (lambda (s1 s2) 18 | (lset= equal? s1 s2))) 19 | 20 | 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | PLT Redex models of LVar calculi 2 | ================================ 3 | 4 | [![Build Status](https://travis-ci.org/lkuper/lvar-semantics.svg?branch=master)](https://travis-ci.org/lkuper/lvar-semantics) 5 | 6 | Subdirectories include: 7 | 8 | * [lambdaLVish]: a Redex model of the lambdaLVish calculus that appears in my 2015 dissertation ([see README](https://github.com/lkuper/lvar-semantics/tree/master/lambdaLVish#readme)). 9 | 10 | * [LVish]: a PLT Redex model of the LVish calculus that appears in our POPL 2014 paper and accompanying tech report ([see README](https://github.com/lkuper/lvar-semantics/tree/master/LVish#readme)). 11 | 12 | * [lambdaLVar]: a PLT Redex model of the lambdaLVar calculus that appears in our FHPC 2013 paper and accompanying tech report ([see README](https://github.com/lkuper/lvar-semantics/tree/master/lambdaLVar#readme)). 13 | 14 | [lambdaLVish]: https://github.com/lkuper/lvar-semantics/tree/master/lambdaLVish 15 | [LVish]: https://github.com/lkuper/lvar-semantics/tree/master/LVish 16 | [lambdaLVar]: https://github.com/lkuper/lvar-semantics/tree/master/lambdaLVar 17 | 18 | ### Modeling lattice parameterization in Redex, or, writing macros that write Redex models 19 | 20 | All the LVar calculi have stores containing "lattice variables", or LVars. An LVar is a mutable store location whose contents can only increase over time, where the meaning of "increase" is given by a partially ordered set, or _lattice_, that the user of the language specifies. Different instantiations of the lattice result in different languages. 21 | 22 | In the Redex of today, it's not possible to parameterize a language 23 | definition by a lattice (see discussion 24 | [here](http://stackoverflow.com/questions/15800167/plt-redex-parameterizing-a-language-definition)). So, instead, for each one of these Redex models we define a Racket macro that takes a lattice as one of its arguments and *generates* a Redex language definition. 25 | 26 | #### `define-lambdaLVar-language` 27 | 28 | For lambdaLVar, this macro is called `define-lambdaLVar-language`. It takes the following arguments: 29 | 30 | * a *name*, e.g., `lambdaLVar-nat`, which becomes the `lang-name` passed to Redex's `define-language` form. 31 | * a *lub operation*, e.g., `max`, a Racket-level procedure that takes two lattice elements and returns a lattice element. 32 | * some number of Redex patterns representing *lattice elements*, not including top and bottom elements, since we add those automatically. (Therefore, if we wanted a lattice consisting only of Top and Bot, we wouldn't pass any lattice elements to `define-LVish-language`.) 33 | 34 | For instance, to generate a language definition called `lambdaLVar-nat` where the lattice is the natural numbers with `max` as the least upper bound, one can write: 35 | 36 | ```racket 37 | (define-lambdaLVar-language lambdaLVar-nat max natural) 38 | ``` 39 | 40 | Here `natural` is [a pattern built into Redex](http://docs.racket-lang.org/redex/The_Redex_Reference.html?q=natural#%28tech._natural%29) that matches any exact non-negative integer. 41 | 42 | The file `lambdaLVar/nat.rkt` contains this instantiation and a test suite of programs for `lambdaLVar-nat`. `lambdaLVar/natpair.rkt` and `lambdaLVar/natpair-ivars.rkt` contain two more example instantiations. 43 | 44 | #### `define-LVish-language` 45 | 46 | For LVish, this macro is called `define-LVish-language`. It takes the following arguments: 47 | 48 | * a *name*, e.g., `LVish-nat`, which becomes the `lang-name` passed to Redex's `define-language` form. 49 | * a *"downset" operation*, a Racket-level procedure that takes a lattice element and returns the (finite) set of all lattice elements that are below that element. The downset operation is used to implement the `freeze ... after ... with` primitive in LVish. 50 | * a *lub operation*, a Racket-level procedure that takes two lattice elements and returns a lattice element. 51 | * some number of Redex patterns representing *lattice elements*, not including top and bottom elements, since we add those automatically. 52 | 53 | For instance, to generate a language definition called `LVish-nat` where the lattice is the natural numbers with `max` as the least upper bound, one can write: 54 | 55 | ```racket 56 | (define-LVish-language LVish-nat downset-op max natural) 57 | ``` 58 | 59 | where `natural` is a Redex pattern, as described above, and `downset-op` is defined as follows: 60 | 61 | ```racket 62 | (define downset-op 63 | (lambda (d) 64 | (if (number? d) 65 | (append '(Bot) (iota d) `(,d)) 66 | '(Bot))))) 67 | ``` 68 | 69 | The file `LVish/nat.rkt` contains this instantiation and a test suite of programs for `LVish-nat`. `LVish/natpair-ivars.rkt` contains another example instantiation. 70 | 71 | #### `define-lambdaLVish-language` 72 | 73 | For lambdaLVish, this macro is called `define-lambdaLVish-language`. It takes the following arguments: 74 | 75 | * a *name*, e.g., `lambdaLVish-nat`, which becomes the `lang-name` passed to Redex's `define-language` form. 76 | * a *"downset" operation*, a Racket-level procedure that takes a lattice element and returns the (finite) set of all lattice elements that are below that element. 77 | * a *lub operation*, a Racket-level procedure that takes two lattice elements and returns a lattice element. 78 | * a list of *update operations*, Racket-level procedures that each take a lattice element and return a lattice element. 79 | * some number of *lattice elements* represented as Redex patterns, not including top and bottom elements, since we add those automatically. 80 | 81 | For instance, to generate a language definition called `lambdaLVish-nat` where the lattice is the non-negative integers ordered in the usual way, and there are two update operations which respectively increment the contents of an LVar by one and two, one could write: 82 | 83 | ```racket 84 | (define-lambaLVish-language lambdaLVish-nat downset-op max update-ops natural) 85 | ``` 86 | 87 | where `natural` and `downset-op` are as above, and `update-op` is defined as follows: 88 | 89 | ```racket 90 | (define update-op-1 91 | (lambda (d) 92 | (match d 93 | ['Bot 1] 94 | [number (add1 d)]))) 95 | 96 | (define update-op-2 97 | (lambda (d) 98 | (match d 99 | ['Bot 2] 100 | [number (add1 (add1 d))]))) 101 | 102 | (define update-ops `(,update-op-1 ,update-op-2)) 103 | ``` 104 | 105 | The file `lambdaLVish/nat.rkt` contains this instantiation and a test suite of programs for `lambdaLVish-nat`. 106 | 107 | ## Reduction traces 108 | 109 | One nice feature that Redex offers is the ability to see a graphical "trace" of the reduction of a term (that is, the running of a program) in DrRacket. In order to use the trace feature with one of these Redex models, you have to first instantiate the model with a lattice. Open the file for the instantiation you want to use (such as `"nat.rkt"`), and click the "Run" button to open a REPL. Then, in the REPL: 110 | 111 | * `(require (submod "." language))`. This will bring the definition of the reduction relation into scope. 112 | * `(require redex)`. This will bring `traces` into scope. 113 | * Try tracing a term with the `traces` command: `(traces )` where `` is the reduction relation and `` is some term in your instantiation of the model. For example, for the language defined in `"nat.rkt"`, you can try: 114 | 115 | ```racket 116 | (traces rr (term 117 | (() 118 | (let ((x_1 new)) 119 | (let par 120 | ((x_2 (puti x_1 1)) 121 | (x_3 (puti x_1 2))) 122 | (freeze x_1))))) 123 | ``` 124 | 125 | This will open a window showing a reduction graph. 126 | -------------------------------------------------------------------------------- /lambdaLVar/Makefile: -------------------------------------------------------------------------------- 1 | default: nat-lang natpair-lang natpair-ivars-lang 2 | 3 | all: nat-lang-all natpair-lang-all natpair-ivars-lang-all 4 | 5 | nat-lang: 6 | raco test -s test-fast nat.rkt 7 | 8 | nat-lang-all: 9 | raco test -s test-all nat.rkt 10 | 11 | natpair-lang: 12 | raco test -s test-fast natpair.rkt 13 | 14 | natpair-lang-all: 15 | raco test -s test-all natpair.rkt 16 | 17 | natpair-ivars-lang: 18 | raco test -s test-fast natpair-ivars.rkt 19 | 20 | natpair-ivars-lang-all: 21 | raco test -s test-all natpair-ivars.rkt -------------------------------------------------------------------------------- /lambdaLVar/README.md: -------------------------------------------------------------------------------- 1 | # lambdaLVar in Redex 2 | 3 | The code in this directory is a PLT Redex model of the lambdaLVar calculus in the paper ["LVars: Lattice-based Data Structures for Deterministic Parallelism"][lambdaLVar-paper] (with some differences, as described below). 4 | 5 | **Stop!** Are you sure this is what you want to be looking at? If you're interested in LVars, you're probably better off looking at what's in the [LVish](https://github.com/lkuper/lvar-semantics/tree/master/LVish) or [lambdaLVish](https://github.com/lkuper/lvar-semantics/tree/master/lambdaLVish) directories instead. This stuff is just here for historical reasons. 6 | 7 | ### lambdaLVar in a nutshell 8 | 9 | lambdaLVar is a deterministic parallel calculus with shared state. It is an untyped lambda calculus extended with a store and with `put` and `get` operations that write to and read from shared variables. In this setting of shared mutable state, the trick that lambdaLVar employs to maintain determinism is that writes must be _monotonically increasing_ with respect to a user-specified partial order, and reads must make only limited observations of the states of variables -- for instance, in a lambdaLVar program it might be possible to observe that a store location containes "at least 4", but not possible to observe the precise value. 10 | 11 | ### Modeling truly simultaneous reductions in Redex 12 | 13 | With Redex, one typically defines a [Felleisen-and-Hieb-style reduction semantics based on _evaluation contexts_][eval-contexts]. An evaluation-context-based semantics is what Redex is best at expressing, and such a semantics would eliminate the need to explicitly specify "structural" rules like E-Put-1 and E-Put-2 in our semantics. Instead, we could simply specify a set of evaluation contexts: 14 | 15 | ``` 16 | (E hole (put E e) (put e E) ...) 17 | ``` 18 | 19 | Unfortunately, such _single-hole_ evaluation contexts force evaluation to be sequential, and we want to model the explicit simultaneous evaluation steps of the E-ParApp rule of our semantics. (To be sure, a semantics specified with single-hole evaluation contexts can express _arbitrary_ evaluation order and therefore remains open to the possibility of parallel _implementation_. Still, since parallelism is lambdaLVar's _raison d'être_, we want to bake parallelism into the model.) 20 | 21 | Since Redex [does not have support for multiple-hole evaluation contexts][racket-list-message], we opted instead for an inference-rule-based semantics implemented using Redex's [`define-judgment-form`][define-judgment-form] feature. Unfortunately, in so doing, we miss out on some of Redex's most useful features. ~~As a tiny example of what we're missing, `define-judgment-form` offers no way to name individual reduction rules, so although using Redex's [`traces`][traces] feature with our semantics will show us a beautiful reduction graph of a configuration, it won't label the edges in the graphs with the names of the reduction rules as it would normally, because Redex has no way of knowing their names.~~ Actually, this is no longer true -- the ability to name clauses in `define-judgment-form` was added in Racket release 5.3.1. But it's still going to take additional effort to get the names of rules to appear in the visualization. 22 | 23 | The Redex model is useful despite these limitations. However, it would be interesting to try modeling lambdaLVar in a framework that has better support for truly simultaneous reductions -- the [K system][k-framework] comes to mind. 24 | 25 | ### Dealing with reflexive relations 26 | 27 | The reflexive reduction rules E-Refl and E-ReflErr of our paper semantics pose a dilemma for the Redex testing infrastructure. Redex's built-in `test-->>` mechanism for testing a reduction relation finds all irreducible terms reachable from a given term, but with E-Refl and E-ReflErr present in the reduction relation, no lambdaLVar terms would be irreducible under it, so it wouldn't be possible to write tests with `test-->>`. An alternative testing mechanism, `test-->>E`, checks if there _exists_ a reduction path from one given term to another, but since the property we are most interested in testing for is determinism, that mechanism is also unsatisfactory since we wish to know not only that one term reduces to another, but that _all_ possible reductions take us from the first to the second. 28 | 29 | Fortunately, there is a simple workaround: we drop the E-Refl and E-ReflErr rules from our semantics and instead add two new rules, E-App-1 and E-App-2, by which parallel application expressions may take a step even if only one of their subexpressions can take a step. The result is a semantics that is feasible to test with Redex. This reduction relation is called `slow-rr`. 30 | 31 | ### Speed tweaks 32 | 33 | Under the semantics just described, if both subexpressions in an application can step, then any of three rules can apply next -- E-App-1, E-App-2, and E-ParApp -- leading to an exponential increase in the number of evaluation paths that an configuration might take. It is easy to construct lambdaLVar programs that are very slow to test with `test-->>` under this semantics, because the system must take all evaluation paths. Of course, taking all evaluation paths is exactly the behavior we want. Although we can't prove determinism with Redex, we _can_ prove the _absence_ of determinism -- a reduction graph that does not converge means that there's a nondeterminism-introducing bug somewhere. Nevertheless, sometimes we just want to check that a program runs at all. In that case, to ameliorate the slowness, we can define more restricted versions of E-App-1 and E-App-2, in which the subexpression that is not taking a step must be a _value_. Finally, we add an E-GetValBlock rule, which allows a _blocked_ `get` expression to step to itself. This is necessary because a blocked `get` is not a value. We call the resulting reduction relation `fast-rr`. 34 | 35 | Under the `fast-rr` rules, an application expression in which one subexpression is a blocked `get` will always be able to take a step under one of the three application rules, but not all thread interleavings will be explored. The speed boost we get from that comes at the price of modeling only a less realistic class of implementations in which parallel evaluation is ``lockstep''. 36 | 37 | ### Version requirements 38 | 39 | The code has been tested under [various versions of Racket](https://travis-ci.org/lkuper/lvar-semantics). Other versions may also work. 40 | 41 | ### Building and running 42 | 43 | Running `make all` in this directory will build all the lambdaLVar languages and run their test suites, using both reduction relations. Be warned: in the test suite for the `lambdaLVar-nat` language, there's one particular that runs so slowly under `slow-rr` that we put it in a "slow test suite" by itself. (To avoid the slow test, simply run `make`.) 44 | 45 | ``` 46 | Running metafunction tests...All 57 tests passed. 47 | cpu time: 14 real time: 13 gc time: 0 48 | Running test suite with fast-rr...All 19 tests passed. 49 | cpu time: 127 real time: 128 gc time: 16 50 | Running test suite with slow-rr...All 19 tests passed. 51 | cpu time: 486 real time: 486 gc time: 8 52 | Running slow test suite with fast-rr...One test passed. 53 | cpu time: 153 real time: 154 gc time: 4 54 | Running slow test suite with slow-rr...One test passed. 55 | cpu time: 365914 real time: 365523 gc time: 7949 56 | ``` 57 | 58 | The slow test takes several orders of magnitude longer when run with `slow-rr` than with `fast-rr`. Stepping through the test manually using `traces` finds 64 terms for the slow version, and 15 for the 59 | fast version. 60 | 61 | [lambdaLVar-paper]: http://www.cs.indiana.edu/~lkuper/papers/lvars-fhpc13.pdf 62 | 63 | [eval-contexts]: http://www.ccs.neu.edu/racket/pubs/tcs92-fh.pdf 64 | 65 | [racket-list-message]: http://lists.racket-lang.org/users/archive/2012-July/053000.html 66 | 67 | [define-judgment-form]: http://docs.racket-lang.org/redex/Other_Relations.html#%28form._%28%28lib._redex/reduction-semantics..rkt%29._define-judgment-form%29%29 68 | 69 | [traces]: http://docs.racket-lang.org/redex/GUI.html?q=traces#%28def._%28%28lib._redex/gui..rkt%29._traces%29%29 70 | 71 | [k-framework]: http://k-framework.org 72 | -------------------------------------------------------------------------------- /lambdaLVar/lambdaLVar.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;; A Redex model of the lambdaLVar language. Mentions of "the TR" in 3 | ;; this document refer to 4 | ;; http://www.cs.indiana.edu/cgi-bin/techreports/TRNNN.cgi?trnum=TR702 5 | 6 | (provide define-lambdaLVar-language) 7 | 8 | (define-syntax-rule (define-lambdaLVar-language name lub-op lattice-values ...) 9 | (begin 10 | (require redex/reduction-semantics) 11 | (require srfi/1) 12 | 13 | (provide slow-rr 14 | fast-rr 15 | exists-d 16 | lub 17 | leq 18 | lubstore 19 | lubstore-helper 20 | store-dom 21 | store-lookup 22 | store-update 23 | incomp 24 | valid 25 | store-dom-diff 26 | store-top? 27 | top? 28 | subst 29 | rename-locs) 30 | 31 | (define-language name 32 | ;; Configurations, on which the reduction relation is defined. 33 | (Config (S e) Error) 34 | 35 | ;; Expressions. 36 | (e x 37 | v 38 | (e e) 39 | (get e e) 40 | (put e e) 41 | new 42 | 43 | ;; These don't appear in the grammar in the TR, because they 44 | ;; immediately desugar to application and lambda. 45 | (let ((x e)) e) 46 | (let par ((x e) (x e)) e)) 47 | 48 | ;; Values. 49 | (v l 50 | Q 51 | (lambda (x) e)) 52 | 53 | ;; Threshold set literals. A threshold set is the set we pass to a 54 | ;; `get` expression that specifies a non-empty, pairwise 55 | ;; incompatible subset of the state space of the location being 56 | ;; queried. The grammar allows empty threshold sets, as well, 57 | ;; because those are the return value of `put`. 58 | 59 | ;; Incidentally, under this grammar, (Top) and (Bot) are threshold 60 | ;; sets. (Bot) makes sense, but (Top) is nonsensical -- a program 61 | ;; that passed (Top) as a threshold would block forever. 62 | ;; Nevertheless, the grammar admits it. 63 | (Q (d (... ...))) 64 | 65 | ;; Stores. A store is either a set of LVars (that is, a finite 66 | ;; partial mapping from locations to StoreVals) or a 67 | ;; distinguished value TopS. 68 | (S (LVar (... ...)) TopS) 69 | (LVar (l StoreVal)) 70 | 71 | ;; Lattice elements, representing the state of an LVar. We 72 | ;; assume Top and Bot lattice elements in addition to the 73 | ;; user-specified lattice-values. A StoreVal can be any element 74 | ;; of the lattice except Top (see Definition 1 in the TR). 75 | (d Top StoreVal) 76 | (StoreVal lattice-values ... Bot) 77 | 78 | ;; Ranges of a couple of metafunctions. 79 | (StoreVal/lookupfailed StoreVal lookupfailed) 80 | (Bool #t #f) 81 | (d/Bool d Bool) 82 | 83 | (x variable-not-otherwise-mentioned) 84 | (l variable-not-otherwise-mentioned)) 85 | 86 | ;; Because our evaluation relation is defined using inference rules 87 | ;; rather than with evaluation contexts, we have to use Redex's 88 | ;; define-judgment-form feature rather than the reduction-relation 89 | ;; feature. (In order to take the evaluation context approach, we 90 | ;; would need multiple-hole contexts, which Redex doesn't support.) 91 | ;; We can, however, wrap the small-step relation in 92 | ;; 'reduction-relation'. 93 | 94 | (define slow-rr 95 | (reduction-relation 96 | name 97 | (--> Config_1 Config_2 98 | (judgment-holds (small-step-slow Config_1 Config_2))))) 99 | 100 | (define fast-rr 101 | (reduction-relation 102 | name 103 | (--> Config_1 Config_2 104 | (judgment-holds (small-step-fast Config_1 Config_2))))) 105 | 106 | ;; NB: in Racket v5.2, `define-judgment-form` doesn't let you use 107 | ;; `side-condition`; you have to use `where`, which does pattern 108 | ;; matching. So for now, we have to define metafunctions for all our 109 | ;; side conditions and then pattern-match with `(where #t (call to 110 | ;; metafunction ...))`. This should be fixed in the most recent 111 | ;; release. 112 | 113 | ;; Reduction rules shown in Figure 4 of the TR, minus E-Refl and 114 | ;; E-ReflErr. We'll patch the missing reflexive rules in the extended 115 | ;; reduction relations defined below this one. 116 | (define-judgment-form name 117 | #:mode (small-step-base I O) 118 | #:contract (small-step-base Config Config) 119 | 120 | [(small-step-base (S (e_1 e_2)) 121 | ((lubstore S_11 S_2) (e_111 e_22))) 122 | (small-step-base (S e_1) (S_1 e_11)) 123 | (small-step-base (S e_2) (S_2 e_22)) 124 | ;; Handles renaming: any new locations created between S and S_1 125 | ;; must have names unique from those created between S and S_2. 126 | ;; See `rename-locs` for more details. 127 | (where (S_11 e_111) (rename-locs (S_1 e_11) S_2 S)) 128 | (where #f (store-top? (lubstore S_11 S_2))) 129 | "E-ParApp"] 130 | 131 | [(small-step-base (S ((lambda (x) e) v)) 132 | (S (subst x v e))) 133 | "E-Beta"] 134 | 135 | [(small-step-base (S new) 136 | ((store-update S l Bot) l)) 137 | (where l (variable-not-in-store S)) 138 | "E-New"] 139 | 140 | [(small-step-base (S (put e_1 e_2)) 141 | (S_1 (put e_11 e_2))) 142 | (small-step-base (S e_1) (S_1 e_11)) 143 | "E-Put-1"] 144 | 145 | [(small-step-base (S (put e_1 e_2)) 146 | (S_2 (put e_1 e_22))) 147 | (small-step-base (S e_2) (S_2 e_22)) 148 | "E-Put-2"] 149 | 150 | [(small-step-base (S (put l (d_2))) 151 | ((store-update S l d_2) ())) 152 | (where d_1 (store-lookup S l)) 153 | (where #f (top? (lub d_1 d_2))) 154 | "E-PutVal"] 155 | 156 | [(small-step-base (S (get e_1 e_2)) 157 | (S_1 (get e_11 e_2))) 158 | (small-step-base (S e_1) (S_1 e_11)) 159 | "E-Get-1"] 160 | 161 | [(small-step-base (S (get e_1 e_2)) 162 | (S_2 (get e_1 e_22))) 163 | (small-step-base (S e_2) (S_2 e_22)) 164 | "E-Get-2"] 165 | 166 | [(small-step-base (S (get l Q)) 167 | (S (d_1))) 168 | (where d_2 (store-lookup S l)) 169 | (where #t (incomp Q)) 170 | (where #t (valid Q)) 171 | (where d_1 (exists-d d_2 Q)) 172 | "E-GetVal"] 173 | 174 | 175 | [(small-step-base (S (let ((x_1 e_1)) e_2)) 176 | (S ((lambda (x_1) e_2) e_1))) 177 | "Desugaring of let"] 178 | 179 | [(small-step-base (S (let par ((x_1 e_1) (x_2 e_2)) e_3)) 180 | (S (((lambda (x_1) (lambda (x_2) e_3)) e_1) e_2))) 181 | "Desugaring of let par"] 182 | 183 | [(small-step-base (S (e_1 e_2)) 184 | Error) 185 | (small-step-base (S e_1) Error) 186 | "E-AppErr-1"] 187 | 188 | [(small-step-base (S (e_1 e_2)) 189 | Error) 190 | (small-step-base (S e_2) Error) 191 | "E-AppErr-2"] 192 | 193 | [(small-step-base (S (e_1 e_2)) 194 | Error) 195 | (small-step-base (S e_1) (S_1 e_11)) 196 | (small-step-base (S e_2) (S_2 e_22)) 197 | (where (S_11 e_111) (rename-locs (S_1 e_11) S_2 S)) 198 | (where #t (store-top? (lubstore S_11 S_2))) 199 | "E-ParAppErr"] 200 | 201 | [(small-step-base (S (put l (d_2))) 202 | Error) 203 | (where d_1 (store-lookup S l)) 204 | (where #t (top? (lub d_1 d_2))) 205 | "E-PutValErr"]) 206 | 207 | ;; Because we left out the E-Refl and E-ReflErr rules from our 208 | ;; semantics, we have to add two new rules, E-App-1 and E-App-2, by 209 | ;; which parallel application expressions may take a step even if only 210 | ;; one of their subexpressions can take a step. This is the simplest 211 | ;; way we know of to patch the missing reflexive rules, but 212 | ;; unfortunately, it runs really slowly Hence the name of this 213 | ;; relation. 214 | (define-extended-judgment-form name small-step-base 215 | #:mode (small-step-slow I O) 216 | #:contract (small-step-slow Config Config) 217 | 218 | [(small-step-slow (S (e_1 e_2)) (S_1 (e_11 e_2))) 219 | (small-step-slow (S e_1) (S_1 e_11)) 220 | (where #f (store-top? (lubstore S S_1))) 221 | "E-App-1"] ;; only reduce left term 222 | 223 | [(small-step-slow (S (e_1 e_2)) 224 | (S_2 (e_1 e_22))) 225 | (small-step-slow (S e_2) (S_2 e_22)) 226 | (where #f (store-top? (lubstore S S_2))) 227 | "E-App-2"] ;; only reduce right term 228 | ) 229 | 230 | ;; In this version, we again patch the missing reflexive rules, but 231 | ;; this time, in E-App-1 and E-App-2, the subexpression that is not 232 | ;; taking a step must be a value. We also add an E-GetValBlock rule, 233 | ;; which allows a blocked get expression to step to itself. This is 234 | ;; This version is much faster in Redex than `small-step-slow`. 235 | (define-extended-judgment-form name small-step-base 236 | #:mode (small-step-fast I O) 237 | #:contract (small-step-fast Config Config) 238 | 239 | [(small-step-fast (S (e_1 v)) 240 | (S_1 (e_11 v))) 241 | (small-step-fast (S e_1) (S_1 e_11)) 242 | (where #f (store-top? (lubstore S S_1))) 243 | "E-App-1"] ;; only reduce left term; right term is a value 244 | 245 | [(small-step-fast (S (v e_2)) 246 | (S_2 (v e_22))) 247 | (small-step-fast (S e_2) (S_2 e_22)) 248 | (where #f (store-top? (lubstore S S_2))) 249 | "E-App-2"] ;; only reduce right term; left term is a value 250 | 251 | ;; Premises 1, 2, and 3 of E-GetVal hold, but there does not exist a 252 | ;; d_1 in Q such that (leq d_1 d_2), so premises 4 and 5 do not 253 | ;; (both) hold. 254 | [(small-step-fast (S (get l Q)) 255 | (S (get l Q))) 256 | (where d_2 (store-lookup S l)) 257 | (where #t (incomp Q)) 258 | (where #t (valid Q)) 259 | (where #f (exists-d d_2 Q)) 260 | "E-GetValBlock"]) 261 | 262 | ;; Some convenience functions: LVar accessors and constructor. 263 | 264 | (define-metafunction name 265 | lvloc : LVar -> l 266 | [(lvloc LVar) ,(first (term LVar))]) 267 | 268 | (define-metafunction name 269 | lvstate : LVar -> StoreVal 270 | [(lvstate LVar) ,(second (term LVar))]) 271 | 272 | (define-metafunction name 273 | build-lv : l StoreVal -> LVar 274 | [(build-lv l StoreVal) 275 | (l StoreVal)]) 276 | 277 | (define-metafunction name 278 | store-dom : S -> (l (... ...)) 279 | [(store-dom ()) ()] 280 | [(store-dom ((l_1 StoreVal_1) (l_2 StoreVal_2) (... ...))) 281 | ,(cons (term l_1) (term (store-dom ((l_2 StoreVal_2) (... ...)))))]) 282 | 283 | ;; Return a list of locations in dom(S_1) that are not in dom(S_2). 284 | (define-metafunction name 285 | store-dom-diff : S S -> (l (... ...)) 286 | [(store-dom-diff S_1 S_2) 287 | ,(lset-difference equal? 288 | (term (store-dom S_1)) 289 | (term (store-dom S_2)))]) 290 | 291 | ;; Rename locations so threads don't conflict. 292 | (define-metafunction name 293 | rename-locs : (S e) S S -> (S e) 294 | [(rename-locs (S_1 e_11) S_2 S) 295 | ;; Any new locations created between S and S_1 need to be given 296 | ;; names unique from those created between S and S_2. That's what 297 | ;; this does. 298 | 299 | ;; For each location created between S and S_1 (that is, 300 | ;; (store-dom-diff S_1 S)), we generate a fresh variable not 301 | ;; appearing in the set of locations created between S and S_2 302 | ;; (that is, (store-dom-diff S_2 S)) and capture-avoidingly 303 | ;; substitute it into the configuration (S_1 e_11). 304 | ,(fold-right 305 | (lambda (loc config) 306 | (term (subst 307 | ,loc 308 | ,(variable-not-in (term (store-dom-diff S_2 S)) 309 | (term ,loc)) 310 | ,config))) 311 | (term (S_1 e_11)) 312 | (term (store-dom-diff S_1 S)))]) 313 | 314 | ;; The greatest element of the store lattice is any store in which 315 | ;; some location is bound to Top. 316 | (define-metafunction name 317 | store-top? : S -> Bool 318 | [(store-top? TopS) ,#t] 319 | [(store-top? S) ,#f]) 320 | 321 | (define-metafunction name 322 | top? : d -> Bool 323 | [(top? Top) ,#t] 324 | [(top? d) ,#f]) 325 | 326 | ;; N.B.: The lub of d_1 and d_2 is the element d_3 such that: 327 | ;; -- (leq d_1 d_3) 328 | ;; -- (leq d_2 d_3) 329 | ;; -- for all d_4 s.t. (leq d_1 d_4) and (leq d_2 d_4), (leq d_3 d_4). 330 | ;; 331 | ;; But we can't get Redex to compute that, so instead, we ask the user 332 | ;; to provide lub, then compute leq in terms of lub. 333 | ;; 334 | ;; Intended to be extended by a user-provided metafunction/extension. 335 | (define-metafunction name 336 | lub : d d -> d 337 | [(lub Bot d_2) d_2] 338 | [(lub d_1 Bot) d_1] 339 | [(lub Top d_2) Top] 340 | [(lub d_1 Top) Top] 341 | [(lub d_1 d_2) ,(lub-op (term d_1) (term d_2))]) 342 | 343 | ;; Defined in terms of lub. 344 | (define-metafunction name 345 | leq : d d -> Bool 346 | [(leq Bot d_2) ,#t] 347 | [(leq d_1 Bot) ,#f] 348 | [(leq Top d_2) ,#f] 349 | [(leq d_1 Top) ,#t] 350 | 351 | ;; If d_1 = d_2, then (leq d_1 d_2). 352 | [(leq d_1 d_2) ,#t 353 | (side-condition (equal? (term d_1) (term d_2)))] 354 | 355 | ;; If (lub d_1 d_2) = d_2, then (leq d_1 d_2). 356 | [(leq d_1 d_2) ,#t 357 | (side-condition (equal? (term (lub d_1 d_2)) (term d_2)))] 358 | 359 | ;; If (lub d_1 d_2) = d_1, then (not (leq d_1 d_2)). (This assumes 360 | ;; that d_1 != d_2, but we've already covered the case where they're 361 | ;; equal.) 362 | [(leq d_1 d_2) ,#f 363 | (side-condition (equal? (term (lub d_1 d_2)) (term d_1)))] 364 | 365 | ;; The only case left: (lub d_1 d_2) = d_3, where d_3 is greater 366 | ;; than both d_1 and d_2. In this case, (not (leq d_1 d_2)). 367 | [(leq d_1 d_2) ,#f]) 368 | 369 | ;; Definition 3 in the TR. 370 | (define-metafunction name 371 | lubstore : S S -> S 372 | [(lubstore S_1 ()) S_1] 373 | [(lubstore () S_2) S_2] 374 | 375 | ;; The TopS case. 376 | [(lubstore S_1 S_2) 377 | TopS 378 | (where #t (lubstore-TopS? S_1 S_2))] 379 | 380 | ;; Otherwise, (lubstore S_1 S_2) is the store S such that (store-dom 381 | ;; S) = (union (store-dom S_1) (store-dom S_2)), and, for all l in 382 | ;; (store-dom S), 383 | 384 | ;; S(l) = (lub S_1(l) S_2(l)) 385 | ;; if (member? l (intersection (store-dom S_1) (store_dom S_2))) 386 | ;; S(l) = S_1(l) if (not (member? l (store-dom S_2))) 387 | ;; S(l) = S_2(l) if (not (member? l (store-dom S_1))) 388 | 389 | [(lubstore S_1 S_2) 390 | ;; Get the union of labels from S_1 and S_2 391 | ,(let* ([locs (lset-union equal? 392 | (term (store-dom S_1)) 393 | (term (store-dom S_2)))] 394 | ;; For each label in the list, take the lub of S_1(l) and S_2(l), 395 | [lubs (term ,(map (lambda (loc) 396 | (term (lubstore-helper S_1 S_2 ,loc))) 397 | locs))]) 398 | ;; Put labels back together with their lubs. 399 | (zip locs lubs))]) 400 | 401 | (define-metafunction name 402 | lubstore-TopS? : S S -> Bool 403 | [(lubstore-TopS? S_1 S_2) 404 | ;; (lubstore-TopS? S_1 S_2) == #t iff there exists some l in 405 | ;; (intersection (store-dom S_1) (store-dom S_2)) such that (lub 406 | ;; (store-lookup S_1 l) (store-lookup S_2 l)) == Top. 407 | 408 | ;; First, get the intersection of the domains of S_1 and S_2. 409 | ,(let* ([locs (lset-intersection equal? 410 | (term (store-dom S_1)) 411 | (term (store-dom S_2)))] 412 | ;; For each such label l, take the lub of S_1(l) and S_2(l). 413 | [lubs (term ,(map (lambda (loc) 414 | (term (lubstore-helper S_1 S_2 ,loc))) 415 | locs))]) 416 | ;; If any lub in the resulting list is Top, return #t; 417 | ;; otherwise, return #f. 418 | (if (member (term Top) lubs) 419 | #t 420 | #f))]) 421 | 422 | ;; Given a store location `l` and two stores `S_1` and `S_2`, return 423 | ;; the lub of S_1(l) and S_2(l). We know that every l this function 424 | ;; gets is going to be in the domain of either S_1 or S_2 or both. 425 | (define-metafunction name 426 | lubstore-helper : S S l -> d 427 | [(lubstore-helper S_1 S_2 l) 428 | ,(let ([d_1 (term (store-lookup S_1 l))] 429 | [d_2 (term (store-lookup S_2 l))]) 430 | (cond 431 | [(equal? d_1 (term lookupfailed)) d_2] 432 | [(equal? d_2 (term lookupfailed)) d_1] 433 | [else (term (lub ,d_1 ,d_2))]))]) 434 | 435 | (define-metafunction name 436 | variable-not-in-store : S -> l 437 | [(variable-not-in-store S) 438 | ,(variable-not-in (term S) (term l))]) 439 | 440 | (define-metafunction name 441 | store-lookup : S l -> StoreVal/lookupfailed 442 | [(store-lookup S l) ,(let ([lv (assq (term l) (term S))]) 443 | (if lv 444 | (term (lvstate ,lv)) 445 | (term lookupfailed)))]) 446 | 447 | ;; Actually handles both updates and extensions. 448 | (define-metafunction name 449 | store-update : S l StoreVal -> S 450 | [(store-update () l StoreVal) ((l StoreVal))] 451 | [(store-update ((l_2 StoreVal_2) (l_3 StoreVal_3) (... ...)) l StoreVal) 452 | ,(if (equal? (term l) (term l_2)) 453 | ;; The side conditions on E-PutVal should ensure that the 454 | ;; call to store-update only happens when the lub of the 455 | ;; old and new values is non-Top. 456 | (cons (term (l_2 (lub StoreVal StoreVal_2))) 457 | (term ((l_3 StoreVal_3) (... ...)))) 458 | (cons (term (l_2 StoreVal_2)) 459 | (term (store-update ((l_3 StoreVal_3) (... ...)) l StoreVal))))]) 460 | 461 | ;; The second condition on the E-GetVal rule. For any two distinct 462 | ;; elements in Q, the lub of them is Top. 463 | (define-metafunction name 464 | incomp : Q -> Bool 465 | [(incomp ()) ,#t] 466 | [(incomp (d)) ,#t] 467 | [(incomp (d_1 d_2)) ,(equal? (term (lub d_1 d_2)) (term Top))] 468 | [(incomp (d_1 d_2 d_3 (... ...))) 469 | ,(and (equal? (term (lub d_1 d_2)) (term Top)) 470 | (term (incomp (d_1 d_3 (... ...)))) 471 | (term (incomp (d_2 d_3 (... ...)))))]) 472 | 473 | ;; The third condition on the E-GetVal rule. 474 | (define-metafunction name 475 | valid : Q -> Bool 476 | [(valid Q) ,(not (null? (term Q)))]) 477 | 478 | ;; The fourth and fifth premises of the E-GetVal rule. If there 479 | ;; exists a d_1 that is a member of Q and is less than or equal to 480 | ;; d_2, returns that d_1. Otherwise, returns #f. 481 | (define-metafunction name 482 | exists-d : d Q -> d/Bool 483 | 484 | ;; If Q is empty, then there definitely isn't a d_1. 485 | [(exists-d d_2 ()) #f] 486 | 487 | ;; If the first item in Q is less than d_2, return it. 488 | [(exists-d d_2 (d_11 d_12 (... ...))) d_11 489 | (where #t (leq d_11 d_2))] 490 | 491 | ;; Otherwise, check the rest. 492 | [(exists-d d_2 (d_11 d_12 (... ...))) (exists-d d_2 (d_12 (... ...))) 493 | (where #f (leq d_11 d_2))]) 494 | 495 | ;; subst and subst-vars: capture-avoiding substitution, due to 496 | ;; redex.racket-lang.org/lam-v.html. 497 | 498 | (define-metafunction name 499 | subst : x any any -> any 500 | ;; 1. x_1 bound, so don't continue in lambda body 501 | [(subst x_1 any_1 (lambda (x_2 (... ...) x_1 x_3 (... ...)) any_2)) 502 | (lambda (x_2 (... ...) x_1 x_3 (... ...)) any_2) 503 | (side-condition (not (member (term x_1) (term (x_2 (... ...))))))] 504 | 505 | ;; 2. general purpose capture-avoiding case 506 | [(subst x_1 any_1 (lambda (x_2 (... ...)) any_2)) 507 | (lambda (x_new (... ...)) 508 | (subst x_1 any_1 (subst-vars (x_2 x_new) (... ...) any_2))) 509 | (where (x_new (... ...)) ,(variables-not-in (term (x_1 any_1 any_2)) 510 | (term (x_2 (... ...)))))] 511 | 512 | ;; 3. replace x_1 with e_1 513 | [(subst x_1 any_1 x_1) any_1] 514 | 515 | ;; 4. x_1 and x_2 are different, so don't replace 516 | [(subst x_1 any_1 x_2) x_2] 517 | 518 | ;; the last cases cover all other expressions 519 | [(subst x_1 any_1 (any_2 (... ...))) 520 | ((subst x_1 any_1 any_2) (... ...))] 521 | [(subst x_1 any_1 any_2) any_2]) 522 | 523 | (define-metafunction name 524 | subst-vars : (x any) (... ...) any -> any 525 | [(subst-vars (x_1 any_1) x_1) any_1] 526 | [(subst-vars (x_1 any_1) (any_2 (... ...))) 527 | ((subst-vars (x_1 any_1) any_2) (... ...))] 528 | [(subst-vars (x_1 any_1) any_2) any_2] 529 | [(subst-vars (x_1 any_1) (x_2 any_2) (... ...) any_3) 530 | (subst-vars (x_1 any_1) 531 | (subst-vars (x_2 any_2) (... ...) any_3))] 532 | [(subst-vars any) any]))) 533 | 534 | 535 | -------------------------------------------------------------------------------- /lambdaLVar/nat.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (module language racket 4 | (require "lambdaLVar.rkt") 5 | (define-lambdaLVar-language lambdaLVar-nat max natural)) 6 | 7 | (module test-suite racket 8 | (require redex/reduction-semantics) 9 | (require (submod ".." language)) 10 | (require srfi/1) 11 | (require "test-helpers.rkt") 12 | 13 | (provide 14 | test-fast 15 | test-all) 16 | 17 | (define (test-fast) 18 | (display "Running metafunction tests...") 19 | (flush-output) 20 | (time (meta-test-suite)) 21 | 22 | (display "Running test suite with fast-rr...") 23 | (flush-output) 24 | (time (program-test-suite fast-rr)) 25 | 26 | (display "Running test suite with slow-rr...") 27 | (flush-output) 28 | (time (program-test-suite slow-rr)) 29 | 30 | (display "Running slow test suite with fast-rr...") 31 | (flush-output) 32 | (time (slow-program-test-suite fast-rr))) 33 | 34 | (define (test-all) 35 | (test-fast) 36 | (display "Running slow test suite with slow-rr...") 37 | (flush-output) 38 | (time (slow-program-test-suite slow-rr))) 39 | 40 | ;; Test suite 41 | 42 | (define (meta-test-suite) 43 | 44 | (test-equal 45 | (term (exists-d 6 ())) 46 | (term #f)) 47 | 48 | (test-equal 49 | (term (exists-d 6 (3))) 50 | (term 3)) 51 | 52 | (test-equal 53 | (term (exists-d 6 (9))) 54 | (term #f)) 55 | 56 | (test-equal 57 | (term (exists-d 3 (3))) 58 | (term 3)) 59 | 60 | ;; These next three are unrealistic for this lattice because Q would 61 | ;; be a singleton set, but it's here to exercise exists-d. 62 | (test-equal 63 | (term (exists-d 6 (7 8 9))) 64 | (term #f)) 65 | 66 | (test-equal 67 | (term (exists-d 6 (7 8 9 6))) 68 | (term 6)) 69 | 70 | (test-equal 71 | (term (exists-d 6 (7 8 9 5))) 72 | (term 5)) 73 | 74 | (test-equal 75 | (term (lub Bot Bot)) 76 | (term Bot)) 77 | 78 | (test-equal 79 | (term (lub Top 3)) 80 | (term Top)) 81 | 82 | (test-equal 83 | (term (lub 3 4)) 84 | (term 4)) 85 | 86 | (test-equal 87 | (term (lub 3 3)) 88 | (term 3)) 89 | 90 | (test-equal 91 | (term (leq 3 3)) 92 | (term #t)) 93 | 94 | (test-equal 95 | (term (leq Top 3)) 96 | (term #f)) 97 | 98 | (test-equal 99 | (term (leq 3 Top)) 100 | (term #t)) 101 | 102 | (test-equal 103 | (term (leq Bot 3)) 104 | (term #t)) 105 | 106 | (test-equal 107 | (term (leq 3 Bot)) 108 | (term #f)) 109 | 110 | (test-equal 111 | (term (leq Top Bot)) 112 | (term #f)) 113 | 114 | (test-equal 115 | (term (leq Bot Top)) 116 | (term #t)) 117 | 118 | (test-equal 119 | (term (leq 3 4)) 120 | (term #t)) 121 | 122 | (test-equal 123 | (term (leq 4 3)) 124 | (term #f)) 125 | 126 | (test-equal 127 | (term (store-dom ((l1 4) (l2 5) (l3 Bot)))) 128 | (term (l1 l2 l3))) 129 | 130 | (test-equal 131 | (stores-equal-modulo-perms? 132 | (term (lubstore ((l1 5) 133 | (l2 6) 134 | (l3 7)) 135 | ((l2 2) 136 | (l4 9)))) 137 | (term ((l1 5) 138 | (l3 7) 139 | (l2 6) 140 | (l4 9)))) 141 | #t) 142 | 143 | (test-equal 144 | (stores-equal-modulo-perms? 145 | (term (lubstore ((l1 5) 146 | (l2 6) 147 | (l3 7)) 148 | ((l1 5) 149 | (l4 9) 150 | (l2 4)))) 151 | (term ((l3 7) 152 | (l1 5) 153 | (l4 9) 154 | (l2 6)))) 155 | #t) 156 | 157 | (test-equal 158 | (stores-equal-modulo-perms? 159 | (term (lubstore ((l1 Bot) 160 | (l2 6) 161 | (l3 Bot)) 162 | ((l1 5) 163 | (l4 9) 164 | (l2 4)))) 165 | (term ((l3 Bot) 166 | (l1 5) 167 | (l4 9) 168 | (l2 6)))) 169 | #t) 170 | 171 | (test-equal 172 | (term (lubstore-helper ((l1 5)) 173 | () 174 | l1)) 175 | (term 5)) 176 | 177 | (test-equal 178 | (term (lubstore-helper ((l1 5)) 179 | ((l1 6)) 180 | l1)) 181 | (term 6)) 182 | 183 | (test-equal 184 | (term (lubstore-helper ((l1 5) 185 | (l2 6) 186 | (l3 7)) 187 | ((l2 2) 188 | (l4 9)) 189 | l2)) 190 | (term 6)) 191 | 192 | (test-equal 193 | (lset= equal? 194 | (lset-union equal? (term ()) (term ())) 195 | (term ())) 196 | #t) 197 | 198 | (test-equal 199 | (lset= equal? 200 | (lset-union equal? (term ()) (term (l1))) 201 | (term (l1))) 202 | #t) 203 | 204 | (test-equal 205 | (lset= equal? 206 | (lset-union equal? (term (l1 l2)) (term (l1 l2 l3))) 207 | (term (l1 l2 l3))) 208 | #t) 209 | 210 | (test-equal 211 | (lset= equal? 212 | (lset-union equal? (term (l2 l3)) (term (l1 l4))) 213 | (term (l2 l3 l1 l4))) 214 | #t) 215 | 216 | (test-equal 217 | (lset= equal? 218 | (lset-union equal? (term (l2 l3)) (term (l1 l2 l4))) 219 | (term (l3 l1 l2 l4))) 220 | #t) 221 | 222 | (test-equal 223 | (term (store-lookup ((l 2)) l)) 224 | (term 2)) 225 | 226 | (test-equal 227 | (term (store-update () l 4)) 228 | (term ((l 4)))) 229 | 230 | (test-equal 231 | (term (store-update ((l 3)) l 4)) 232 | (term ((l 4)))) 233 | 234 | (test-equal 235 | (term (store-update () l Bot)) 236 | (term ((l Bot)))) 237 | 238 | (test-equal 239 | (term (valid ())) 240 | #f) 241 | 242 | (test-equal 243 | (term (valid (3))) 244 | #t) 245 | 246 | (test-equal 247 | (term (valid (5 6 7))) 248 | #t) 249 | 250 | (test-equal 251 | (term (store-dom ())) 252 | (term ())) 253 | 254 | (test-equal 255 | (term (store-dom ((l 3) (l1 4)))) 256 | (term (l l1))) 257 | 258 | (test-equal 259 | (term (store-dom-diff ((l 3) (l1 4)) 260 | ((l 4) (l1 3)))) 261 | (term ())) 262 | 263 | (test-equal 264 | (term (store-dom-diff ((l 3)) 265 | ((l 4) (l1 3)))) 266 | (term ())) 267 | 268 | (test-equal 269 | (term (store-dom-diff ((l 4) (l1 3)) 270 | ((l 3)))) 271 | (term (l1))) 272 | 273 | (test-equal 274 | (term (store-dom-diff ((l 4)) 275 | ())) 276 | (term (l))) 277 | 278 | (test-equal 279 | (term (rename-locs (((l Bot)) 280 | (put l (3))) 281 | ((l 4)) 282 | ())) 283 | (term 284 | (((l1 Bot)) 285 | (put l1 (3))))) 286 | 287 | (test-equal 288 | (term (store-top? ())) 289 | (term #f)) 290 | 291 | (test-equal 292 | (term (store-top? ((l 3) (l1 4)))) 293 | (term #f)) 294 | 295 | (test-equal 296 | (term (store-top? TopS)) 297 | (term #t)) 298 | 299 | (test-equal 300 | (term (top? Top)) 301 | (term #t)) 302 | 303 | (test-equal 304 | (term (top? Bot)) 305 | (term #f)) 306 | 307 | (test-equal 308 | (term (top? 3)) 309 | (term #f)) 310 | 311 | (test-equal 312 | (cfgs-equal-modulo-perms? 313 | '(((l 4) (l1 3)) ()) 314 | '(((l1 3) (l 4)) ())) 315 | #t) 316 | 317 | (test-equal 318 | (cfgs-equal-modulo-perms? 319 | '(((l1 3) (l 4)) ()) 320 | '(((l1 3) (l 4)) (3))) 321 | #f) 322 | 323 | (test-equal 324 | (cfgs-equal-modulo-perms? 325 | '(((l 4) (l1 3)) ()) 326 | '(((l1 3) (l 4)) (3))) 327 | #f) 328 | 329 | (test-equal 330 | (cfgs-equal-modulo-perms? 331 | '(((l 3) (l1 4)) ()) 332 | '(((l1 3) (l 4)) ())) 333 | #f) 334 | 335 | (test-equal 336 | (term (subst l l1 (((l Bot)) 337 | (put l (3))))) 338 | (term (((l1 Bot)) 339 | (put l1 (3))))) 340 | 341 | (test-results)) 342 | 343 | (define (program-test-suite rr) 344 | 345 | ;; E-App-1 346 | (test-->> rr 347 | (term 348 | (() ;; empty store 349 | ((lambda (x_1) x_1) 350 | ((lambda (x_1) x_1) (lambda (x_2) x_2))))) 351 | (term 352 | (() 353 | (lambda (x_2) x_2)))) 354 | 355 | ;; E-App-2 356 | (test-->> rr 357 | (term 358 | (() ;; empty store 359 | (((lambda (x_1) x_1) (lambda (x_2) x_2)) 360 | (lambda (x_1) x_1)))) 361 | (term 362 | (() 363 | (lambda (x_1) x_1)))) 364 | 365 | ;; E-ParApp 366 | (test-->> rr 367 | (term 368 | (() ;; empty store 369 | (((lambda (x_1) x_1) (lambda (x_2) x_2)) 370 | ((lambda (x_1) x_1) (lambda (x_2) x_2))))) 371 | (term 372 | (() 373 | (lambda (x_2) x_2)))) 374 | 375 | ;; E-Beta 376 | (test-->> rr 377 | (term 378 | (() ;; empty store 379 | ((lambda (x_1) x_1) ()))) 380 | (term 381 | (() 382 | ()))) 383 | 384 | (test-->> rr 385 | (term 386 | (() ;; empty store 387 | ((lambda (x_1) x_1) (lambda (x_2) x_2)))) 388 | (term 389 | (() 390 | (lambda (x_2) x_2)))) 391 | 392 | ;; E-New 393 | (test-->> rr 394 | (term 395 | (((l 3)) 396 | new)) 397 | (term 398 | (((l 3) (l1 Bot)) 399 | l1))) 400 | 401 | (test-->> rr 402 | (term 403 | (((l 3) (l1 4)) 404 | new)) 405 | (term 406 | (((l 3) (l1 4) (l2 Bot)) 407 | l2))) 408 | 409 | ;; E-PutVal 410 | (test-->> rr 411 | (term 412 | (((l Bot)) 413 | (put l (3)))) 414 | (term 415 | (((l 3)) 416 | ()))) 417 | 418 | (test-->> rr 419 | (term 420 | (((l 2)) 421 | (put l (3)))) 422 | (term 423 | (((l 3)) 424 | ()))) 425 | 426 | ;; This should work because put just puts the max of the current value and the new value. 427 | (test-->> rr 428 | (term 429 | (((l 2)) 430 | (put l (1)))) 431 | (term 432 | (((l 2)) 433 | ()))) 434 | 435 | ;; let 436 | (test-->> rr 437 | (term 438 | (() ;; empty store 439 | (let ((x_1 (lambda (x_1) x_1))) 440 | (let ((x_2 (lambda (x_1) x_1))) 441 | (x_1 x_2))))) 442 | (term 443 | (() 444 | (lambda (x_1) x_1)))) 445 | 446 | ;; let par 447 | (test-->> rr 448 | (term 449 | (() ;; empty store 450 | (let par ((x_1 (lambda (x_1) x_1)) 451 | (x_2 (lambda (x_1) x_1))) 452 | (x_1 x_2)))) 453 | (term 454 | (() 455 | (lambda (x_1) x_1)))) 456 | 457 | ;; E-Beta + E-New 458 | (test-->> rr 459 | (term 460 | (() ;; empty store 461 | ((lambda (x) x) new))) 462 | (term 463 | (((l Bot)) 464 | l))) 465 | 466 | ;; let + E-New + E-PutVal + E-GetVal 467 | (test-->> rr 468 | (term 469 | (() ;; empty store 470 | (let ((x_1 new)) 471 | (let ((x_2 (put x_1 (3)))) 472 | (let ((x_3 (get x_1 (2)))) 473 | x_3))))) 474 | (term 475 | (((l 3)) 476 | (2)))) 477 | 478 | ;; let par + E-New + E-PutVal + E-GetVal 479 | (test-->> rr 480 | (term 481 | (() ;; empty store 482 | (let ((x_1 new)) 483 | (let par ((x_2 (put x_1 (2))) 484 | (x_3 (put x_1 (3)))) 485 | (get x_1 (2)))))) 486 | (term 487 | (((l 3)) 488 | (2)))) 489 | 490 | ;; Another aspect of E-PutVal's behavior 491 | (test-->> rr 492 | (term 493 | (() ;; empty store 494 | (let ((x_1 new)) 495 | (let ((x_2 (put x_1 (5)))) 496 | ;; This should just take the lub of the old and new 497 | ;; values, i.e., 5. 498 | (let ((x_3 (put x_1 (4)))) 499 | (get x_1 (5))))))) 500 | (term 501 | (((l 5)) 502 | (5)))) 503 | 504 | ;; E-PutValErr 505 | (test-->> rr 506 | (term 507 | (() ;; empty store 508 | (let ((x_1 new)) 509 | (let ((x_2 (put x_1 (Top)))) 510 | x_2)))) 511 | (term 512 | Error)) 513 | 514 | (test-->> rr 515 | #:equiv cfgs-equal-modulo-perms? 516 | (term 517 | (() 518 | (let par ([x_1 new] 519 | [x_2 new]) 520 | (let par ([x_3 (put x_1 (3))] 521 | [x_4 (put x_2 (4))]) 522 | (get x_2 (4)))))) 523 | 524 | ;; When we're using slow-rr, we can end up with a store 525 | ;; of ((l 3) (l1 4)) or a permutation thereof -- that 526 | ;; is, x_1 is allocated first, followed by x_2. When 527 | ;; we're using fast-rr, we always seem to get the 528 | ;; allocation in the opposite order. This is not 529 | ;; nondeterministic in the sense that the result of 530 | ;; reading x_2 is always the same, but it ends up at a 531 | ;; different location in the store. This is a hack to 532 | ;; account for that. 533 | (if (equal? rr slow-rr) 534 | (term 535 | (((l 3) 536 | (l1 4)) 537 | (4))) 538 | (term 539 | (((l 4) 540 | (l1 3)) 541 | (4)))) 542 | (term 543 | (((l 4) 544 | (l1 3)) 545 | (4)))) 546 | 547 | ;;let par put and get 548 | (test-->> rr 549 | (term 550 | (() ;; empty store 551 | (let ((x_1 new)) 552 | (let par ((x_2 (put x_1 (2))) 553 | (x_3 (get x_1 (2)))) 554 | (get x_1 (2)))))) 555 | (term 556 | (((l 2)) 557 | (2)))) 558 | 559 | (test-results)) 560 | 561 | ;; Warning: Passing `slow-rr` to this procedure will take 562 | ;; several orders of magnitude longer to finish than passing 563 | ;; `fast-rr`. 564 | (define (slow-program-test-suite rr) 565 | 566 | ;; let par + E-New + E-PutVal + E-GetVal + E-GetValBlock 567 | (test-->> rr 568 | (term 569 | (() ;; empty store 570 | (let ((x_1 new)) 571 | (let par 572 | ;; Gets stuck trying to get 4 out of x_1, then 573 | ;; unstuck after the other subexpression finishes. 574 | ((x_4 (let par ((x_2 (put x_1 (2))) 575 | (x_3 (put x_1 (3)))) 576 | (get x_1 (4)))) 577 | ;; Eventually puts 4 in x_1 after several dummy 578 | ;; beta-reductions. 579 | (x_5 ((lambda (x_2) 580 | ((lambda (x_2) 581 | ((lambda (x_2) 582 | ((lambda (x_2) 583 | ((lambda (x_2) 584 | (put x_1 (4))) ())) ())) ())) ())) ()))) 585 | x_4)))) 586 | (term 587 | (((l 4)) 588 | (4)))) 589 | (test-results))) 590 | 591 | (module test-fast racket 592 | (require (submod ".." test-suite)) 593 | (test-fast)) 594 | 595 | (module test-all racket 596 | (require (submod ".." test-suite)) 597 | (test-all)) 598 | 599 | 600 | -------------------------------------------------------------------------------- /lambdaLVar/natpair-ivars.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (module language racket 4 | (require redex/reduction-semantics) 5 | (require "lambdaLVar.rkt") 6 | 7 | (define-lambdaLVar-language lambdaLVar-natpair-ivars 8 | my-lub 9 | (natural natural) 10 | (natural Bot) 11 | (Bot natural)) 12 | 13 | ;; my-lub: A function that takes two pairs (they might be of the 14 | ;; form (natural natural), (natural Bot), or (Bot natural)) and 15 | ;; returns a pair that is their least upper bound. 16 | 17 | ;; Because they're IVars, we can only safely combine two pairs if 18 | ;; one of them has only the car filled in, and the other has only 19 | ;; the cadr filled in -- or if whatever they're filled in with is 20 | ;; the same. 21 | 22 | ;; assumes that a1 and a2 aren't both numbers, or if they are then 23 | ;; they're the same 24 | (define lub-helper 25 | (lambda (a1 a2) 26 | (cond 27 | [(and (number? a1) (number? a2) (equal? a1 a2)) a1] 28 | [(and (number? a1) (number? a2) (not (equal? a1 a2))) 29 | ;; If we get here, something's wrong 30 | (error "oops!")] 31 | [(number? a1) a1] 32 | [(number? a2) a2] 33 | [else 'Bot]))) 34 | 35 | (define my-lub 36 | (lambda (p1 p2) 37 | (let ([car1 (car p1)] 38 | [cadr1 (cadr p1)] 39 | [car2 (car p2)] 40 | [cadr2 (cadr p2)]) 41 | (cond 42 | ;; nat/Bot, nat/Bot 43 | ;; nat/Bot, nat/nat 44 | ;; nat/nat, nat/Bot 45 | ;; nat/nat, nat/nat 46 | [(and (number? car1) (number? car2) (not (equal? car1 car2))) 47 | 'Top] 48 | 49 | ;; Bot/nat, Bot/nat 50 | ;; nat/nat, Bot/nat 51 | ;; Bot/nat, nat/nat 52 | [(and (number? cadr1) (number? cadr2) (not (equal? cadr1 cadr2))) 53 | 'Top] 54 | 55 | ;; nat/Bot, Bot/nat 56 | ;; Bot/nat, nat/Bot 57 | [else (list 58 | (lub-helper car1 car2) 59 | (lub-helper cadr1 cadr2))]))))) 60 | 61 | (module test-suite racket 62 | (require redex/reduction-semantics) 63 | (require (submod ".." language)) 64 | (require srfi/1) 65 | (require "test-helpers.rkt") 66 | 67 | (provide 68 | test-fast 69 | test-all) 70 | 71 | (define (test-fast) 72 | (display "Running metafunction tests...") 73 | (flush-output) 74 | (time (meta-test-suite)) 75 | 76 | (display "Running test suite with fast-rr...") 77 | (flush-output) 78 | (time (program-test-suite fast-rr)) 79 | 80 | (display "Running test suite with slow-rr...") 81 | (flush-output) 82 | (time (program-test-suite slow-rr)) 83 | 84 | (display "Running slow test suite with fast-rr...") 85 | (flush-output) 86 | (time (slow-program-test-suite fast-rr))) 87 | 88 | (define (test-all) 89 | (test-fast) 90 | (display "Running slow test suite with slow-rr...") 91 | (flush-output) 92 | (time (slow-program-test-suite slow-rr))) 93 | 94 | ;; Test suite 95 | 96 | (define (meta-test-suite) 97 | 98 | (test-equal 99 | (term (incomp ((3 Bot) (Bot 4)))) 100 | (term #f)) 101 | 102 | (test-equal 103 | (term (incomp ((2 Bot) (3 Bot) (Bot 4)))) 104 | (term #f)) 105 | 106 | (test-equal 107 | (term (incomp (Bot (4 Bot)))) 108 | (term #f)) 109 | 110 | (test-equal 111 | (term (incomp ((3 Bot) (4 Bot)))) 112 | (term #t)) 113 | 114 | (test-equal 115 | (term (incomp ((Bot 3) (Bot 4)))) 116 | (term #t)) 117 | 118 | (test-equal 119 | (term (incomp ((Bot 1) (Bot 2) (Bot 3) (Bot 4) (Bot 5)))) 120 | (term #t)) 121 | 122 | (test-equal 123 | (term (incomp ((Bot 1) (Bot 2) (Bot 3) (Bot 4) (Bot 5) (1 Bot)))) 124 | (term #f)) 125 | 126 | (test-equal 127 | (term (exists-d (Bot 1) ())) 128 | (term #f)) 129 | 130 | (test-equal 131 | (term (exists-d (Bot 6) (Bot))) 132 | (term Bot)) 133 | 134 | (test-equal 135 | (term (exists-d (Bot 6) ((Bot 9)))) 136 | (term #f)) 137 | 138 | (test-equal 139 | (term (exists-d (Bot 3) ((Bot 3)))) 140 | (term (Bot 3))) 141 | 142 | (test-equal 143 | (term (exists-d (Bot 6) ((Bot 7) (Bot 8) (Bot 9)))) 144 | (term #f)) 145 | 146 | (test-equal 147 | (term (exists-d (Bot 6) ((Bot 7) (Bot 8) (Bot 9) (Bot 6)))) 148 | (term (Bot 6))) 149 | 150 | (test-equal 151 | (term (exists-d (Bot 6) ((Bot 7) (Bot 8) (Bot 9) Bot))) 152 | (term Bot)) 153 | 154 | (test-equal 155 | (term (exists-d (6 6) ((Bot 7) (Bot 8) (Bot 9) (Bot 6)))) 156 | (term (Bot 6))) 157 | 158 | (test-equal 159 | (term (lub Bot Bot)) 160 | (term Bot)) 161 | 162 | (test-equal 163 | (term (lub Top (Bot 3))) 164 | (term Top)) 165 | 166 | (test-equal 167 | (term (lub (3 Bot) (Bot 4))) 168 | (term (3 4))) 169 | 170 | (test-equal 171 | (term (lub (3 3) (3 3))) 172 | (term (3 3))) 173 | 174 | (test-equal 175 | (term (leq (3 3) (3 3))) 176 | (term #t)) 177 | 178 | (test-equal 179 | (term (leq Top (3 3))) 180 | (term #f)) 181 | 182 | (test-equal 183 | (term (leq (3 3) Top)) 184 | (term #t)) 185 | 186 | (test-equal 187 | (term (leq Bot (3 3))) 188 | (term #t)) 189 | 190 | (test-equal 191 | (term (leq (3 3) Bot)) 192 | (term #f)) 193 | 194 | (test-equal 195 | (term (leq Top Bot)) 196 | (term #f)) 197 | 198 | (test-equal 199 | (term (leq Bot Top)) 200 | (term #t)) 201 | 202 | (test-equal 203 | (term (leq (Bot 3) (3 3))) 204 | (term #t)) 205 | 206 | (test-equal 207 | (term (leq (3 3) (Bot 3))) 208 | (term #f)) 209 | 210 | (test-equal 211 | (term (leq (3 3) (4 4))) 212 | (term #f)) 213 | 214 | (test-equal 215 | (term (leq (5 5) (4 4))) 216 | (term #f)) 217 | 218 | (test-equal 219 | (term (store-dom ((l1 (4 4)) (l2 (5 5)) (l3 Bot)))) 220 | (term (l1 l2 l3))) 221 | 222 | (test-equal 223 | (stores-equal-modulo-perms? 224 | (term (lubstore ((l1 (5 5)) 225 | (l2 (6 6)) 226 | (l3 (7 7))) 227 | ((l2 (6 6)) 228 | (l4 (9 9))))) 229 | (term ((l1 (5 5)) 230 | (l3 (7 7)) 231 | (l2 (6 6)) 232 | (l4 (9 9))))) 233 | #t) 234 | 235 | (test-equal 236 | (stores-equal-modulo-perms? 237 | (term (lubstore ((l1 (5 5)) 238 | (l2 (6 6)) 239 | (l3 (7 7))) 240 | ((l1 (5 5)) 241 | (l4 (9 9)) 242 | (l2 (6 6))))) 243 | (term ((l3 (7 7)) 244 | (l1 (5 5)) 245 | (l4 (9 9)) 246 | (l2 (6 6))))) 247 | #t) 248 | 249 | (test-equal 250 | (stores-equal-modulo-perms? 251 | (term (lubstore ((l1 Bot) 252 | (l2 (6 6)) 253 | (l3 Bot)) 254 | ((l1 (5 5)) 255 | (l4 (9 9)) 256 | (l2 (6 6))))) 257 | (term ((l3 Bot) 258 | (l1 (5 5)) 259 | (l4 (9 9)) 260 | (l2 (6 6))))) 261 | #t) 262 | 263 | (test-equal 264 | (term (lubstore-helper ((l1 (5 5))) 265 | () 266 | l1)) 267 | (term (5 5))) 268 | 269 | (test-equal 270 | (term (lubstore-helper ((l1 (Bot 6))) 271 | ((l1 (6 6))) 272 | l1)) 273 | (term (6 6))) 274 | 275 | (test-equal 276 | (term (lubstore-helper ((l1 (5 5)) 277 | (l2 (6 6)) 278 | (l3 (7 7))) 279 | ((l2 (6 6)) 280 | (l4 (9 9))) 281 | l2)) 282 | (term (6 6))) 283 | 284 | (test-equal 285 | (lset= equal? 286 | (lset-union equal? (term ()) (term ())) 287 | (term ())) 288 | #t) 289 | 290 | (test-equal 291 | (lset= equal? 292 | (lset-union equal? (term ()) (term (l1))) 293 | (term (l1))) 294 | #t) 295 | 296 | (test-equal 297 | (lset= equal? 298 | (lset-union equal? (term (l1 l2)) (term (l1 l2 l3))) 299 | (term (l1 l2 l3))) 300 | #t) 301 | 302 | (test-equal 303 | (lset= equal? 304 | (lset-union equal? (term (l2 l3)) (term (l1 l4))) 305 | (term (l2 l3 l1 l4))) 306 | #t) 307 | 308 | (test-equal 309 | (lset= equal? 310 | (lset-union equal? (term (l2 l3)) (term (l1 l2 l4))) 311 | (term (l3 l1 l2 l4))) 312 | #t) 313 | 314 | (test-equal 315 | (term (store-lookup ((l (2 2))) l)) 316 | (term (2 2))) 317 | 318 | (test-equal 319 | (term (store-update () l (4 4))) 320 | (term ((l (4 4))))) 321 | 322 | (test-equal 323 | (term (store-update ((l (Bot 4))) l (4 4))) 324 | (term ((l (4 4))))) 325 | 326 | (test-equal 327 | (term (store-update () l Bot)) 328 | (term ((l Bot)))) 329 | 330 | (test-equal 331 | (term (valid ())) 332 | #f) 333 | 334 | (test-equal 335 | (term (valid ((3 3)))) 336 | #t) 337 | 338 | (test-equal 339 | (term (valid ((5 5) (6 6) (7 7)))) 340 | #t) 341 | 342 | (test-equal 343 | (term (store-dom ())) 344 | (term ())) 345 | 346 | (test-equal 347 | (term (store-dom ((l (3 3)) (l1 (4 4))))) 348 | (term (l l1))) 349 | 350 | (test-equal 351 | (term (store-dom-diff ((l (3 3)) (l1 (4 4))) 352 | ((l (4 4)) (l1 (3 3))))) 353 | (term ())) 354 | 355 | (test-equal 356 | (term (store-dom-diff ((l (3 3))) 357 | ((l (4 4)) (l1 (3 3))))) 358 | (term ())) 359 | 360 | (test-equal 361 | (term (store-dom-diff ((l (4 4)) (l1 (3 3))) 362 | ((l (3 3))))) 363 | (term (l1))) 364 | 365 | (test-equal 366 | (term (store-dom-diff ((l (4 4))) 367 | ())) 368 | (term (l))) 369 | 370 | (test-equal 371 | (term (rename-locs (((l Bot)) 372 | (put l ((3 3)))) 373 | ((l (4 4))) 374 | ())) 375 | (term 376 | (((l1 Bot)) 377 | (put l1 ((3 3)))))) 378 | 379 | (test-equal 380 | (term (store-top? ())) 381 | (term #f)) 382 | 383 | (test-equal 384 | (term (store-top? ((l (3 3)) (l1 (4 4))))) 385 | (term #f)) 386 | 387 | (test-equal 388 | (term (store-top? TopS)) 389 | (term #t)) 390 | 391 | (test-equal 392 | (term (top? Top)) 393 | (term #t)) 394 | 395 | (test-equal 396 | (term (top? Bot)) 397 | (term #f)) 398 | 399 | (test-equal 400 | (term (top? (3 3))) 401 | (term #f)) 402 | 403 | (test-equal 404 | (cfgs-equal-modulo-perms? 405 | '(((l (4 4)) (l1 (3 3))) ()) 406 | '(((l1 (3 3)) (l (4 4))) ())) 407 | #t) 408 | 409 | (test-equal 410 | (cfgs-equal-modulo-perms? 411 | '(((l1 (3 3)) (l (4 4))) ()) 412 | '(((l1 (3 3)) (l (4 4))) ((3 3)))) 413 | #f) 414 | 415 | (test-equal 416 | (cfgs-equal-modulo-perms? 417 | '(((l (4 4)) (l1 (3 3))) ()) 418 | '(((l1 (3 3)) (l (4 4))) ((3 3)))) 419 | #f) 420 | 421 | (test-equal 422 | (cfgs-equal-modulo-perms? 423 | '(((l (3 3)) (l1 (4 4))) ()) 424 | '(((l1 (3 3)) (l (4 4))) ())) 425 | #f) 426 | 427 | (test-equal 428 | (term (subst l l1 (((l Bot)) 429 | (put l ((3 3)))))) 430 | (term (((l1 Bot)) 431 | (put l1 ((3 3)))))) 432 | 433 | (test-results)) 434 | 435 | (define (program-test-suite rr) 436 | 437 | ;; E-App-1 438 | (test-->> rr 439 | (term 440 | (() ;; empty store 441 | ((lambda (x_1) x_1) 442 | ((lambda (x_1) x_1) (lambda (x_2) x_2))))) 443 | (term 444 | (() 445 | (lambda (x_2) x_2)))) 446 | 447 | ;; E-App-2 448 | (test-->> rr 449 | (term 450 | (() ;; empty store 451 | (((lambda (x_1) x_1) (lambda (x_2) x_2)) 452 | (lambda (x_1) x_1)))) 453 | (term 454 | (() 455 | (lambda (x_1) x_1)))) 456 | 457 | ;; E-ParApp 458 | (test-->> rr 459 | (term 460 | (() ;; empty store 461 | (((lambda (x_1) x_1) (lambda (x_2) x_2)) 462 | ((lambda (x_1) x_1) (lambda (x_2) x_2))))) 463 | (term 464 | (() 465 | (lambda (x_2) x_2)))) 466 | 467 | ;; E-Beta 468 | (test-->> rr 469 | (term 470 | (() ;; empty store 471 | ((lambda (x_1) x_1) ()))) 472 | (term 473 | (() 474 | ()))) 475 | 476 | (test-->> rr 477 | (term 478 | (() ;; empty store 479 | ((lambda (x_1) x_1) (lambda (x_2) x_2)))) 480 | (term 481 | (() 482 | (lambda (x_2) x_2)))) 483 | 484 | ;; E-New 485 | (test-->> rr 486 | (term 487 | (((l (3 3))) 488 | new)) 489 | (term 490 | (((l (3 3)) (l1 Bot)) 491 | l1))) 492 | 493 | (test-->> rr 494 | (term 495 | (((l (3 3)) (l1 (4 4))) 496 | new)) 497 | (term 498 | (((l (3 3)) (l1 (4 4)) (l2 Bot)) 499 | l2))) 500 | 501 | ;; E-PutVal 502 | (test-->> rr 503 | (term 504 | (((l Bot)) 505 | (put l ((3 3))))) 506 | (term 507 | (((l (3 3))) 508 | ()))) 509 | 510 | (test-->> rr 511 | (term 512 | (((l (Bot 3))) 513 | (put l ((3 3))))) 514 | (term 515 | (((l (3 3))) 516 | ()))) 517 | 518 | ;; let 519 | (test-->> rr 520 | (term 521 | (() ;; empty store 522 | (let ((x_1 (lambda (x_1) x_1))) 523 | (let ((x_2 (lambda (x_1) x_1))) 524 | (x_1 x_2))))) 525 | (term 526 | (() 527 | (lambda (x_1) x_1)))) 528 | 529 | ;; let par 530 | (test-->> rr 531 | (term 532 | (() ;; empty store 533 | (let par ((x_1 (lambda (x_1) x_1)) 534 | (x_2 (lambda (x_1) x_1))) 535 | (x_1 x_2)))) 536 | (term 537 | (() 538 | (lambda (x_1) x_1)))) 539 | 540 | ;; E-Beta + E-New 541 | (test-->> rr 542 | (term 543 | (() ;; empty store 544 | ((lambda (x) x) new))) 545 | (term 546 | (((l Bot)) 547 | l))) 548 | 549 | ;; let + E-New + E-PutVal + E-GetVal 550 | (test-->> rr 551 | (term 552 | (() ;; empty store 553 | (let ((x_1 new)) 554 | (let ((x_2 (put x_1 ((3 3))))) 555 | (let ((x_3 (get x_1 ((Bot 3))))) 556 | x_3))))) 557 | (term 558 | (((l (3 3))) 559 | ((Bot 3))))) 560 | 561 | ;; let par + E-New + E-PutVal + E-GetVal 562 | (test-->> rr 563 | (term 564 | (() ;; empty store 565 | (let ((x_1 new)) 566 | (let par ((x_2 (put x_1 ((Bot 3)))) 567 | (x_3 (put x_1 ((3 Bot))))) 568 | (get x_1 ((3 3))))))) 569 | (term 570 | (((l (3 3))) 571 | ((3 3))))) 572 | 573 | ;; Another aspect of E-PutVal's behavior 574 | (test-->> rr 575 | (term 576 | (() ;; empty store 577 | (let ((x_1 new)) 578 | (let ((x_2 (put x_1 ((5 5))))) 579 | ;; This should just take the lub of the old and new 580 | ;; values, i.e., (5 5). 581 | (let ((x_3 (put x_1 ((Bot 5))))) 582 | (get x_1 ((5 5)))))))) 583 | (term 584 | (((l (5 5))) 585 | ((5 5))))) 586 | 587 | ;; E-PutValErr 588 | (test-->> rr 589 | (term 590 | (() ;; empty store 591 | (let ((x_1 new)) 592 | (let ((x_2 (put x_1 (Top)))) 593 | x_2)))) 594 | (term 595 | Error)) 596 | 597 | (test-->> rr 598 | #:equiv cfgs-equal-modulo-perms? 599 | (term 600 | (() 601 | (let par ([x_1 new] 602 | [x_2 new]) 603 | (let par ([x_3 (put x_1 ((3 3)))] 604 | [x_4 (put x_2 ((4 4)))]) 605 | (get x_2 ((4 4))))))) 606 | 607 | ;; When we're using slow-rr, we can end up with a store 608 | ;; of ((l (3 3)) (l1 (4 4))) or a permutation thereof -- 609 | ;; that is, x_1 is allocated first, followed by x_2. 610 | ;; When we're using fast-rr, we always seem to get the 611 | ;; allocation in the opposite order. This is not 612 | ;; nondeterministic in the sense that the result of 613 | ;; reading x_2 is always the same, but it ends up at a 614 | ;; different location in the store. This is a hack to 615 | ;; account for that. 616 | (if (equal? rr slow-rr) 617 | (term 618 | (((l (3 3)) 619 | (l1 (4 4))) 620 | ((4 4)))) 621 | (term 622 | (((l (4 4)) 623 | (l1 (3 3))) 624 | ((4 4))))) 625 | (term 626 | (((l (4 4)) 627 | (l1 (3 3))) 628 | ((4 4))))) 629 | 630 | ;;let par put and get 631 | (test-->> rr 632 | (term 633 | (() ;; empty store 634 | (let ((x_1 new)) 635 | (let par ((x_2 (put x_1 ((2 2)))) 636 | (x_3 (get x_1 ((2 2))))) 637 | (get x_1 ((2 2))))))) 638 | (term 639 | (((l (2 2))) 640 | ((2 2))))) 641 | 642 | (test-results)) 643 | 644 | (define (slow-program-test-suite rr) 645 | 646 | ;; let par + E-New + E-PutVal + E-GetVal + E-GetValBlock 647 | (test-->> rr 648 | (term 649 | (() ;; empty store 650 | (let ((x_1 new)) 651 | (let par 652 | ;; Gets stuck trying to get (4 4) out of x_1, 653 | ;; then unstuck after the other subexpression 654 | ;; finishes. 655 | ((x_4 (let par ((x_2 (put x_1 ((Bot 4)))) 656 | (x_3 (put x_1 (Bot)))) 657 | (get x_1 ((4 4))))) 658 | ;; Eventually puts (4 4) in x_1 after several 659 | ;; dummy beta-reductions. 660 | (x_5 ((lambda (x_2) 661 | ((lambda (x_2) 662 | ((lambda (x_2) 663 | ((lambda (x_2) 664 | ((lambda (x_2) 665 | (put x_1 ((4 4)))) ())) ())) ())) ())) ()))) 666 | x_4)))) 667 | (term 668 | (((l (4 4))) 669 | ((4 4))))) 670 | 671 | (test-results))) 672 | 673 | (module test-fast racket 674 | (require (submod ".." test-suite)) 675 | (test-fast)) 676 | 677 | (module test-all racket 678 | (require (submod ".." test-suite)) 679 | (test-all)) 680 | -------------------------------------------------------------------------------- /lambdaLVar/natpair.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (module language racket 4 | (require "lambdaLVar.rkt") 5 | 6 | (define-lambdaLVar-language lambdaLVar-natpair 7 | my-lub 8 | (natural natural) 9 | (natural Bot) 10 | (Bot natural)) 11 | 12 | ;; my-lub: A function that takes two pairs (they might be of the 13 | ;; form (natural natural), (natural Bot), or (Bot natural)) and 14 | ;; returns a pair that is their least upper bound. 15 | (define my-lub 16 | (lambda (p1 p2) 17 | (let* ([x_1 (car p1)] 18 | [x_2 (cadr p1)] 19 | [y_1 (car p2)] 20 | [y_2 (cadr p2)] 21 | [max_1 (my-max x_1 y_1)] 22 | [max_2 (my-max x_2 y_2)]) 23 | (list max_1 max_2)))) 24 | 25 | (define my-max 26 | (lambda (z_1 z_2) 27 | (cond 28 | [(equal? z_1 'Bot) z_2] 29 | [(equal? z_2 'Bot) z_1] 30 | [(and (number? z_1) (number? z_2)) 31 | (max z_1 z_2)] 32 | [(number? z_1) 33 | z_1] 34 | [(number? z_2) 35 | z_2] 36 | [else (error "You didn't pass in a valid argument")])))) 37 | 38 | (module test-suite racket 39 | (require redex/reduction-semantics) 40 | (require (submod ".." language)) 41 | (require srfi/1) 42 | (require "test-helpers.rkt") 43 | 44 | (provide 45 | test-fast 46 | test-all) 47 | 48 | (define (test-fast) 49 | (display "Running metafunction tests...") 50 | (flush-output) 51 | (time (meta-test-suite)) 52 | 53 | (display "Running test suite with fast-rr...") 54 | (flush-output) 55 | (time (program-test-suite fast-rr)) 56 | 57 | (display "Running test suite with slow-rr...") 58 | (flush-output) 59 | (time (program-test-suite slow-rr)) 60 | 61 | (display "Running slow test suite with fast-rr...") 62 | (flush-output) 63 | (time (slow-program-test-suite fast-rr))) 64 | 65 | (define (test-all) 66 | (test-fast) 67 | (display "Running slow test suite with slow-rr...") 68 | (flush-output) 69 | (time (slow-program-test-suite slow-rr))) 70 | 71 | ;; Test suite 72 | 73 | (define (meta-test-suite) 74 | 75 | (test-equal 76 | (term (incomp ((3 Bot) (Bot 4)))) 77 | (term #f)) 78 | 79 | (test-equal 80 | (term (incomp ((2 Bot) (3 Bot) (Bot 4)))) 81 | (term #f)) 82 | 83 | (test-equal 84 | (term (incomp (Bot (4 Bot)))) 85 | (term #f)) 86 | 87 | (test-equal 88 | (term (incomp ((3 Bot) (4 Bot)))) 89 | (term #f)) 90 | 91 | (test-equal 92 | (term (incomp ((Bot 3) (Bot 4)))) 93 | (term #f)) 94 | 95 | (test-equal 96 | (term (incomp ((Bot 1) (Bot 2) (Bot 3) (Bot 4) (Bot 5)))) 97 | (term #f)) 98 | 99 | (test-equal 100 | (term (incomp ((Bot 1) (Bot 2) (Bot 3) (Bot 4) (Bot 5) (1 Bot)))) 101 | (term #f)) 102 | 103 | (test-equal 104 | (term (incomp ((Bot 1)))) 105 | (term #t)) 106 | 107 | (test-equal 108 | (term (exists-d (Bot 1) ())) 109 | (term #f)) 110 | 111 | (test-equal 112 | (term (exists-d (Bot 6) (Bot))) 113 | (term Bot)) 114 | 115 | (test-equal 116 | (term (exists-d (Bot 6) ((Bot 9)))) 117 | (term #f)) 118 | 119 | (test-equal 120 | (term (exists-d (Bot 3) ((Bot 3)))) 121 | (term (Bot 3))) 122 | 123 | (test-equal 124 | (term (exists-d (Bot 6) ((Bot 7) (Bot 8) (Bot 9)))) 125 | (term #f)) 126 | 127 | (test-equal 128 | (term (exists-d (Bot 6) ((Bot 7) (Bot 8) (Bot 9) (Bot 6)))) 129 | (term (Bot 6))) 130 | 131 | (test-equal 132 | (term (exists-d (Bot 6) ((Bot 7) (Bot 8) (Bot 9) Bot))) 133 | (term Bot)) 134 | 135 | (test-equal 136 | (term (exists-d (6 6) ((Bot 7) (Bot 8) (Bot 9) (Bot 6)))) 137 | (term (Bot 6))) 138 | 139 | (test-equal 140 | (term (exists-d (6 6) ((3 3) (Bot 8) (Bot 9)))) 141 | (term (3 3))) 142 | 143 | (test-equal 144 | (term (exists-d (6 6) ((Bot 3) (Bot 8) (Bot 9)))) 145 | (term (Bot 3))) 146 | 147 | (test-equal 148 | (term (lub Top (3 3))) 149 | (term Top)) 150 | 151 | (test-equal 152 | (term (lub Bot (3 3))) 153 | (term (3 3))) 154 | 155 | (test-equal 156 | (term (lub Bot Bot)) 157 | (term Bot)) 158 | 159 | (test-equal 160 | (term (lub Bot Top)) 161 | (term Top)) 162 | 163 | (test-equal 164 | (term (lub (3 3) (4 4))) 165 | (term (4 4))) 166 | 167 | (test-equal 168 | (term (lub (3 3) (3 3))) 169 | (term (3 3))) 170 | 171 | (test-equal 172 | (term (lub (3 5) (7 3))) 173 | (term (7 5))) 174 | 175 | (test-equal 176 | (term (lub (3 0) (2 0))) 177 | (term (3 0))) 178 | 179 | (test-equal 180 | (term (lub (3 Bot) (2 0))) 181 | (term (3 0))) 182 | 183 | (test-equal 184 | (term (lub (Bot 4) (2 0))) 185 | (term (2 4))) 186 | 187 | (test-equal 188 | (term (lub (Bot 0) (2 0))) 189 | (term (2 0))) 190 | 191 | (test-equal 192 | (term (lub (2 0) (2 Bot))) 193 | (term (2 0))) 194 | 195 | (test-equal 196 | (term (leq (3 3) (3 3))) 197 | (term #t)) 198 | 199 | (test-equal 200 | (term (leq Top (3 3))) 201 | (term #f)) 202 | 203 | (test-equal 204 | (term (leq (3 3) Top)) 205 | (term #t)) 206 | 207 | (test-equal 208 | (term (leq Bot (3 3))) 209 | (term #t)) 210 | 211 | (test-equal 212 | (term (leq (3 3) Bot)) 213 | (term #f)) 214 | 215 | (test-equal 216 | (term (leq Top Bot)) 217 | (term #f)) 218 | 219 | (test-equal 220 | (term (leq Bot Top)) 221 | (term #t)) 222 | 223 | (test-equal 224 | (term (leq (Bot 3) (3 3))) 225 | (term #t)) 226 | 227 | (test-equal 228 | (term (leq (3 3) (Bot 3))) 229 | (term #f)) 230 | 231 | (test-equal 232 | (term (leq (3 3) (4 4))) 233 | (term #t)) 234 | 235 | (test-equal 236 | (term (leq (5 5) (4 4))) 237 | (term #f)) 238 | 239 | (test-equal 240 | (term (store-dom ((l1 (4 4)) (l2 (5 5)) (l3 Bot)))) 241 | (term (l1 l2 l3))) 242 | 243 | (test-equal 244 | (stores-equal-modulo-perms? 245 | (term (lubstore ((l1 (5 5)) 246 | (l2 (6 6)) 247 | (l3 (7 7))) 248 | ((l2 (6 6)) 249 | (l4 (9 9))))) 250 | (term ((l1 (5 5)) 251 | (l3 (7 7)) 252 | (l2 (6 6)) 253 | (l4 (9 9))))) 254 | #t) 255 | 256 | (test-equal 257 | (stores-equal-modulo-perms? 258 | (term (lubstore ((l1 (5 5)) 259 | (l2 (6 6)) 260 | (l3 (7 7))) 261 | ((l1 (5 5)) 262 | (l4 (9 9)) 263 | (l2 (6 6))))) 264 | (term ((l3 (7 7)) 265 | (l1 (5 5)) 266 | (l4 (9 9)) 267 | (l2 (6 6))))) 268 | #t) 269 | 270 | (test-equal 271 | (stores-equal-modulo-perms? 272 | (term (lubstore ((l1 Bot) 273 | (l2 (6 6)) 274 | (l3 Bot)) 275 | ((l1 (5 5)) 276 | (l4 (9 9)) 277 | (l2 (6 6))))) 278 | (term ((l3 Bot) 279 | (l1 (5 5)) 280 | (l4 (9 9)) 281 | (l2 (6 6))))) 282 | #t) 283 | 284 | (test-equal 285 | (stores-equal-modulo-perms? 286 | (term (lubstore ((l1 (5 5)) 287 | (l2 (6 6)) 288 | (l3 (7 7))) 289 | ((l2 (3 3)) 290 | (l4 (9 9))))) 291 | (term ((l1 (5 5)) 292 | (l3 (7 7)) 293 | (l2 (6 6)) 294 | (l4 (9 9))))) 295 | #t) 296 | 297 | (test-equal 298 | (stores-equal-modulo-perms? 299 | (term (lubstore ((l1 (5 5)) 300 | (l2 (6 6)) 301 | (l3 (7 7))) 302 | ((l1 (5 5)) 303 | (l4 (9 9)) 304 | (l2 Bot)))) 305 | (term ((l3 (7 7)) 306 | (l1 (5 5)) 307 | (l4 (9 9)) 308 | (l2 (6 6))))) 309 | #t) 310 | 311 | (test-equal 312 | (stores-equal-modulo-perms? 313 | (term (lubstore ((l1 Bot) 314 | (l2 (Bot 6)) 315 | (l3 Bot)) 316 | ((l1 (5 5)) 317 | (l4 (9 9)) 318 | (l2 (6 5))))) 319 | (term ((l3 Bot) 320 | (l1 (5 5)) 321 | (l4 (9 9)) 322 | (l2 (6 6))))) 323 | #t) 324 | 325 | (test-equal 326 | (term (lubstore-helper ((l1 (5 5))) 327 | () 328 | l1)) 329 | (term (5 5))) 330 | 331 | (test-equal 332 | (term (lubstore-helper ((l1 (Bot 6))) 333 | ((l1 (6 6))) 334 | l1)) 335 | (term (6 6))) 336 | 337 | (test-equal 338 | (term (lubstore-helper ((l1 (5 5)) 339 | (l2 (6 6)) 340 | (l3 (7 7))) 341 | ((l2 (5 6)) 342 | (l4 (9 9))) 343 | l2)) 344 | (term (6 6))) 345 | 346 | (test-equal 347 | (lset= equal? 348 | (lset-union equal? (term ()) (term ())) 349 | (term ())) 350 | #t) 351 | 352 | (test-equal 353 | (lset= equal? 354 | (lset-union equal? (term ()) (term (l1))) 355 | (term (l1))) 356 | #t) 357 | 358 | (test-equal 359 | (lset= equal? 360 | (lset-union equal? (term (l1 l2)) (term (l1 l2 l3))) 361 | (term (l1 l2 l3))) 362 | #t) 363 | 364 | (test-equal 365 | (lset= equal? 366 | (lset-union equal? (term (l2 l3)) (term (l1 l4))) 367 | (term (l2 l3 l1 l4))) 368 | #t) 369 | 370 | (test-equal 371 | (lset= equal? 372 | (lset-union equal? (term (l2 l3)) (term (l1 l2 l4))) 373 | (term (l3 l1 l2 l4))) 374 | #t) 375 | 376 | (test-equal 377 | (term (store-lookup ((l (2 2))) l)) 378 | (term (2 2))) 379 | 380 | (test-equal 381 | (term (store-update () l (4 4))) 382 | (term ((l (4 4))))) 383 | 384 | (test-equal 385 | (term (store-update ((l (Bot 4))) l (4 4))) 386 | (term ((l (4 4))))) 387 | 388 | (test-equal 389 | (term (store-update () l Bot)) 390 | (term ((l Bot)))) 391 | 392 | (test-equal 393 | (term (valid ())) 394 | #f) 395 | 396 | (test-equal 397 | (term (valid ((3 3)))) 398 | #t) 399 | 400 | (test-equal 401 | (term (valid ((5 5) (6 6) (7 7)))) 402 | #t) 403 | 404 | (test-equal 405 | (term (store-dom ())) 406 | (term ())) 407 | 408 | (test-equal 409 | (term (store-dom ((l (3 3)) (l1 (4 4))))) 410 | (term (l l1))) 411 | 412 | (test-equal 413 | (term (store-dom-diff ((l (3 3)) (l1 (4 4))) 414 | ((l (4 4)) (l1 (3 3))))) 415 | (term ())) 416 | 417 | (test-equal 418 | (term (store-dom-diff ((l (3 3))) 419 | ((l (4 4)) (l1 (3 3))))) 420 | (term ())) 421 | 422 | (test-equal 423 | (term (store-dom-diff ((l (4 4)) (l1 (3 3))) 424 | ((l (3 3))))) 425 | (term (l1))) 426 | 427 | (test-equal 428 | (term (store-dom-diff ((l (4 4))) 429 | ())) 430 | (term (l))) 431 | 432 | (test-equal 433 | (term (rename-locs (((l Bot)) 434 | (put l ((3 3)))) 435 | ((l (4 4))) 436 | ())) 437 | (term 438 | (((l1 Bot)) 439 | (put l1 ((3 3)))))) 440 | 441 | (test-equal 442 | (term (store-top? ())) 443 | (term #f)) 444 | 445 | (test-equal 446 | (term (store-top? ((l (3 3)) (l1 (4 4))))) 447 | (term #f)) 448 | 449 | (test-equal 450 | (term (store-top? TopS)) 451 | (term #t)) 452 | 453 | (test-equal 454 | (term (top? Top)) 455 | (term #t)) 456 | 457 | (test-equal 458 | (term (top? Bot)) 459 | (term #f)) 460 | 461 | (test-equal 462 | (term (top? (3 3))) 463 | (term #f)) 464 | 465 | (test-equal 466 | (cfgs-equal-modulo-perms? 467 | '(((l (4 4)) (l1 (3 3))) ()) 468 | '(((l1 (3 3)) (l (4 4))) ())) 469 | #t) 470 | 471 | (test-equal 472 | (cfgs-equal-modulo-perms? 473 | '(((l1 (3 3)) (l (4 4))) ()) 474 | '(((l1 (3 3)) (l (4 4))) ((3 3)))) 475 | #f) 476 | 477 | (test-equal 478 | (cfgs-equal-modulo-perms? 479 | '(((l (4 4)) (l1 (3 3))) ()) 480 | '(((l1 (3 3)) (l (4 4))) ((3 3)))) 481 | #f) 482 | 483 | (test-equal 484 | (cfgs-equal-modulo-perms? 485 | '(((l (3 3)) (l1 (4 4))) ()) 486 | '(((l1 (3 3)) (l (4 4))) ())) 487 | #f) 488 | 489 | (test-equal 490 | (term (subst l l1 (((l Bot)) 491 | (put l ((3 3)))))) 492 | (term (((l1 Bot)) 493 | (put l1 ((3 3)))))) 494 | 495 | (test-results)) 496 | 497 | (define (program-test-suite rr) 498 | 499 | ;; E-App-1 500 | (test-->> rr 501 | (term 502 | (() ;; empty store 503 | ((lambda (x_1) x_1) 504 | ((lambda (x_1) x_1) (lambda (x_2) x_2))))) 505 | (term 506 | (() 507 | (lambda (x_2) x_2)))) 508 | 509 | ;; E-App-2 510 | (test-->> rr 511 | (term 512 | (() ;; empty store 513 | (((lambda (x_1) x_1) (lambda (x_2) x_2)) 514 | (lambda (x_1) x_1)))) 515 | (term 516 | (() 517 | (lambda (x_1) x_1)))) 518 | 519 | ;; E-ParApp 520 | (test-->> rr 521 | (term 522 | (() ;; empty store 523 | (((lambda (x_1) x_1) (lambda (x_2) x_2)) 524 | ((lambda (x_1) x_1) (lambda (x_2) x_2))))) 525 | (term 526 | (() 527 | (lambda (x_2) x_2)))) 528 | 529 | ;; E-Beta 530 | (test-->> rr 531 | (term 532 | (() ;; empty store 533 | ((lambda (x_1) x_1) ()))) 534 | (term 535 | (() 536 | ()))) 537 | 538 | (test-->> rr 539 | (term 540 | (() ;; empty store 541 | ((lambda (x_1) x_1) (lambda (x_2) x_2)))) 542 | (term 543 | (() 544 | (lambda (x_2) x_2)))) 545 | 546 | ;; E-New 547 | (test-->> rr 548 | (term 549 | (((l (3 3))) 550 | new)) 551 | (term 552 | (((l (3 3)) (l1 Bot)) 553 | l1))) 554 | 555 | (test-->> rr 556 | (term 557 | (((l (3 3)) (l1 (4 4))) 558 | new)) 559 | (term 560 | (((l (3 3)) (l1 (4 4)) (l2 Bot)) 561 | l2))) 562 | 563 | ;; E-PutVal 564 | (test-->> rr 565 | (term 566 | (((l Bot)) 567 | (put l ((3 3))))) 568 | (term 569 | (((l (3 3))) 570 | ()))) 571 | 572 | (test-->> rr 573 | (term 574 | (((l (Bot 3))) 575 | (put l ((3 3))))) 576 | (term 577 | (((l (3 3))) 578 | ()))) 579 | 580 | (test-->> rr 581 | (term 582 | (((l (2 3))) 583 | (put l ((3 4))))) 584 | (term 585 | (((l (3 4))) 586 | ()))) 587 | 588 | ;; let 589 | (test-->> rr 590 | (term 591 | (() ;; empty store 592 | (let ((x_1 (lambda (x_1) x_1))) 593 | (let ((x_2 (lambda (x_1) x_1))) 594 | (x_1 x_2))))) 595 | (term 596 | (() 597 | (lambda (x_1) x_1)))) 598 | 599 | ;; let par 600 | (test-->> rr 601 | (term 602 | (() ;; empty store 603 | (let par ((x_1 (lambda (x_1) x_1)) 604 | (x_2 (lambda (x_1) x_1))) 605 | (x_1 x_2)))) 606 | (term 607 | (() 608 | (lambda (x_1) x_1)))) 609 | 610 | ;; E-Beta + E-New 611 | (test-->> rr 612 | (term 613 | (() ;; empty store 614 | ((lambda (x) x) new))) 615 | (term 616 | (((l Bot)) 617 | l))) 618 | 619 | ;; let + E-New + E-PutVal + E-GetVal 620 | (test-->> rr 621 | (term 622 | (() ;; empty store 623 | (let ((x_1 new)) 624 | (let ((x_2 (put x_1 ((3 3))))) 625 | (let ((x_3 (get x_1 ((2 3))))) 626 | x_3))))) 627 | (term 628 | (((l (3 3))) 629 | ((2 3))))) 630 | 631 | ;; let par + E-New + E-PutVal + E-GetVal 632 | (test-->> rr 633 | (term 634 | (() ;; empty store 635 | (let ((x_1 new)) 636 | (let par ((x_2 (put x_1 ((2 3)))) 637 | (x_3 (put x_1 ((3 Bot))))) 638 | (get x_1 ((3 3))))))) 639 | (term 640 | (((l (3 3))) 641 | ((3 3))))) 642 | 643 | (test-->> rr 644 | (term 645 | (() ;; empty store 646 | (let ((x_1 new)) 647 | (let ((x_2 (put x_1 ((5 3))))) 648 | (let ((x_3 (put x_1 ((Bot 5))))) 649 | (get x_1 ((5 5)))))))) 650 | (term 651 | (((l (5 5))) 652 | ((5 5))))) 653 | 654 | (test-->> rr 655 | (term 656 | (() ;; empty store 657 | (let ((x_1 new)) 658 | (let ((x_2 (put x_1 ((5 3))))) 659 | (let ((x_3 (put x_1 ((Bot 5))))) 660 | (get x_1 ((4 4)))))))) 661 | (term 662 | (((l (5 5))) 663 | ((4 4))))) 664 | 665 | ;; E-PutValErr 666 | (test-->> rr 667 | (term 668 | (() ;; empty store 669 | (let ((x_1 new)) 670 | (let ((x_2 (put x_1 (Top)))) 671 | x_2)))) 672 | (term 673 | Error)) 674 | 675 | (test-->> rr 676 | #:equiv cfgs-equal-modulo-perms? 677 | (term 678 | (() 679 | (let par ([x_1 new] 680 | [x_2 new]) 681 | (let par ([x_3 (put x_1 ((3 3)))] 682 | [x_4 (put x_2 ((4 4)))]) 683 | (get x_2 ((4 4))))))) 684 | 685 | ;; When we're using slow-rr, we can end up with a store 686 | ;; of ((l (3 3)) (l1 (4 4))) or a permutation thereof -- 687 | ;; that is, x_1 is allocated first, followed by x_2. 688 | ;; When we're using fast-rr, we always seem to get the 689 | ;; allocation in the opposite order. This is not 690 | ;; nondeterministic in the sense that the result of 691 | ;; reading x_2 is always the same, but it ends up at a 692 | ;; different location in the store. This is a hack to 693 | ;; account for that. 694 | (if (equal? rr slow-rr) 695 | (term 696 | (((l (3 3)) 697 | (l1 (4 4))) 698 | ((4 4)))) 699 | (term 700 | (((l (4 4)) 701 | (l1 (3 3))) 702 | ((4 4))))) 703 | (term 704 | (((l (4 4)) 705 | (l1 (3 3))) 706 | ((4 4))))) 707 | 708 | ;;let par put and get 709 | (test-->> rr 710 | (term 711 | (() ;; empty store 712 | (let ((x_1 new)) 713 | (let par ((x_2 (put x_1 ((2 2)))) 714 | (x_3 (get x_1 ((2 2))))) 715 | (get x_1 ((2 2))))))) 716 | (term 717 | (((l (2 2))) 718 | ((2 2))))) 719 | 720 | (test-->> rr 721 | (term 722 | (() ;; empty store 723 | (let ((x_1 new)) 724 | (let par ((x_2 (put x_1 ((1 2)))) 725 | (x_3 (get x_1 ((Bot 2))))) 726 | (get x_1 ((1 Bot))))))) 727 | (term 728 | (((l (1 2))) 729 | ((1 Bot))))) 730 | 731 | (test-results)) 732 | 733 | (define (slow-program-test-suite rr) 734 | 735 | ;; let par + E-New + E-PutVal + E-GetVal + E-GetValBlock 736 | (test-->> rr 737 | (term 738 | (() ;; empty store 739 | (let ((x_1 new)) 740 | (let par 741 | ;; Gets stuck trying to get (4 4) out of x_1, 742 | ;; then unstuck after the other subexpression 743 | ;; finishes. 744 | ((x_4 (let par ((x_2 (put x_1 ((Bot 4)))) 745 | (x_3 (put x_1 (Bot)))) 746 | (get x_1 ((4 4))))) 747 | ;; Eventually puts (4 4) in x_1 after several 748 | ;; dummy beta-reductions. 749 | (x_5 ((lambda (x_2) 750 | ((lambda (x_2) 751 | ((lambda (x_2) 752 | ((lambda (x_2) 753 | ((lambda (x_2) 754 | (put x_1 ((4 4)))) ())) ())) ())) ())) ()))) 755 | x_4)))) 756 | (term 757 | (((l (4 4))) 758 | ((4 4))))) 759 | 760 | (test-->> rr 761 | (term 762 | (() ;; empty store 763 | (let ((x_1 new)) 764 | (let par 765 | ;; Gets stuck trying to get (4 4) out of x_1, 766 | ;; then unstuck after the other subexpression 767 | ;; finishes. 768 | ((x_4 (let par ((x_2 (put x_1 ((3 4)))) 769 | (x_3 (put x_1 ((2 3))))) 770 | (get x_1 ((4 4))))) 771 | ;; Eventually puts (4 4) in x_1 after several 772 | ;; dummy beta-reductions. 773 | (x_5 ((lambda (x_2) 774 | ((lambda (x_2) 775 | ((lambda (x_2) 776 | ((lambda (x_2) 777 | ((lambda (x_2) 778 | (put x_1 ((4 Bot)))) ())) ())) ())) ())) ()))) 779 | x_4)))) 780 | (term 781 | (((l (4 4))) 782 | ((4 4))))) 783 | 784 | (test-results))) 785 | 786 | (module test-fast racket 787 | (require (submod ".." test-suite)) 788 | (test-fast)) 789 | 790 | (module test-all racket 791 | (require (submod ".." test-suite)) 792 | (test-all)) 793 | -------------------------------------------------------------------------------- /lambdaLVar/test-helpers.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide cfgs-equal-modulo-perms? 4 | stores-equal-modulo-perms?) 5 | (require srfi/1) 6 | 7 | ;; Takes two (S e) configurations and returns #t if they're equal 8 | ;; modulo permutations of store bindings. 9 | (define cfgs-equal-modulo-perms? 10 | (lambda (cfg1 cfg2) 11 | (and (stores-equal-modulo-perms? (car cfg1) (car cfg2)) 12 | (equal? (cdr cfg1) (cdr cfg2))))) 13 | 14 | ;; Takes two stores and returns #t if they're equal modulo 15 | ;; permutations. 16 | (define stores-equal-modulo-perms? 17 | (lambda (s1 s2) 18 | (lset= equal? s1 s2))) 19 | 20 | 21 | -------------------------------------------------------------------------------- /lambdaLVish/Makefile: -------------------------------------------------------------------------------- 1 | default: all 2 | 3 | all: nat-lang-all 4 | 5 | nat-lang-all: 6 | raco test -s test-all nat.rkt 7 | 8 | clean: 9 | rm -rf compiled/ 10 | -------------------------------------------------------------------------------- /lambdaLVish/README.md: -------------------------------------------------------------------------------- 1 | # lambdaLVish in Redex 2 | 3 | The code in this directory is a PLT Redex model of the lambdaLVish calculus from chapter 3 of [my dissertation](https://github.com/lkuper/dissertation). lambdaLVish is similar to [the LVish calculus](https://github.com/lkuper/lvar-semantics/tree/master/LVish#readme), but (1) renamed so as not to be confused with [the LVish Haskell library](http://hackage.haskell.org/package/lvish), and (2) extended with support for arbitrary *update operations*. Update operations generalize the `put` operation to allow not only least-upper-bound writes, but any inflationary and commutative write. 4 | 5 | ### Version requirements 6 | 7 | The code has been tested under [various versions of Racket](https://travis-ci.org/lkuper/lvar-semantics). Other versions may also work. 8 | 9 | It will _not_ work under versions prior to 5.3.2 (released January 2013). This is because version 5.3.2 added support for the Redex `boolean` pattern, which the code makes use of. 10 | 11 | ### Building and running 12 | 13 | Running `make all` in this directory will build all the lambdaLVish languages and run their test suites. 14 | -------------------------------------------------------------------------------- /lambdaLVish/lambdaLVish.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;; A Redex model of the lambdaLVish language. 3 | 4 | (provide define-lambdaLVish-language) 5 | 6 | ;; define-lambdaLVish-language takes the following arguments: 7 | ;; 8 | ;; * a name, e.g. lambdaLVish-nat, which becomes the `lang-name` passed to 9 | ;; Redex's `define-language` form. 10 | ;; 11 | ;; * a "downset" operation, a Racket-level procedure that takes a 12 | ;; lattice element and returns the (finite) set of all lattice 13 | ;; elements that are below that element. 14 | ;; 15 | ;; * a lub operation, a Racket-level procedure that takes two 16 | ;; lattice elements and returns a lattice element. 17 | ;; 18 | ;; * a list of update operations, Racket-level procedures that each 19 | ;; take a lattice element and return a lattice element. 20 | ;; 21 | ;; * some number of lattice elements represented as Redex patterns, 22 | ;; not including top and bottom elements, since we add those 23 | ;; automatically. (Therefore, if we wanted a lattice consisting 24 | ;; only of Top and Bot, we wouldn't pass any lattice elements to 25 | ;; define-lambdaLVish-language.) 26 | 27 | ;; When reading lambdaLVish programs, keep in mind that the last 28 | ;; argument to `puti` is the *index into the (1-indexed) list of 29 | ;; update operations*, *not* the value being written! 30 | 31 | (define-syntax-rule (define-lambdaLVish-language 32 | name 33 | downset-op 34 | lub-op 35 | update-ops 36 | lattice-elements ...) 37 | (begin 38 | (require redex/reduction-semantics) 39 | (require srfi/1) 40 | 41 | ;; rr is the reduction relation; most of the other operations here 42 | ;; are exported for testing purposes only. 43 | (provide rr 44 | exists-p 45 | lub 46 | lub-p 47 | leq 48 | extend-H 49 | contains-all-Q 50 | first-unhandled-d-in-Q 51 | store-dom 52 | lookup-val 53 | lookup-status 54 | lookup-state 55 | update-state 56 | incomp 57 | store-dom-diff 58 | top? 59 | subst) 60 | 61 | ;; A template for the generated Redex language definition. 62 | (define-language name 63 | 64 | ;; ============================================================= 65 | ;; lambdaLVish syntax 66 | 67 | ;; Configurations on which the reduction relation operates. 68 | (Config (S e) 69 | Error) 70 | 71 | ;; Expressions. 72 | (e x 73 | v 74 | (e e) 75 | (get e e) 76 | (puti e idx) 77 | new 78 | (freeze e) 79 | (freeze e after e with e) 80 | 81 | ;; An intermediate language form -- this doesn't show up in 82 | ;; user programs. 83 | (freeze l after Q with ((callback (lambda (x) e)) 84 | (running (e (... ...))) 85 | (handled H))) 86 | 87 | ;; Derived forms; these immediately desugar to application 88 | ;; and lambda. 89 | (let ((x e) (x e) (... ...)) e) 90 | (let par ((x e) (x e) (x e) (... ...)) e)) 91 | 92 | ;; Variables. 93 | (x variable-not-otherwise-mentioned) 94 | 95 | ;; Values. 96 | (v () ;; unit value 97 | StoreVal ;; return value of `freeze ... after ... with ...` 98 | ;; (we use StoreVal instead of d here because it 99 | ;; will never be Top) 100 | 101 | (StoreVal status) ;; return value of `get` (we use (StoreVal 102 | ;; status) instead of p here because it 103 | ;; will never be Top-p) 104 | 105 | l ;; locations (pointers to LVars in the store) 106 | P ;; threshold sets 107 | Q ;; event sets 108 | (lambda (x) e)) 109 | 110 | ;; Lattice elements, representing the "value" part of the state 111 | ;; of an LVar (the other part being "status"). We assume Top 112 | ;; and Bot lattice elements in addition to the user-specified 113 | ;; set of lattice elements. A StoreVal can be any element of 114 | ;; the lattice except Top. 115 | 116 | ;; N.B. In the LaTeX grammar, we leave out these next two rules. 117 | ;; That's because in that grammar, the user-provided lattice 118 | ;; already comes with Bot and Top, and d is any element of that 119 | ;; user-provided lattice. We just use d in the LaTeX grammar in 120 | ;; every place we use StoreVal here. 121 | (d StoreVal Top) 122 | (StoreVal lattice-elements ... Bot) 123 | 124 | ;; This isn't in the LaTeX grammar either. It's just a way to 125 | ;; index into the specified list of update operations to get the 126 | ;; one we want to use. 127 | (idx natural) 128 | 129 | ;; Threshold sets. A threshold set is the set we pass to a 130 | ;; `get` expression that specifies a non-empty, pairwise 131 | ;; incompatible subset of the states of the LVar being queried. 132 | 133 | ;; N.B. Threshold sets are potentially infinite, but we don't 134 | ;; have a good way to express infinite threshold sets in Redex. 135 | ;; In the paper, we sometimes define infinite threshold sets 136 | ;; using predicates. 137 | (P (p p (... ...))) 138 | 139 | ;; Event sets. In `freeze l after Q with (lambda (x) e)`, Q is 140 | ;; the event set. It's a set of lattice elements on which we 141 | ;; want (lambda (x) e) to be invoked when l reaches them. It 142 | ;; doesn't have to be pairwise incompatible in the way that a 143 | ;; threshold set does; It's just a set of lattice states. 144 | 145 | ;; N.B. Event sets are potentially infinite, but we don't have a 146 | ;; good way to express infinite event sets in Redex. 147 | (Q (d d (... ...))) 148 | 149 | ;; Handled element sets. A handled element set is a finite, 150 | ;; potentially empty set of lattice elements excluding Top. 151 | ;; Used to keep track of handled lattice elements in `freeze 152 | ;; ... after`. 153 | (H (d (... ...))) 154 | 155 | ;; Stores. A store is either a finite set of LVars (that is, a 156 | ;; finite partial mapping from locations l to pairs of StoreVals 157 | ;; and status flags) or a distinguished value TopS. 158 | (S (LVar (... ...)) TopS) 159 | (LVar (l (StoreVal status))) 160 | (status #t #f) 161 | (l variable-not-otherwise-mentioned) 162 | 163 | ;; States. 164 | (p (StoreVal status) Top-p) 165 | 166 | ;; Like P, but potentially empty. Used in the type of the 167 | ;; exists-p metafunction. 168 | (P/null P ()) 169 | 170 | ;; Codomains for a couple of metafunctions. 171 | (Maybe-p p #f) 172 | (Maybe-d d #f) 173 | 174 | ;; Evaluation contexts. 175 | (E hole 176 | (E e) 177 | (e E) 178 | (get E e) 179 | (get e E) 180 | (puti E idx) 181 | (freeze E) 182 | (freeze E after e with e) 183 | (freeze e after E with e) 184 | (freeze e after e with E) 185 | (freeze v after v with ((callback v) 186 | (running (e (... ...) E e (... ...))) 187 | (handled H))) 188 | 189 | ;; Special context for desugaring only. 190 | (let par ((x e) (... ...) (x E) (x e) (... ...)) e))) 191 | 192 | ;; ============================================================= 193 | ;; lambdaLVish reduction relation 194 | 195 | (define rr 196 | (reduction-relation 197 | name 198 | 199 | ;; Beta-reduction. 200 | (--> (S (in-hole E ((lambda (x) e) v))) 201 | (S (in-hole E (subst x v e))) 202 | "E-Beta") 203 | 204 | ;; Allocation of new LVars. 205 | (--> (S (in-hole E new)) 206 | ((update-state S l (Bot #f)) (in-hole E l)) 207 | (where l (variable-not-in-store S)) 208 | "E-New") 209 | 210 | ;; Update. 211 | (--> (S (in-hole E (puti l idx))) 212 | ((update-state S l p_2) (in-hole E ())) 213 | (where p_1 (lookup-state S l)) 214 | (where p_2 (u-p p_1 idx)) 215 | (where (StoreVal status) p_2) 216 | "E-Put") 217 | 218 | ;; Update that would lead to an error. 219 | (--> (S (in-hole E (puti l idx))) 220 | Error 221 | (where p_1 (lookup-state S l)) 222 | (where Top-p (u-p p_1 idx)) 223 | "E-Put-Err") 224 | 225 | ;; Threshold reads from LVars. The `incomp` and `exists-p` 226 | ;; premises to this rule are why we still need to specify a lub 227 | ;; operation, even though arbitrary update operations are 228 | ;; allowed. 229 | (--> (S (in-hole E (get l P))) 230 | (S (in-hole E p_2)) 231 | (where p_1 (lookup-state S l)) 232 | (where #t (incomp P)) 233 | (where p_2 (exists-p p_1 P)) 234 | "E-Get") 235 | 236 | ;; Creation of the intermediate language forms that 237 | ;; E-Spawn-Handler and E-Finalize-Freeze need to operate on. 238 | (--> (S (in-hole E (freeze l after Q with (lambda (x) e)))) 239 | (S (in-hole E (freeze l after Q with ((callback (lambda (x) e)) 240 | (running ()) 241 | (handled ()))))) 242 | "E-Freeze-Init") 243 | 244 | ;; Launching of handlers. This rule can fire potentially many 245 | ;; times for a given `freeze ... after` expression. It fires 246 | ;; once for each lattice element d_2 that is: 247 | ;; 248 | ;; * <= the current value d_1 of l. 249 | ;; * not a member of the current handled set H. 250 | ;; * a member of the event set Q. 251 | ;; 252 | ;; For each such d_2, it launches a handler in the `running` 253 | ;; set and adds d_2 to the `handled` set. 254 | (--> (S (in-hole E (freeze l after Q with ((callback (lambda (x) e_0)) 255 | (running (e (... ...))) 256 | (handled H))))) 257 | (S (in-hole E (freeze l after Q with ((callback (lambda (x) e_0)) 258 | (running ((subst x d_2 e_0) e (... ...))) 259 | (handled H_2))))) 260 | (where d_1 (lookup-val S l)) 261 | (where d_2 (first-unhandled-d-in-Q d_1 H Q)) 262 | (where H_2 (extend-H H d_2)) 263 | "E-Spawn-Handler") 264 | 265 | ;; Last step in the evaluation of `freeze ... after`. When all 266 | ;; expressions in the `running` set have reached values and all 267 | ;; lattice elements at or below l's current value have been 268 | ;; handled, this rule freezes and returns that value. 269 | 270 | ;; N.B.: If we haven't done any writes to an LVar yet (i.e., 271 | ;; its value is Bot), then the callback must still run once, to 272 | ;; add Bot to the `handled` set. Only then will the premises 273 | ;; of E-Freeze-Final be satisfied, allowing it to run. 274 | (--> (S (in-hole E (freeze l after Q with ((callback (lambda (x) e)) 275 | (running (v (... ...))) 276 | (handled H))))) 277 | ((freeze-helper S l) (in-hole E d_1)) 278 | (where d_1 (lookup-val S l)) 279 | (where #t (contains-all-Q d_1 H Q)) 280 | "E-Freeze-Final") 281 | 282 | ;; Special case of freeze-after, where there are no handlers to 283 | ;; run. 284 | (--> (S (in-hole E (freeze l))) 285 | ((freeze-helper S l) (in-hole E d_1)) 286 | (where d_1 (lookup-val S l)) 287 | "E-Freeze-Simple") 288 | 289 | ;; ============================================================ 290 | 291 | ;; Desugaring of `let`. 292 | (--> (S (in-hole E (let ((x_1 e_1)) e_2))) 293 | (S (in-hole E ((lambda (x_1) e_2) e_1))) 294 | "Desugaring of let") 295 | 296 | ;; Desugaring of `let par`. 297 | (--> (S (in-hole E (let par ((x_1 e_1) (x_2 e_2)) e_3))) 298 | (S (in-hole E (((lambda (x_1) (lambda (x_2) e_3)) e_1) e_2))) 299 | "Desugaring of let par") 300 | 301 | ;; Desugaring of multi-binding `let` 302 | (--> (S (in-hole E (let ((x_1 e_1) 303 | (x_2 e_2) 304 | (x_3 e_3) (... ...)) 305 | e_4))) 306 | (S (in-hole E (let ((x_1 e_1)) 307 | (let ((x_2 e_2)) 308 | (let ((x_3 e_3) (... ...)) 309 | e_4))))) 310 | "Desugaring of multi-binding `let`") 311 | 312 | ;; Desugaring of multi-binding `let par` 313 | (--> (S (in-hole E (let par ((x_1 e_1) 314 | (x_2 e_2) 315 | (x_3 e_3) 316 | (x_4 x_4) (... ...)) 317 | e_5))) 318 | (S (in-hole E (let par ((x_1 e_1) 319 | (x (let par ((x_2 e_2) 320 | (x_3 e_3) 321 | (x_4 x_4) (... ...)) 322 | e_5))) 323 | x))) 324 | (fresh x) 325 | "Desugaring of multi-binding `let par`"))) 326 | 327 | ;; ============================================================= 328 | ;; lambdaLVish metafunctions 329 | 330 | ;; Some convenience functions: LVar accessors and constructor. 331 | 332 | (define-metafunction name 333 | lvloc : LVar -> l 334 | [(lvloc LVar) ,(first (term LVar))]) 335 | 336 | (define-metafunction name 337 | lvstate : LVar -> p 338 | [(lvstate LVar) ,(second (term LVar))]) 339 | 340 | (define-metafunction name 341 | lvvalue : LVar -> StoreVal 342 | [(lvvalue LVar) ,(first (second (term LVar)))]) 343 | 344 | (define-metafunction name 345 | lvstatus : LVar -> status 346 | [(lvstatus LVar) ,(second (second (term LVar)))]) 347 | 348 | (define-metafunction name 349 | build-lv : l StoreVal status -> LVar 350 | [(build-lv l StoreVal status) 351 | (l (StoreVal status))]) 352 | 353 | ;; Returns a store that is the same as the original store S, but 354 | ;; with S(l) modified to be frozen. 355 | (define-metafunction name 356 | freeze-helper : S l -> S 357 | [(freeze-helper S l) 358 | ,(let ([lv (assq (term l) (term S))] 359 | [update (lambda (lv) 360 | (if (equal? (term (lvloc ,lv)) (term l)) 361 | (term (build-lv (lvloc ,lv) (lvvalue ,lv) #t)) 362 | lv))]) 363 | (if lv 364 | (term ,(map update (term S))) 365 | (error "freeze-helper: lookup failed")))]) 366 | 367 | ;; Takes a handled set H and returns a new one with d added. 368 | ;; Assumes that d is not already a member of H. 369 | (define-metafunction name 370 | extend-H : H d -> H 371 | [(extend-H H d) ,(cons (term d) (term H))]) 372 | 373 | ;; Checks to see that, for all lattice elements that are less than 374 | ;; or equal to d and a member of Q, they're a member of H. In 375 | ;; other words, (contains-all-Q d H Q) returns true exactly when 376 | ;; the set (intersection (downset-op d) Q) is a subset of H. 377 | (define-metafunction name 378 | contains-all-Q : d H Q -> boolean 379 | [(contains-all-Q d H Q) 380 | ,(lset<= equal? 381 | (lset-intersection equal? 382 | (downset-op (term d)) 383 | (term Q)) 384 | (term H))]) 385 | 386 | ;; A helper for the E-Spawn-Handler reduction rule. Takes a 387 | ;; lattice element d_1, a finite set H of elements, and a finite 388 | ;; set Q of elements of interest. returns the first element that 389 | ;; is <= d_1 in the lattice that is *not* a member of H and *is* a 390 | ;; member of Q, if such an element exists; returns #f otherwise. 391 | (define-metafunction name 392 | first-unhandled-d-in-Q : d H Q -> Maybe-d 393 | [(first-unhandled-d-in-Q d_1 H Q) 394 | ,(let ([ls (filter (lambda (x) 395 | (and (not (member x (term H))) 396 | (member x (term Q)))) 397 | (downset-op (term d_1)))]) 398 | (if (null? ls) 399 | #f 400 | (term ,(first ls))))]) 401 | 402 | (define-metafunction name 403 | store-dom : S -> (l (... ...)) 404 | [(store-dom ()) ()] 405 | [(store-dom ((l_1 (StoreVal_1 status_1)) 406 | (l_2 (StoreVal_2 status_2)) (... ...))) 407 | ,(cons (term l_1) 408 | (term (store-dom ((l_2 (StoreVal_2 status_2)) (... ...)))))]) 409 | 410 | ;; Return a list of locations in dom(S_1) that are not in dom(S_2). 411 | (define-metafunction name 412 | store-dom-diff : S S -> (l (... ...)) 413 | [(store-dom-diff S_1 S_2) 414 | ,(lset-difference equal? 415 | (term (store-dom S_1)) 416 | (term (store-dom S_2)))]) 417 | 418 | (define-metafunction name 419 | top? : d -> boolean 420 | [(top? Top) #t] 421 | [(top? d) #f]) 422 | 423 | ;; N.B.: The lub of d_1 and d_2 is the element d_3 such that: 424 | ;; -- (leq d_1 d_3) 425 | ;; -- (leq d_2 d_3) 426 | ;; -- for all d_4 s.t. (leq d_1 d_4) and (leq d_2 d_4), (leq d_3 d_4). 427 | ;; 428 | ;; But we can't get Redex to compute that, so instead, we ask the user 429 | ;; to provide lub, then compute leq in terms of lub. 430 | ;; 431 | ;; Intended to be extended by a user-provided operation. 432 | (define-metafunction name 433 | lub : d d -> d 434 | [(lub Bot d_2) d_2] 435 | [(lub d_1 Bot) d_1] 436 | [(lub Top d_2) Top] 437 | [(lub d_1 Top) Top] 438 | [(lub d_1 d_2) ,(lub-op (term d_1) (term d_2))]) 439 | 440 | ;; Defined in terms of lub. 441 | (define-metafunction name 442 | leq : d d -> boolean 443 | [(leq Bot d_2) #t] 444 | [(leq d_1 Bot) #f] 445 | [(leq Top d_2) #f] 446 | [(leq d_1 Top) #t] 447 | 448 | ;; If d_1 = d_2, then (leq d_1 d_2). 449 | [(leq d_1 d_2) #t 450 | (side-condition (equal? (term d_1) (term d_2)))] 451 | 452 | ;; If (lub d_1 d_2) = d_2, then (leq d_1 d_2). 453 | [(leq d_1 d_2) #t 454 | (side-condition (equal? (term (lub d_1 d_2)) (term d_2)))] 455 | 456 | ;; If (lub d_1 d_2) = d_1, then (not (leq d_1 d_2)). (This assumes 457 | ;; that d_1 != d_2, but we've already covered the case where they're 458 | ;; equal.) 459 | [(leq d_1 d_2) #f 460 | (side-condition (equal? (term (lub d_1 d_2)) (term d_1)))] 461 | 462 | ;; The only case left: (lub d_1 d_2) = d_3, where d_3 is greater 463 | ;; than both d_1 and d_2. In this case, (not (leq d_1 d_2)). 464 | [(leq d_1 d_2) #f]) 465 | 466 | ;; The update operation, defined in terms of the user-provided 467 | ;; update-ops. The `sub1` is so the list can be 1-indexed, to 468 | ;; match the paper version. 469 | (define-metafunction name 470 | u : d idx -> d 471 | [(u d idx) ,((list-ref update-ops (sub1 (term idx))) (term d))]) 472 | 473 | ;; The update operation, but extended to handle status bits. 474 | (define-metafunction name 475 | u-p : p idx -> p 476 | [(u-p (d #f) idx) ((u d idx) #f)] 477 | [(u-p (d #t) idx) 478 | ,(if (equal? (term (u d idx)) (term d)) 479 | (term (d #t)) 480 | (term Top-p))]) 481 | 482 | ;; The lub operation, but extended to handle status bits. 483 | (define-metafunction name 484 | lub-p : p p -> p 485 | 486 | ;; Neither frozen: 487 | [(lub-p (d_1 #f) (d_2 #f)) 488 | ,(let ([d (term (lub d_1 d_2))]) 489 | (if (equal? d (term Top)) 490 | (term Top-p) 491 | `(,d #f)))] 492 | 493 | ;; Both frozen: 494 | [(lub-p (d_1 #t) (d_2 #t)) 495 | ,(if (equal? (term d_1) (term d_2)) 496 | (term (d_1 #t)) 497 | (term Top-p))] 498 | 499 | ;; d_1 unfrozen, d_2 frozen: 500 | [(lub-p (d_1 #f) (d_2 #t)) 501 | ,(if (term (leq d_1 d_2)) 502 | (term (d_2 #t)) 503 | (term Top-p))] 504 | 505 | ;; d_1 frozen, d_2 unfrozen: 506 | [(lub-p (d_1 #t) (d_2 #f)) 507 | ,(if (term (leq d_2 d_1)) 508 | (term (d_1 #t)) 509 | (term Top-p))]) 510 | 511 | ;; The leq operation, but extended to handle status bits: 512 | (define-metafunction name 513 | leq-p : p p -> boolean 514 | 515 | ;; Neither frozen: 516 | [(leq-p (d_1 #f) (d_2 #f)) 517 | (leq d_1 d_2)] 518 | 519 | ;; Both frozen: 520 | [(leq-p (d_1 #t) (d_2 #t)) 521 | ,(equal? (term d_1) (term d_2))] 522 | 523 | ;; d_1 unfrozen, d_2 frozen: 524 | [(leq-p (d_1 #f) (d_2 #t)) 525 | (leq d_1 d_2)] 526 | 527 | ;; d_1 frozen, d_2 unfrozen: 528 | [(leq-p (d_1 #t) (d_2 #f)) 529 | ,(equal? (term d_1) (term Top))]) 530 | 531 | (define-metafunction name 532 | variable-not-in-store : S -> l 533 | [(variable-not-in-store S) 534 | ,(variable-not-in (term S) (term l))]) 535 | 536 | (define-metafunction name 537 | lookup-val : S l -> StoreVal 538 | [(lookup-val S l) ,(let ([lv (assq (term l) (term S))]) 539 | (if lv 540 | (term (lvvalue ,lv)) 541 | (error "lookup-val: lookup failed")))]) 542 | 543 | (define-metafunction name 544 | lookup-status : S l -> status 545 | [(lookup-status S l) ,(let ([lv (assq (term l) (term S))]) 546 | (if lv 547 | (term (lvstatus ,lv)) 548 | (error "lookup-status: lookup failed")))]) 549 | 550 | (define-metafunction name 551 | lookup-state : S l -> p 552 | [(lookup-state S l) ,(let ([lv (assq (term l) (term S))]) 553 | (if lv 554 | (term (lvstate ,lv)) 555 | (error "lookup-state: lookup failed")))]) 556 | 557 | ;; Actually handles both updates and extensions. 558 | (define-metafunction name 559 | update-state : S l p -> S 560 | [(update-state () l p) ((l p))] 561 | 562 | [(update-state ((l_2 p_2) (l_3 p_3) (... ...)) 563 | l_1 p_1) 564 | ,(if (equal? (term l_1) (term l_2)) 565 | (cons (term (l_2 p_1)) 566 | (term ((l_3 p_3) (... ...)))) 567 | (cons (term (l_2 p_2)) 568 | (term (update-state ((l_3 p_3) (... ...)) l_1 p_1))))]) 569 | 570 | ;; Used as a premise of the E-Get rule. Returns #t if, for any 571 | ;; two distinct elements in P, the lub of them is Top-p, and #f 572 | ;; otherwise. 573 | (define-metafunction name 574 | incomp : P -> boolean 575 | [(incomp ()) #t] 576 | [(incomp (p)) #t] 577 | [(incomp (p_1 p_2)) ,(equal? (term (lub-p p_1 p_2)) (term Top-p))] 578 | [(incomp (p_1 p_2 p_3 (... ...))) 579 | ,(and (equal? (term (lub-p p_1 p_2)) (term Top-p)) 580 | (term (incomp (p_1 p_3 (... ...)))) 581 | (term (incomp (p_2 p_3 (... ...)))))]) 582 | 583 | ;; Used as a premise of the E-Get rule. If there exists a p_2 584 | ;; that is a member of P and is less than or equal to p_1, returns 585 | ;; that p_2. Otherwise, returns #f. 586 | (define-metafunction name 587 | exists-p : p P/null -> Maybe-p 588 | 589 | ;; If the second argument is null, then there definitely isn't a p_2. 590 | [(exists-p p_1 ()) #f] 591 | 592 | ;; If the first item in P is less than p_1, return it. 593 | [(exists-p p_1 (p_21 p_22 (... ...))) p_21 594 | (where #t (leq-p p_21 p_1))] 595 | 596 | ;; Otherwise, check the rest. 597 | [(exists-p p_1 (p_21 p_22 (... ...))) (exists-p p_1 (p_22 (... ...))) 598 | (where #f (leq-p p_21 p_1))]) 599 | 600 | ;; subst and subst-vars: capture-avoiding substitution, due to 601 | ;; redex.racket-lang.org/lam-v.html. 602 | 603 | (define-metafunction name 604 | subst : x any any -> any 605 | ;; 1. x_1 bound, so don't continue in lambda body 606 | [(subst x_1 any_1 (lambda (x_2 (... ...) x_1 x_3 (... ...)) any_2)) 607 | (lambda (x_2 (... ...) x_1 x_3 (... ...)) any_2) 608 | (side-condition (not (member (term x_1) (term (x_2 (... ...))))))] 609 | 610 | ;; 2. general purpose capture-avoiding case 611 | [(subst x_1 any_1 (lambda (x_2 (... ...)) any_2)) 612 | (lambda (x_new (... ...)) 613 | (subst x_1 any_1 (subst-vars (x_2 x_new) (... ...) any_2))) 614 | (where (x_new (... ...)) ,(variables-not-in (term (x_1 any_1 any_2)) 615 | (term (x_2 (... ...)))))] 616 | 617 | ;; 3. replace x_1 with e_1 618 | [(subst x_1 any_1 x_1) any_1] 619 | 620 | ;; 4. x_1 and x_2 are different, so don't replace 621 | [(subst x_1 any_1 x_2) x_2] 622 | 623 | ;; the last cases cover all other expressions 624 | [(subst x_1 any_1 (any_2 (... ...))) 625 | ((subst x_1 any_1 any_2) (... ...))] 626 | [(subst x_1 any_1 any_2) any_2]) 627 | 628 | (define-metafunction name 629 | subst-vars : (x any) (... ...) any -> any 630 | [(subst-vars (x_1 any_1) x_1) any_1] 631 | [(subst-vars (x_1 any_1) (any_2 (... ...))) 632 | ((subst-vars (x_1 any_1) any_2) (... ...))] 633 | [(subst-vars (x_1 any_1) any_2) any_2] 634 | [(subst-vars (x_1 any_1) (x_2 any_2) (... ...) any_3) 635 | (subst-vars (x_1 any_1) 636 | (subst-vars (x_2 any_2) (... ...) any_3))] 637 | [(subst-vars any) any]))) 638 | -------------------------------------------------------------------------------- /lambdaLVish/nat.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (module language racket 4 | (require "lambdaLVish.rkt") 5 | (require srfi/1) 6 | (provide lambdaLVish-nat) 7 | 8 | (define-lambdaLVish-language lambdaLVish-nat downset-op max update-ops natural) 9 | 10 | ;; To figure out at some point: maybe we could actually write 11 | ;; downset-op with Redex patterns? 12 | 13 | (define downset-op 14 | (lambda (d) 15 | (if (number? d) 16 | (append '(Bot) (iota d) `(,d)) 17 | '(Bot)))) 18 | 19 | (define update-op-1 20 | (lambda (d) 21 | (match d 22 | ['Bot 1] 23 | [number (add1 d)]))) 24 | 25 | (define update-op-2 26 | (lambda (d) 27 | (match d 28 | ['Bot 2] 29 | [number (add1 (add1 d))]))) 30 | 31 | (define update-ops `(,update-op-1 ,update-op-2))) 32 | 33 | (module test-suite racket 34 | (require redex/reduction-semantics) 35 | (require (submod ".." language)) 36 | (require "test-helpers.rkt") 37 | 38 | (provide 39 | test-all) 40 | 41 | (define (test-all) 42 | (display "Running metafunction tests...") 43 | (flush-output) 44 | (time (meta-test-suite)) 45 | 46 | (display "Running test suite...") 47 | (flush-output) 48 | (time (program-test-suite rr))) 49 | 50 | ;; Test suite 51 | 52 | (define (meta-test-suite) 53 | (test-equal 54 | (term (exists-p (6 #f) ())) 55 | (term #f)) 56 | 57 | (test-equal 58 | (term (exists-p (6 #f) ((3 #f)))) 59 | (term (3 #f))) 60 | 61 | (test-equal 62 | (term (exists-p (6 #f) ((9 #f)))) 63 | (term #f)) 64 | 65 | (test-equal 66 | (term (exists-p (3 #f) ((3 #f)))) 67 | (term (3 #f))) 68 | 69 | ;; These next three are unrealistic for this lattice because Q would 70 | ;; be a singleton set, but it's here to exercise exists-p. 71 | (test-equal 72 | (term (exists-p (6 #f) ((7 #f) (8 #f) (9 #f)))) 73 | (term #f)) 74 | 75 | (test-equal 76 | (term (exists-p (6 #f) ((7 #f) (8 #f) (9 #f) (6 #f)))) 77 | (term (6 #f))) 78 | 79 | (test-equal 80 | (term (exists-p (6 #f) ((7 #f) (8 #f) (9 #f) (5 #f)))) 81 | (term (5 #f))) 82 | 83 | (test-equal 84 | (term (lub Bot Bot)) 85 | (term Bot)) 86 | 87 | (test-equal 88 | (term (lub Top 3)) 89 | (term Top)) 90 | 91 | (test-equal 92 | (term (lub 3 4)) 93 | (term 4)) 94 | 95 | (test-equal 96 | (term (lub 3 3)) 97 | (term 3)) 98 | 99 | (test-equal 100 | (term (lub-p (3 #f) (4 #f))) 101 | (term ((lub 3 4) #f))) 102 | 103 | (test-equal 104 | (term (lub-p (3 #t) (3 #t))) 105 | (term (3 #t))) 106 | 107 | (test-equal 108 | (term (lub-p (3 #t) (4 #t))) 109 | (term Top-p)) 110 | 111 | (test-equal 112 | (term (lub-p (3 #f) (4 #t))) 113 | (term (4 #t))) 114 | 115 | (test-equal 116 | (term (lub-p (4 #f) (3 #t))) 117 | (term Top-p)) 118 | 119 | (test-equal 120 | (term (lub-p (4 #t) (3 #f))) 121 | (term (4 #t))) 122 | 123 | (test-equal 124 | (term (lub-p (3 #t) (4 #f))) 125 | (term Top-p)) 126 | 127 | (test-equal 128 | (term (leq 3 3)) 129 | (term #t)) 130 | 131 | (test-equal 132 | (term (leq Top 3)) 133 | (term #f)) 134 | 135 | (test-equal 136 | (term (leq 3 Top)) 137 | (term #t)) 138 | 139 | (test-equal 140 | (term (leq Bot 3)) 141 | (term #t)) 142 | 143 | (test-equal 144 | (term (leq 3 Bot)) 145 | (term #f)) 146 | 147 | (test-equal 148 | (term (leq Top Bot)) 149 | (term #f)) 150 | 151 | (test-equal 152 | (term (leq Bot Top)) 153 | (term #t)) 154 | 155 | (test-equal 156 | (term (leq 3 4)) 157 | (term #t)) 158 | 159 | (test-equal 160 | (term (leq 4 3)) 161 | (term #f)) 162 | 163 | (test-equal 164 | (term (extend-H () 3)) 165 | (term (3))) 166 | 167 | (test-equal 168 | (term (extend-H (3 4 5) 6)) 169 | (term (6 3 4 5))) 170 | 171 | ;; For the remaining tests, note that (downset 3) => (Bot 0 1 2 3). 172 | 173 | ;; The following tests all use the entire downset as Q: 174 | 175 | (test-equal 176 | (term (contains-all-Q 3 177 | (Bot 0 1 2 3) 178 | (Bot 0 1 2 3))) 179 | (term #t)) 180 | 181 | (test-equal 182 | (term (contains-all-Q 3 183 | (Bot 1 2 3) 184 | (Bot 0 1 2 3))) 185 | (term #f)) 186 | 187 | (test-equal 188 | (term (contains-all-Q 3 189 | (Bot 2 3) 190 | (Bot 0 1 2 3))) 191 | (term #f)) 192 | 193 | (test-equal 194 | (term (contains-all-Q 3 195 | (Bot 2 3 4 5) 196 | (Bot 0 1 2 3))) 197 | (term #f)) 198 | 199 | (test-equal 200 | (term (contains-all-Q 3 201 | (Bot 0 1 2 3 4 5) 202 | (Bot 0 1 2 3))) 203 | (term #t)) 204 | 205 | ;; And these use smaller sets as Q: 206 | 207 | (test-equal 208 | (term (contains-all-Q 3 209 | (Bot 0 1 2 3) 210 | (Bot))) 211 | (term #t)) 212 | 213 | (test-equal 214 | (term (contains-all-Q 3 215 | (Bot 1 2 3) 216 | (Bot 0))) 217 | (term #f)) 218 | 219 | (test-equal 220 | (term (contains-all-Q 3 221 | (Bot 2 3) 222 | (Bot 2 3))) 223 | (term #t)) 224 | 225 | (test-equal 226 | (term (contains-all-Q 3 227 | (Bot 2 3 4 5) 228 | (0 1 2 3))) 229 | (term #f)) 230 | 231 | (test-equal 232 | (term (contains-all-Q 3 233 | (Bot 0 1 2 3 4 5) 234 | (Bot 0))) 235 | (term #t)) 236 | 237 | ;; The following tests all use the entire downset as Q: 238 | 239 | ;; "Return the first element <= 3 that is *not* in (0 1 2 3 4 5) 240 | ;; but *is* in (Bot 0 1 2 3)." 241 | (test-equal 242 | (term (first-unhandled-d-in-Q 3 (0 1 2 3 4 5) (Bot 0 1 2 3))) 243 | (term Bot)) 244 | 245 | (test-equal 246 | (term (first-unhandled-d-in-Q 3 (Bot 1 2 3 4 5) (Bot 0 1 2 3))) 247 | (term 0)) 248 | 249 | (test-equal 250 | (term (first-unhandled-d-in-Q 3 (Bot 0 1 2 3 4 5) (Bot 0 1 2 3))) 251 | (term #f)) 252 | 253 | (test-equal 254 | (term (first-unhandled-d-in-Q 3 (Bot 0 1 2 3) (Bot 0 1 2 3))) 255 | (term #f)) 256 | 257 | (test-equal 258 | (term (first-unhandled-d-in-Q 3 (Bot 2 3) (Bot 0 1 2 3))) 259 | (term 0)) 260 | 261 | (test-equal 262 | (term (first-unhandled-d-in-Q 3 (Bot 0 2 3) (Bot 0 1 2 3))) 263 | (term 1)) 264 | 265 | (test-equal 266 | (term (first-unhandled-d-in-Q 3 (Bot 0 1 2) (Bot 0 1 2 3))) 267 | (term 3)) 268 | 269 | (test-equal 270 | (term (first-unhandled-d-in-Q 3 (Bot 0 1 2 4 5 6 7) (Bot 0 1 2 3))) 271 | (term 3)) 272 | 273 | (test-equal 274 | (term (first-unhandled-d-in-Q 3 (7 0 2 6 Bot 3 1 5 4) (Bot 0 1 2 3))) 275 | (term #f)) 276 | 277 | (test-equal 278 | (term (first-unhandled-d-in-Q 3 (7 6 5 4 3 0 Bot) (Bot 0 1 2 3))) 279 | (term 1)) 280 | 281 | ;; And these use smaller sets as Q: 282 | 283 | ;; "Return the first element <= 3 that is *not* in (0 1 2 3 4 5) 284 | ;; but *is* in (1 2 3)." 285 | (test-equal 286 | (term (first-unhandled-d-in-Q 3 (0 1 2 3 4 5) (1 2 3))) 287 | (term #f)) 288 | 289 | (test-equal 290 | (term (first-unhandled-d-in-Q 3 (Bot 1 2 3 4 5) (1 2 3))) 291 | (term #f)) 292 | 293 | (test-equal 294 | (term (first-unhandled-d-in-Q 3 (Bot 0 1 2 3 4 5) (1 2 3))) 295 | (term #f)) 296 | 297 | (test-equal 298 | (term (first-unhandled-d-in-Q 3 (Bot 0 1 2 3) (1 2 3))) 299 | (term #f)) 300 | 301 | (test-equal 302 | (term (first-unhandled-d-in-Q 3 (Bot 2 3) (0 1 2))) 303 | (term 0)) 304 | 305 | (test-equal 306 | (term (first-unhandled-d-in-Q 3 (Bot 0 2 3) (0 1 2))) 307 | (term 1)) 308 | 309 | (test-equal 310 | (term (first-unhandled-d-in-Q 1 (Bot 0 3) (2))) 311 | (term #f)) 312 | 313 | (test-equal 314 | (term (first-unhandled-d-in-Q 3 (Bot 0 3) (2))) 315 | (term 2)) 316 | 317 | (test-equal 318 | (term (first-unhandled-d-in-Q 3 (Bot 0 2 3) (2))) 319 | (term #f)) 320 | 321 | (test-equal 322 | (term (store-dom ((l1 (4 #f)) (l2 (5 #f)) (l3 (Bot #f))))) 323 | (term (l1 l2 l3))) 324 | 325 | (test-equal 326 | (term (lookup-val ((l (2 #f))) l)) 327 | (term 2)) 328 | 329 | (test-equal 330 | (term (lookup-status ((l (2 #f))) l)) 331 | (term #f)) 332 | 333 | (test-equal 334 | (term (lookup-status ((l (2 #t))) l)) 335 | (term #t)) 336 | 337 | (test-equal 338 | (term (lookup-state ((l (2 #t))) l)) 339 | (term (2 #t))) 340 | 341 | (test-equal 342 | (term (lookup-state ((l (2 #t)) (l1 (3 #f))) l1)) 343 | (term (3 #f))) 344 | 345 | (test-equal 346 | (term (update-state () l (4 #f))) 347 | (term ((l (4 #f))))) 348 | 349 | (test-equal 350 | (term (update-state ((l (3 #f))) l (4 #f))) 351 | (term ((l (4 #f))))) 352 | 353 | (test-equal 354 | (term (update-state () l (Bot #f))) 355 | (term ((l (Bot #f))))) 356 | 357 | (test-equal 358 | (term (store-dom ())) 359 | (term ())) 360 | 361 | (test-equal 362 | (term (store-dom ((l (3 #f)) (l1 (4 #f))))) 363 | (term (l l1))) 364 | 365 | (test-equal 366 | (term (store-dom-diff ((l (3 #f)) (l1 (4 #f))) 367 | ((l (4 #f)) (l1 (3 #f))))) 368 | (term ())) 369 | 370 | (test-equal 371 | (term (store-dom-diff ((l (3 #f))) 372 | ((l (4 #f)) (l1 (3 #f))))) 373 | (term ())) 374 | 375 | (test-equal 376 | (term (store-dom-diff ((l (4 #f)) (l1 (3 #f))) 377 | ((l (3 #f))))) 378 | (term (l1))) 379 | 380 | (test-equal 381 | (term (store-dom-diff ((l (4 #f))) 382 | ())) 383 | (term (l))) 384 | 385 | (test-equal 386 | (term (top? Top)) 387 | (term #t)) 388 | 389 | (test-equal 390 | (term (top? Bot)) 391 | (term #f)) 392 | 393 | (test-equal 394 | (term (top? 3)) 395 | (term #f)) 396 | 397 | (test-equal 398 | (cfgs-equal-modulo-perms? 399 | '(((l (4 #f)) (l1 (3 #f))) ()) 400 | '(((l1 (3 #f)) (l (4 #f))) ())) 401 | #t) 402 | 403 | (test-equal 404 | (cfgs-equal-modulo-perms? 405 | '(((l1 (3 #f)) (l (4 #f))) ()) 406 | '(((l1 (3 #f)) (l (4 #f))) (3))) 407 | #f) 408 | 409 | (test-equal 410 | (cfgs-equal-modulo-perms? 411 | '(((l (4 #f)) (l1 (3 #f))) ()) 412 | '(((l1 (3 #f)) (l (4 #f))) (3))) 413 | #f) 414 | 415 | (test-equal 416 | (cfgs-equal-modulo-perms? 417 | '(((l (3 #f)) (l1 (4 #f))) ()) 418 | '(((l1 (3 #f)) (l (4 #f))) ())) 419 | #f) 420 | 421 | (test-results)) 422 | 423 | (define (program-test-suite rr) 424 | 425 | (test-->> rr 426 | (term 427 | (() ;; empty store 428 | ((lambda (x_1) x_1) 429 | ((lambda (x_1) x_1) (lambda (x_2) x_2))))) 430 | (term 431 | (() 432 | (lambda (x_2) x_2)))) 433 | 434 | (test-->> rr 435 | (term 436 | (() ;; empty store 437 | (((lambda (x_1) x_1) (lambda (x_2) x_2)) 438 | (lambda (x_1) x_1)))) 439 | (term 440 | (() 441 | (lambda (x_1) x_1)))) 442 | 443 | (test-->> rr 444 | (term 445 | (() ;; empty store 446 | (((lambda (x_1) x_1) (lambda (x_2) x_2)) 447 | ((lambda (x_1) x_1) (lambda (x_2) x_2))))) 448 | (term 449 | (() 450 | (lambda (x_2) x_2)))) 451 | 452 | (test-->> rr 453 | (term 454 | (() ;; empty store 455 | ((lambda (x_1) x_1) ()))) 456 | (term 457 | (() 458 | ()))) 459 | 460 | (test-->> rr 461 | (term 462 | (() ;; empty store 463 | ((lambda (x_1) x_1) (lambda (x_2) x_2)))) 464 | (term 465 | (() 466 | (lambda (x_2) x_2)))) 467 | 468 | (test-->> rr 469 | (term 470 | (((l (3 #f))) 471 | new)) 472 | (term 473 | (((l (3 #f)) (l1 (Bot #f))) 474 | l1))) 475 | 476 | (test-->> rr 477 | (term 478 | (((l (3 #f)) (l1 (4 #f))) 479 | new)) 480 | (term 481 | (((l (3 #f)) (l1 (4 #f)) (l2 (Bot #f))) 482 | l2))) 483 | 484 | (test-->> rr 485 | (term 486 | (((l (3 #f))) 487 | (puti l 1))) 488 | (term 489 | (((l (4 #f))) 490 | ()))) 491 | 492 | (test-->> rr 493 | (term 494 | (((l (3 #f))) 495 | (puti l 2))) 496 | (term 497 | (((l (5 #f))) 498 | ()))) 499 | 500 | (test-->> rr 501 | (term 502 | (((l (Bot #f))) 503 | (puti l 1))) 504 | (term 505 | (((l (1 #f))) 506 | ()))) 507 | 508 | (test-->> rr 509 | (term 510 | (((l (2 #f))) 511 | (puti l 1))) 512 | (term 513 | (((l (3 #f))) 514 | ()))) 515 | 516 | ;; let 517 | (test-->> rr 518 | (term 519 | (() ;; empty store 520 | (let ((x_1 (lambda (x_1) x_1))) 521 | (let ((x_2 (lambda (x_1) x_1))) 522 | (x_1 x_2))))) 523 | (term 524 | (() 525 | (lambda (x_1) x_1)))) 526 | 527 | ;; let par 528 | (test-->> rr 529 | (term 530 | (() ;; empty store 531 | (let par ((x_1 (lambda (x_1) x_1)) 532 | (x_2 (lambda (x_1) x_1))) 533 | (x_1 x_2)))) 534 | (term 535 | (() 536 | (lambda (x_1) x_1)))) 537 | 538 | (test-->> rr 539 | (term 540 | (() ;; empty store 541 | ((lambda (x) x) new))) 542 | (term 543 | (((l (Bot #f))) 544 | l))) 545 | 546 | (test-->> rr 547 | (term 548 | (() ;; empty store 549 | (let ((x_1 new)) 550 | (let ((x_2 (puti x_1 1))) 551 | (let ((x_3 (get x_1 ((1 #f))))) 552 | x_3))))) 553 | (term 554 | (((l (1 #f))) 555 | (1 #f)))) 556 | 557 | (test-->> rr 558 | (term 559 | (() ;; empty store 560 | (let ((x_1 new)) 561 | (let par ((x_2 (puti x_1 1)) 562 | (x_3 (puti x_1 1))) 563 | (get x_1 ((2 #f))))))) 564 | (term 565 | (((l (2 #f))) 566 | (2 #f)))) 567 | 568 | (test-->> rr 569 | (term 570 | (() 571 | (let par ([x_1 new] 572 | [x_2 new]) 573 | (let par ([x_3 (puti x_1 1)] 574 | [x_4 (puti x_2 1)]) 575 | (get x_2 ((1 #f))))))) 576 | (term 577 | (((l (1 #f)) 578 | (l1 (1 #f))) 579 | (1 #f)))) 580 | 581 | (test-->> rr 582 | (term 583 | (() ;; empty store 584 | (let ((x_1 new)) 585 | (let par ((x_2 (puti x_1 1)) 586 | (x_3 (get x_1 ((1 #f))))) 587 | (get x_1 ((1 #f))))))) 588 | (term 589 | (((l (1 #f))) 590 | (1 #f)))) 591 | 592 | (test-->> rr 593 | (term 594 | (() ;; empty store 595 | (let ((x_1 new)) 596 | (let par 597 | ;; Gets stuck trying to get 3 out of x_1, then 598 | ;; unstuck after the other subexpression finishes. 599 | ((x_4 (let par ((x_2 (puti x_1 1)) 600 | (x_3 (puti x_1 1))) 601 | (get x_1 ((3 #f))))) 602 | ;; Eventually puts 3 in x_1 after several dummy 603 | ;; beta-reductions. 604 | (x_5 ((lambda (x_2) 605 | ((lambda (x_2) 606 | ((lambda (x_2) 607 | ((lambda (x_2) 608 | ((lambda (x_2) 609 | (puti x_1 1)) ())) ())) ())) ())) ()))) 610 | x_4)))) 611 | (term 612 | (((l (3 #f))) 613 | (3 #f)))) 614 | 615 | (test-->> rr 616 | (term 617 | (() ;; empty store 618 | (let ((x_1 new)) 619 | (let ((x_2 (puti x_1 1))) 620 | (freeze x_1))))) 621 | (term 622 | (((l (1 #t))) 623 | 1))) 624 | 625 | ;; Thresholding on frozenness. 626 | (test-->> rr 627 | (term 628 | (() ;; empty store 629 | (let ((x_1 new)) 630 | (let par 631 | ((x_2 (get x_1 ((1 #t)))) 632 | (x_3 (freeze x_1 after (Bot) with (lambda (x) 633 | (puti x_1 1))))) 634 | x_2)))) 635 | (term 636 | (((l (1 #t))) 637 | (1 #t)))) 638 | 639 | ;; Mixing different update operations is fine, since they commute. 640 | (test-->> rr 641 | (term 642 | (() ;; empty store 643 | (let ((x_1 new)) 644 | (let par 645 | ((x_2 (puti x_1 1)) 646 | (x_3 (puti x_1 2))) 647 | (freeze x_1))))) 648 | (term 649 | (((l (3 #t))) 650 | 3))) 651 | 652 | ;; Here we have a quasi-deterministic program where a freeze and a 653 | ;; put are racing with each other. One of two things will happen: 654 | ;; both `puti`s will run before the freeze, so x_1 will be 2, or 655 | ;; the freeze will complete before both `puti`s have run, so the 656 | ;; program will raise an error. 657 | (test-->> rr 658 | (term 659 | (() ;; empty store 660 | (let ((x_1 new)) 661 | (let par 662 | ((x_2 (let ((x_4 (puti x_1 1))) 663 | (freeze x_1))) 664 | (x_3 (puti x_1 1))) 665 | x_2)))) 666 | (term 667 | (((l (2 #t))) 668 | 2)) 669 | (term 670 | Error)) 671 | 672 | ;; Similar to the above, but with `freeze ... after ... with` and 673 | ;; an additional `puti`. 674 | (test-->> rr 675 | (term 676 | (() ;; empty store 677 | (let ((x_1 new)) 678 | (let par 679 | ((x_2 (let ((x_4 (puti x_1 1))) 680 | (freeze x_1 after (Bot) with (lambda (x) 681 | (puti x_1 1))))) 682 | (x_3 (puti x_1 1))) 683 | x_2)))) 684 | (term 685 | (((l (3 #t))) 686 | 3)) 687 | (term 688 | Error)) 689 | 690 | ;; Suppose we don't do any writes to an LVar, but then we do a 691 | ;; freeze-after with a callback. The callback must still run at 692 | ;; least once, in order to add Bot to the `handled` set. 693 | (test-->> rr 694 | (term 695 | (() ;; empty store 696 | (let ((x_1 new)) 697 | (let ((x_2 new)) 698 | (let par 699 | ((x_3 (freeze x_1 after (Bot) with (lambda (x) 700 | (puti x_2 1)))) 701 | (x_4 (puti x_2 1))) 702 | x_3))))) 703 | (term 704 | (((l (Bot #t)) 705 | (l1 (2 #f))) 706 | Bot))) 707 | 708 | ;; Just trying some weird things. This program will fault if one 709 | ;; of the callback-triggered `puti`s completes after the other LVar 710 | ;; gets frozen, but it's also possible for the program to complete 711 | ;; successfully! 712 | (test-->> rr 713 | (term 714 | (() ;; empty store 715 | (let ((x_1 new)) 716 | (let ((x_2 new)) 717 | (let par 718 | ((x_3 (freeze x_1 after (Bot) with (lambda (x) 719 | (puti x_2 1)))) 720 | (x_4 (freeze x_2 after (Bot) with (lambda (x) 721 | (puti x_1 1))))) 722 | x_3))))) 723 | (term 724 | (((l (1 #t)) 725 | (l1 (1 #t))) 726 | 1)) 727 | (term 728 | Error)) 729 | 730 | ;; Trying out more interesting eval contexts. 731 | (test-->> rr 732 | (term 733 | (() ;; empty store 734 | (let ((x_1 new)) 735 | (let ((x_2 new)) 736 | (let ((x_3 (freeze ((lambda (x) x) x_2)))) 737 | x_3))))) 738 | (term 739 | (((l (Bot #f)) 740 | (l1 (Bot #t))) 741 | Bot))) 742 | 743 | (test-->> rr 744 | (term 745 | (() ;; empty store 746 | (let ((x_1 new)) 747 | (let ((x_2 new)) 748 | (let par 749 | ((x_3 (freeze x_1 after (Bot) with ((lambda (x) 750 | (lambda (x) 751 | (puti x_2 1))) 752 | ()))) 753 | (x_4 (freeze x_2 after (Bot) with ((lambda (x) 754 | (lambda (x) 755 | (puti x_1 1))) 756 | ())))) 757 | x_3))))) 758 | (term 759 | (((l (1 #t)) 760 | (l1 (1 #t))) 761 | 1)) 762 | (term 763 | Error)) 764 | 765 | (test-->> rr 766 | (term 767 | (() ;; empty store 768 | (let ((x_1 new)) 769 | (let ((x_2 new)) 770 | (let ((x_3 new)) 771 | (let par 772 | ((x_3 (freeze x_1 after (Bot) with ((lambda (x) 773 | (lambda (x) 774 | (puti x_2 1))) 775 | (puti x_3 1)))) 776 | (x_4 (freeze x_2 after (Bot) with ((lambda (x) 777 | (lambda (x) 778 | (puti x_1 1))) 779 | (puti x_3 1))))) 780 | x_3)))))) 781 | (term 782 | (((l (1 #t)) 783 | (l1 (1 #t)) 784 | (l2 (2 #f))) 785 | 1)) 786 | (term 787 | Error)) 788 | 789 | ;; Freezing an LVar twice with different values is 790 | ;; quasi-deterministic. 791 | (test-->> rr 792 | (term 793 | (() ;; empty store 794 | (let ((x_1 new)) 795 | (let par 796 | ((x_3 (freeze x_1 after (Bot) with ((lambda (x) 797 | (lambda (x) 798 | (puti x_1 1))) 799 | (puti x_1 1)))) 800 | (x_4 (freeze x_1 after (Bot) with (lambda (x) 801 | (puti x_1 1))))) 802 | x_3)))) 803 | (term 804 | (((l (3 #t))) 805 | 3)) 806 | (term 807 | Error)) 808 | 809 | (test-results))) 810 | 811 | (module test-all racket 812 | (require (submod ".." test-suite)) 813 | (test-all)) 814 | -------------------------------------------------------------------------------- /lambdaLVish/test-helpers.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide cfgs-equal-modulo-perms? 4 | stores-equal-modulo-perms?) 5 | (require srfi/1) 6 | 7 | ;; Takes two (S e) configurations and returns #t if they're equal 8 | ;; modulo permutations of store bindings. 9 | (define cfgs-equal-modulo-perms? 10 | (lambda (cfg1 cfg2) 11 | (and (stores-equal-modulo-perms? (car cfg1) (car cfg2)) 12 | (equal? (cdr cfg1) (cdr cfg2))))) 13 | 14 | ;; Takes two stores and returns #t if they're equal modulo 15 | ;; permutations. 16 | (define stores-equal-modulo-perms? 17 | (lambda (s1 s2) 18 | (lset= equal? s1 s2))) 19 | 20 | 21 | --------------------------------------------------------------------------------