|
1 ;; An implementation of transactional world state, after Henry Baker's |
|
2 ;; ideas in "Worlds in Collision: A Mostly Functional Model of |
|
3 ;; Concurrency Control and Recovery" (Unpublished memo, 1990). |
|
4 |
|
5 ;; Ada database package specification, [Baker90] p6: |
|
6 ; package database is |
|
7 ; type page is private; |
|
8 ; subtype index is 0 .. (N-1); |
|
9 ; type world is private; |
|
10 ; null_world: constant world; |
|
11 ; function lookup(i: index; w: world) return page; |
|
12 ; function update(i: index; p: page; w: world) return world; |
|
13 ; procedure assign_world(w: out world; w: world); |
|
14 ; procedure nupdate(i: index; p: page; w: in out world); |
|
15 ; end database; |
|
16 |
|
17 ;; This implementation: |
|
18 ;; - page == object |
|
19 ;; - index == symbol |
|
20 ;; - world == opaque map from index to page |
|
21 |
|
22 (require 'splay-tree) |
|
23 |
|
24 (define-record-type world |
|
25 (make-world map) |
|
26 world? |
|
27 (map world-map set-world-map!)) |
|
28 |
|
29 (define (entry-cmp ea eb) |
|
30 (let ((a (car ea)) |
|
31 (b (car eb))) |
|
32 (cond |
|
33 ((eq? a b) 0) |
|
34 ((string<? (symbol->string a) (symbol->string b)) -1) |
|
35 (else 1)))) |
|
36 |
|
37 (define (entry-cmp1 a) |
|
38 (let ((sa (symbol->string a))) |
|
39 (lambda (eb) |
|
40 (let ((b (car eb))) |
|
41 (cond |
|
42 ((eq? a b) 0) |
|
43 ((string<? sa (symbol->string b)) -1) |
|
44 (else 1)))))) |
|
45 |
|
46 (define (deep-binding) |
|
47 ;; switching from world-to-world: O(1) |
|
48 ;; lookup: O(M) |
|
49 ;; update/world-create: O(1) |
|
50 (let () |
|
51 (define null-world (make-world '())) |
|
52 |
|
53 (define (lookup i w default-page) |
|
54 (cond |
|
55 ((assq i (world-map w)) => cdr) |
|
56 (else default-page))) |
|
57 |
|
58 (define (update i p w) |
|
59 (make-world (cons (cons i p) (world-map w)))) |
|
60 |
|
61 (define (assign-world w1 w2) |
|
62 (set-world-map! w1 (world-map w2))) |
|
63 |
|
64 (define (nupdate i p w) |
|
65 (assign-world w (update i p w))) |
|
66 |
|
67 (values null-world |
|
68 lookup |
|
69 update |
|
70 assign-world |
|
71 nupdate))) |
|
72 |
|
73 (define (deep-binding/splay-tree) |
|
74 ;; switching from world-to-world: O(1) |
|
75 ;; lookup: O(log N) |
|
76 ;; update/world-create: O(log N) |
|
77 (let () |
|
78 (define null-world (make-world '())) |
|
79 |
|
80 (define (lookup i w default-page) |
|
81 (let ((cmp (entry-cmp1 i))) |
|
82 (splay-tree-find cmp |
|
83 (world-map w) |
|
84 (lambda (new-map) |
|
85 (set-world-map! w new-map) |
|
86 (cdr (bst-node-element new-map))) |
|
87 (lambda (new-map) |
|
88 (set-world-map! w new-map) |
|
89 default-page)))) |
|
90 |
|
91 (define (update i p w) |
|
92 (let ((cmp (entry-cmp1 i))) |
|
93 (make-world (splay-tree-insert/replace cmp |
|
94 (world-map w) |
|
95 (cons i p))))) |
|
96 |
|
97 (define (assign-world w1 w2) |
|
98 (set-world-map! w1 (world-map w2))) |
|
99 |
|
100 (define (nupdate i p w) |
|
101 (assign-world w (update i p w))) |
|
102 |
|
103 (values null-world |
|
104 lookup |
|
105 update |
|
106 assign-world |
|
107 nupdate))) |
|
108 |
|
109 (define (shallow-binding) |
|
110 (let () |
|
111 (define null-world (make-world '())) |
|
112 |
|
113 (define (onestep nw ow) |
|
114 (set-cdr! ( |
|
115 |
|
116 (define (lookup i w default-page) |
|
117 (cond |
|
118 ((assq i (world-map w)) => cdr) |
|
119 (else default-page))) |
|
120 |
|
121 (define (update i p w) |
|
122 (make-world (cons (cons i p) (world-map w)))) |
|
123 |
|
124 (define (assign-world w1 w2) |
|
125 (set-world-map! w1 (world-map w2))) |
|
126 |
|
127 (define (nupdate i p w) |
|
128 (assign-world w (update i p w))) |
|
129 |
|
130 (values null-world |
|
131 lookup |
|
132 update |
|
133 assign-world |
|
134 nupdate))) |