Mercurial > urweb
comparison src/effectize.sml @ 1104:72670131dace
Basis.serialize; separate file for mhash; run transactional finishers in reverse order; set needs_sig properly
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Thu, 31 Dec 2009 11:41:57 -0500 |
parents | dfe34fad749d |
children | 9d3ccb8b39ac |
comparison
equal
deleted
inserted
replaced
1103:2f42c61b8d0a | 1104:72670131dace |
---|---|
64 | 64 |
65 fun couldWrite evs = U.Exp.exists {kind = fn _ => false, | 65 fun couldWrite evs = U.Exp.exists {kind = fn _ => false, |
66 con = fn _ => false, | 66 con = fn _ => false, |
67 exp = exp evs} | 67 exp = exp evs} |
68 | 68 |
69 fun exp writers readers e = | |
70 case e of | |
71 EServerCall (n, _, _) => IM.inDomain (writers, n) andalso IM.inDomain (readers, n) | |
72 | _ => false | |
73 | |
74 fun couldWriteWithRpc writers readers = U.Exp.exists {kind = fn _ => false, | |
75 con = fn _ => false, | |
76 exp = exp writers readers} | |
77 | |
69 fun exp evs e = | 78 fun exp evs e = |
70 case e of | 79 case e of |
71 EFfi ("Basis", "getCookie") => true | 80 EFfi ("Basis", "getCookie") => true |
72 | ENamed n => IM.inDomain (evs, n) | 81 | ENamed n => IM.inDomain (evs, n) |
73 | EServerCall (n, _, _) => IM.inDomain (evs, n) | 82 | EServerCall (n, _, _) => IM.inDomain (evs, n) |
75 | 84 |
76 fun couldReadCookie evs = U.Exp.exists {kind = fn _ => false, | 85 fun couldReadCookie evs = U.Exp.exists {kind = fn _ => false, |
77 con = fn _ => false, | 86 con = fn _ => false, |
78 exp = exp evs} | 87 exp = exp evs} |
79 | 88 |
80 fun doDecl (d, evs as (writers, readers)) = | 89 fun doDecl (d, evs as (writers, readers, pushers)) = |
81 case #1 d of | 90 case #1 d of |
82 DVal (x, n, t, e, s) => | 91 DVal (x, n, t, e, s) => |
83 (d, (if couldWrite writers e then | 92 (d, (if couldWrite writers e then |
84 IM.insert (writers, n, (#2 d, s)) | 93 IM.insert (writers, n, (#2 d, s)) |
85 else | 94 else |
86 writers, | 95 writers, |
87 if couldReadCookie readers e then | 96 if couldReadCookie readers e then |
88 IM.insert (readers, n, (#2 d, s)) | 97 IM.insert (readers, n, (#2 d, s)) |
89 else | 98 else |
90 readers)) | 99 readers, |
100 if couldWriteWithRpc writers readers e then | |
101 IM.insert (pushers, n, (#2 d, s)) | |
102 else | |
103 pushers)) | |
91 | DValRec vis => | 104 | DValRec vis => |
92 let | 105 let |
93 fun oneRound evs = | 106 fun oneRound evs = |
94 foldl (fn ((_, n, _, e, s), (changed, (writers, readers))) => | 107 foldl (fn ((_, n, _, e, s), (changed, (writers, readers, pushers))) => |
95 let | 108 let |
96 val (changed, writers) = | 109 val (changed, writers) = |
97 if couldWrite writers e andalso not (IM.inDomain (writers, n)) then | 110 if couldWrite writers e andalso not (IM.inDomain (writers, n)) then |
98 (true, IM.insert (writers, n, (#2 d, s))) | 111 (true, IM.insert (writers, n, (#2 d, s))) |
99 else | 112 else |
102 val (changed, readers) = | 115 val (changed, readers) = |
103 if couldReadCookie readers e andalso not (IM.inDomain (readers, n)) then | 116 if couldReadCookie readers e andalso not (IM.inDomain (readers, n)) then |
104 (true, IM.insert (readers, n, (#2 d, s))) | 117 (true, IM.insert (readers, n, (#2 d, s))) |
105 else | 118 else |
106 (changed, readers) | 119 (changed, readers) |
120 | |
121 val (changed, pushers) = | |
122 if couldWriteWithRpc writers readers e | |
123 andalso not (IM.inDomain (pushers, n)) then | |
124 (true, IM.insert (pushers, n, (#2 d, s))) | |
125 else | |
126 (changed, pushers) | |
107 in | 127 in |
108 (changed, (writers, readers)) | 128 (changed, (writers, readers, pushers)) |
109 end) (false, evs) vis | 129 end) (false, evs) vis |
110 | 130 |
111 fun loop evs = | 131 fun loop evs = |
112 let | 132 let |
113 val (b, evs) = oneRound evs | 133 val (b, evs) = oneRound evs |
116 loop evs | 136 loop evs |
117 else | 137 else |
118 evs | 138 evs |
119 end | 139 end |
120 in | 140 in |
121 (d, loop (writers, readers)) | 141 (d, loop (writers, readers, pushers)) |
122 end | 142 end |
123 | DExport (Link, n) => | 143 | DExport (Link, n, _) => |
124 (case IM.find (writers, n) of | 144 (case IM.find (writers, n) of |
125 NONE => () | 145 NONE => () |
126 | SOME (loc, s) => ErrorMsg.errorAt loc ("A link (" ^ s ^ ") could cause side effects; try implementing it with a form instead"); | 146 | SOME (loc, s) => ErrorMsg.errorAt loc ("A link (" ^ s ^ ") could cause side effects; try implementing it with a form instead"); |
127 (d, evs)) | 147 ((DExport (Link, n, IM.inDomain (pushers, n)), #2 d), evs)) |
128 | DExport (Action _, n) => | 148 | DExport (Action _, n, _) => |
129 ((DExport (Action (if IM.inDomain (writers, n) then | 149 ((DExport (Action (if IM.inDomain (writers, n) then |
130 if IM.inDomain (readers, n) then | 150 if IM.inDomain (readers, n) then |
131 ReadCookieWrite | 151 ReadCookieWrite |
132 else | 152 else |
133 ReadWrite | 153 ReadWrite |
134 else | 154 else |
135 ReadOnly), n), #2 d), | 155 ReadOnly), n, IM.inDomain (pushers, n)), #2 d), |
136 evs) | 156 evs) |
137 | DExport (Rpc _, n) => | 157 | DExport (Rpc _, n, _) => |
138 ((DExport (Rpc (if IM.inDomain (writers, n) then | 158 ((DExport (Rpc (if IM.inDomain (writers, n) then |
139 if IM.inDomain (readers, n) then | 159 if IM.inDomain (readers, n) then |
140 ReadCookieWrite | 160 ReadCookieWrite |
141 else | 161 else |
142 ReadWrite | 162 ReadWrite |
143 else | 163 else |
144 ReadOnly), n), #2 d), | 164 ReadOnly), n, IM.inDomain (pushers, n)), #2 d), |
145 evs) | 165 evs) |
146 | _ => (d, evs) | 166 | _ => (d, evs) |
147 | 167 |
148 val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty) file | 168 val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty, IM.empty) file |
149 in | 169 in |
150 file | 170 file |
151 end | 171 end |
152 | 172 |
153 end | 173 end |