Source file lazy_storage_diff.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
module type Next = sig
type id
val init : Raw_context.t -> Raw_context.t tzresult Lwt.t
val incr : Raw_context.t -> (Raw_context.t * id) tzresult Lwt.t
end
module type Total_bytes = sig
type id
val init : Raw_context.t -> id -> Z.t -> Raw_context.t tzresult Lwt.t
val get : Raw_context.t -> id -> Z.t tzresult Lwt.t
val update : Raw_context.t -> id -> Z.t -> Raw_context.t tzresult Lwt.t
end
(** Operations to be defined on a lazy storage type. *)
module type OPS = sig
module Id : Lazy_storage_kind.ID
type alloc
type updates
val title : string
val alloc_encoding : alloc Data_encoding.t
val updates_encoding : updates Data_encoding.t
val alloc_in_memory_size : alloc -> Cache_memory_helpers.nodes_and_size
val updates_in_memory_size : updates -> Cache_memory_helpers.nodes_and_size
val bytes_size_for_empty : Z.t
val alloc : Raw_context.t -> id:Id.t -> alloc -> Raw_context.t tzresult Lwt.t
val apply_updates :
Raw_context.t -> id:Id.t -> updates -> (Raw_context.t * Z.t) tzresult Lwt.t
module Next : Next with type id := Id.t
module Total_bytes : Total_bytes with type id := Id.t
(** Deep copy. *)
val copy :
Raw_context.t -> from:Id.t -> to_:Id.t -> Raw_context.t tzresult Lwt.t
(** Deep deletion. *)
val remove : Raw_context.t -> Id.t -> Raw_context.t Lwt.t
end
module Big_map = struct
include Lazy_storage_kind.Big_map
let alloc_in_memory_size {key_type; value_type} =
let open Cache_memory_helpers in
ret_adding
(expr_size key_type ++ expr_size value_type)
(header_size +! (word_size *? 2))
let updates_in_memory_size updates =
let open Cache_memory_helpers in
let update_size {key; key_hash = _; value} =
ret_adding
(expr_size key ++ option_size_vec expr_size value)
(header_size +! (word_size *? 3) +? Script_expr_hash.size)
in
list_fold_size update_size updates
let bytes_size_for_big_map_key = 65
let bytes_size_for_empty =
let bytes_size_for_big_map = 33 in
Z.of_int bytes_size_for_big_map
let alloc ctxt ~id {key_type; value_type} =
let key_type =
Micheline.strip_locations
(Script_repr.strip_annotations (Micheline.root key_type))
in
let value_type =
Micheline.strip_locations
(Script_repr.strip_annotations (Micheline.root value_type))
in
Storage.Big_map.Key_type.init ctxt id key_type >>=? fun ctxt ->
Storage.Big_map.Value_type.init ctxt id value_type
let apply_update ctxt ~id
{
key = _key_is_shown_only_on_the_receipt_in_print_big_map_diff;
key_hash;
value;
} =
match value with
| None ->
Storage.Big_map.Contents.remove (ctxt, id) key_hash
>|=? fun (ctxt, freed, existed) ->
let freed =
if existed then freed + bytes_size_for_big_map_key else freed
in
(ctxt, Z.of_int ~-freed)
| Some v ->
Storage.Big_map.Contents.add (ctxt, id) key_hash v
>|=? fun (ctxt, size_diff, existed) ->
let size_diff =
if existed then size_diff else size_diff + bytes_size_for_big_map_key
in
(ctxt, Z.of_int size_diff)
let apply_updates ctxt ~id updates =
List.fold_left_es
(fun (ctxt, size) update ->
apply_update ctxt ~id update >|=? fun (ctxt, added_size) ->
(ctxt, Z.add size added_size))
(ctxt, Z.zero)
updates
include Storage.Big_map
end
type ('id, 'alloc, 'updates) ops =
(module OPS
with type Id.t = 'id
and type alloc = 'alloc
and type updates = 'updates)
module Sapling_state = struct
include Lazy_storage_kind.Sapling_state
let alloc_in_memory_size {memo_size = (_ : int)} =
let open Cache_memory_helpers in
(Nodes.zero, header_size +! word_size)
let updates_in_memory_size update =
(Cache_memory_helpers.Nodes.zero, Sapling_repr.diff_in_memory_size update)
let bytes_size_for_empty = Z.of_int 33
let alloc ctxt ~id {memo_size} = Sapling_storage.init ctxt id ~memo_size
let apply_updates ctxt ~id updates =
Sapling_storage.apply_diff ctxt id updates
include Storage.Sapling
end
let get_ops : type i a u. (i, a, u) Lazy_storage_kind.t -> (i, a, u) ops =
function
| Big_map -> (module Big_map)
| Sapling_state -> (module Sapling_state)
type ('id, 'alloc) init = Existing | Copy of {src : 'id} | Alloc of 'alloc
type ('id, 'alloc, 'updates) diff =
| Remove
| Update of {init : ('id, 'alloc) init; updates : 'updates}
let diff_encoding : type i a u. (i, a, u) ops -> (i, a, u) diff Data_encoding.t
=
fun (module OPS) ->
let open Data_encoding in
union
[
case
(Tag 0)
~title:"update"
(obj2
(req "action" (constant "update"))
(req "updates" OPS.updates_encoding))
(function
| Update {init = Existing; updates} -> Some ((), updates) | _ -> None)
(fun ((), updates) -> Update {init = Existing; updates});
case
(Tag 1)
~title:"remove"
(obj1 (req "action" (constant "remove")))
(function Remove -> Some () | _ -> None)
(fun () -> Remove);
case
(Tag 2)
~title:"copy"
(obj3
(req "action" (constant "copy"))
(req "source" OPS.Id.encoding)
(req "updates" OPS.updates_encoding))
(function
| Update {init = Copy {src}; updates} -> Some ((), src, updates)
| _ -> None)
(fun ((), src, updates) -> Update {init = Copy {src}; updates});
case
(Tag 3)
~title:"alloc"
(merge_objs
(obj2
(req "action" (constant "alloc"))
(req "updates" OPS.updates_encoding))
OPS.alloc_encoding)
(function
| Update {init = Alloc alloc; updates} -> Some (((), updates), alloc)
| _ -> None)
(fun (((), updates), alloc) -> Update {init = Alloc alloc; updates});
]
let init_size :
type i a u.
(i, a, u) ops -> (i, a) init -> Cache_memory_helpers.nodes_and_size =
fun (module OPS) init ->
let open Cache_memory_helpers in
match init with
| Existing -> zero
| Copy {src = _id_is_a_Z_fitting_in_an_int_for_a_long_time} ->
(Nodes.zero, header_size +! word_size)
| Alloc alloc ->
ret_adding (OPS.alloc_in_memory_size alloc) (header_size +! word_size)
let updates_size :
type i a u. (i, a, u) ops -> u -> Cache_memory_helpers.nodes_and_size =
fun (module OPS) updates -> OPS.updates_in_memory_size updates
let diff_in_memory_size kind diff =
let open Cache_memory_helpers in
match diff with
| Remove -> zero
| Update {init; updates} ->
let ops = get_ops kind in
ret_adding (init_size ops init ++ updates_size ops updates) h2w
(**
[apply_updates ctxt ops ~id init] applies the updates [updates] on lazy
storage [id] on storage context [ctxt] using operations [ops] and returns the
updated storage context and the added size in bytes (may be negative).
*)
let apply_updates :
type i a u.
Raw_context.t ->
(i, a, u) ops ->
id:i ->
u ->
(Raw_context.t * Z.t) tzresult Lwt.t =
fun ctxt (module OPS) ~id updates ->
OPS.apply_updates ctxt ~id updates >>=? fun (ctxt, updates_size) ->
if Z.(equal updates_size zero) then return (ctxt, updates_size)
else
OPS.Total_bytes.get ctxt id >>=? fun size ->
OPS.Total_bytes.update ctxt id (Z.add size updates_size) >|=? fun ctxt ->
(ctxt, updates_size)
(**
[apply_init ctxt ops ~id init] applies the initialization [init] on lazy
storage [id] on storage context [ctxt] using operations [ops] and returns the
updated storage context and the added size in bytes (may be negative).
If [id] represents a temporary lazy storage, the added size may be wrong.
*)
let apply_init :
type i a u.
Raw_context.t ->
(i, a, u) ops ->
id:i ->
(i, a) init ->
(Raw_context.t * Z.t) tzresult Lwt.t =
fun ctxt (module OPS) ~id init ->
match init with
| Existing -> return (ctxt, Z.zero)
| Copy {src} ->
OPS.copy ctxt ~from:src ~to_:id >>=? fun ctxt ->
if OPS.Id.is_temp id then return (ctxt, Z.zero)
else
OPS.Total_bytes.get ctxt src >>=? fun copy_size ->
return (ctxt, Z.add copy_size OPS.bytes_size_for_empty)
| Alloc alloc ->
OPS.Total_bytes.init ctxt id Z.zero >>=? fun ctxt ->
OPS.alloc ctxt ~id alloc >>=? fun ctxt ->
return (ctxt, OPS.bytes_size_for_empty)
(**
[apply_diff ctxt ops ~id diff] applies the diff [diff] on lazy storage [id]
on storage context [ctxt] using operations [ops] and returns the updated
storage context and the added size in bytes (may be negative).
If [id] represents a temporary lazy storage, the added size may be wrong.
*)
let apply_diff :
type i a u.
Raw_context.t ->
(i, a, u) ops ->
id:i ->
(i, a, u) diff ->
(Raw_context.t * Z.t) tzresult Lwt.t =
fun ctxt ((module OPS) as ops) ~id diff ->
match diff with
| Remove ->
if OPS.Id.is_temp id then
OPS.remove ctxt id >|= fun ctxt -> ok (ctxt, Z.zero)
else
OPS.Total_bytes.get ctxt id >>=? fun size ->
OPS.remove ctxt id >>= fun ctxt ->
return (ctxt, Z.neg (Z.add size OPS.bytes_size_for_empty))
| Update {init; updates} ->
apply_init ctxt ops ~id init >>=? fun (ctxt, init_size) ->
apply_updates ctxt ops ~id updates >>=? fun (ctxt, updates_size) ->
return (ctxt, Z.add init_size updates_size)
type diffs_item =
| Item :
('i, 'a, 'u) Lazy_storage_kind.t * 'i * ('i, 'a, 'u) diff
-> diffs_item
let make :
type i a u.
(i, a, u) Lazy_storage_kind.t -> i -> (i, a, u) diff -> diffs_item =
fun k id diff -> Item (k, id, diff)
let item_encoding =
let open Data_encoding in
union
@@ List.map
(fun (tag, Lazy_storage_kind.Ex_Kind k) ->
let ops = get_ops k in
let (module OPS) = ops in
let title = OPS.title in
case
(Tag tag)
~title
(obj3
(req "kind" (constant title))
(req "id" OPS.Id.encoding)
(req "diff" (diff_encoding ops)))
(fun (Item (kind, id, diff)) ->
match Lazy_storage_kind.equal k kind with
| Eq -> Some ((), id, diff)
| Neq -> None)
(fun ((), id, diff) -> Item (k, id, diff)))
Lazy_storage_kind.all
let item_in_memory_size
(Item
( kind ,
_id_is_a_Z_fitting_in_an_int_for_a_long_time,
diff )) =
let open Cache_memory_helpers in
ret_adding (diff_in_memory_size kind diff) h3w
type diffs = diffs_item list
let diffs_in_memory_size diffs =
Cache_memory_helpers.list_fold_size item_in_memory_size diffs
let encoding =
let open Data_encoding in
def "lazy_storage_diff" @@ list item_encoding
let apply ctxt diffs =
List.fold_left_es
(fun (ctxt, total_size) (Item (k, id, diff)) ->
let ops = get_ops k in
apply_diff ctxt ops ~id diff >|=? fun (ctxt, added_size) ->
let (module OPS) = ops in
( ctxt,
if OPS.Id.is_temp id then total_size else Z.add total_size added_size ))
(ctxt, Z.zero)
diffs
let fresh :
type i a u.
(i, a, u) Lazy_storage_kind.t ->
temporary:bool ->
Raw_context.t ->
(Raw_context.t * i) tzresult Lwt.t =
fun kind ~temporary ctxt ->
if temporary then
return
(Raw_context.fold_map_temporary_lazy_storage_ids ctxt (fun temp_ids ->
Lazy_storage_kind.Temp_ids.fresh kind temp_ids))
else
let (module OPS) = get_ops kind in
OPS.Next.incr ctxt
let init ctxt =
List.fold_left_es
(fun ctxt (_tag, Lazy_storage_kind.Ex_Kind k) ->
let (module OPS) = get_ops k in
OPS.Next.init ctxt)
ctxt
Lazy_storage_kind.all
let cleanup_temporaries ctxt =
Raw_context.map_temporary_lazy_storage_ids_s ctxt (fun temp_ids ->
List.fold_left_s
(fun ctxt (_tag, Lazy_storage_kind.Ex_Kind k) ->
let (module OPS) = get_ops k in
Lazy_storage_kind.Temp_ids.fold_s k OPS.remove temp_ids ctxt)
ctxt
Lazy_storage_kind.all
>|= fun ctxt -> (ctxt, Lazy_storage_kind.Temp_ids.init))