Proto/Michelson: lazy storage in interpreter

parent 1f3c1b6d
......@@ -721,6 +721,14 @@ module Lazy_storage : sig
type ('alloc, 'updates) t = Big_map : (Big_map.alloc, Big_map.updates) t
end
module KId : sig
type t = private E : (_, _) Kind.t * Z.t -> t
val make : (_, _) Kind.t -> Z.t -> t
val compare : t -> t -> int
end
type 'alloc init = Existing | Copy of {src : Z.t} | Alloc of 'alloc
type ('alloc, 'updates) diff =
......@@ -731,6 +739,8 @@ module Lazy_storage : sig
val make : ('a, 'u) Kind.t -> Z.t -> ('a, 'u) diff -> diffs_item
val make_remove : KId.t -> diffs_item
type diffs = diffs_item list
val encoding : diffs Data_encoding.t
......
......@@ -661,13 +661,13 @@ let apply_manager_operation_content :
>>=? fun ctxt ->
Script_ir_translator.parse_script ctxt ~legacy:false script
>>=? fun (Ex_script parsed_script, ctxt) ->
Script_ir_translator.collect_big_maps
Script_ir_translator.collect_lazy_storage
ctxt
parsed_script.storage_type
parsed_script.storage
>>=? fun (to_duplicate, ctxt) ->
let to_update = Script_ir_translator.no_big_map_id in
Script_ir_translator.extract_big_map_diff
let to_update = Script_ir_translator.no_lazy_storage_id in
Script_ir_translator.extract_lazy_storage_diff
ctxt
Optimized
parsed_script.storage_type
......
......@@ -309,7 +309,7 @@ let register () =
let open Script_ir_translator in
parse_script ctxt ~legacy:true script
>>=? fun (Ex_script script, ctxt) ->
Script_ir_translator.collect_big_maps
Script_ir_translator.collect_lazy_storage
ctxt
script.storage_type
script.storage
......
......@@ -23,6 +23,16 @@
(* *)
(*****************************************************************************)
module KId = struct
type t = E : (_, _) Lazy_storage_kind.t * Z.t -> t
let make kind id = E (kind, id)
let compare (E (kind1, id1)) (E (kind2, id2)) =
let c = Lazy_storage_kind.compare kind1 kind2 in
if Compare.Int.(c <> 0) then c else Compare.Z.compare id1 id2
end
module type OPS = sig
type alloc
......@@ -214,6 +224,8 @@ let make :
type a u. (a, u) Lazy_storage_kind.t -> Z.t -> (a, u) diff -> diffs_item =
fun k id diff -> E (k, id, diff)
let make_remove (KId.E (k, id)) = E (k, id, Remove)
let item_encoding =
let open Data_encoding in
union
......
......@@ -23,6 +23,14 @@
(* *)
(*****************************************************************************)
module KId : sig
type t = private E : (_, _) Lazy_storage_kind.t * Z.t -> t
val make : (_, _) Lazy_storage_kind.t -> Z.t -> t
val compare : t -> t -> int
end
module Big_map : sig
type alloc = Lazy_storage_kind.Big_map.alloc = {
key_type : Script_repr.expr;
......@@ -49,6 +57,8 @@ type diffs_item = private
val make : ('a, 'u) Lazy_storage_kind.t -> Z.t -> ('a, 'u) diff -> diffs_item
val make_remove : KId.t -> diffs_item
type diffs = diffs_item list
val encoding : diffs Data_encoding.t
......
......@@ -70,3 +70,6 @@ let eq :
type a1 u1 a2 u2. (a1, u1) t -> (a2, u2) t -> (a1 * u1, a2 * u2) eq option
=
fun k1 k2 -> match (k1, k2) with (Big_map, Big_map) -> Some Eq
let compare : type a1 u1 a2 u2. (a1, u1) t -> (a2, u2) t -> int =
fun k1 k2 -> match (k1, k2) with (Big_map, Big_map) -> 0
......@@ -354,15 +354,15 @@ let init ctxt block_header =
(script : Alpha_context.Script.t) =
Script_ir_translator.parse_script ctxt ~legacy:false script
>>=? fun (Ex_script parsed_script, ctxt) ->
Script_ir_translator.extract_big_map_diff
Script_ir_translator.extract_lazy_storage_diff
ctxt
Optimized
parsed_script.storage_type
parsed_script.storage
~to_duplicate:Script_ir_translator.no_big_map_id
~to_update:Script_ir_translator.no_big_map_id
~to_duplicate:Script_ir_translator.no_lazy_storage_id
~to_update:Script_ir_translator.no_lazy_storage_id
~temporary:false
>>=? fun (storage, big_map_diff, ctxt) ->
>>=? fun (storage, lazy_storage_diff, ctxt) ->
Script_ir_translator.unparse_data
ctxt
Optimized
......@@ -372,7 +372,7 @@ let init ctxt block_header =
let storage =
Alpha_context.Script.lazy_expr (Micheline.strip_locations storage)
in
return (({script with storage}, big_map_diff), ctxt)
return (({script with storage}, lazy_storage_diff), ctxt)
in
Alpha_context.prepare_first_block ~typecheck ~level ~timestamp ~fitness ctxt
>>=? fun ctxt -> return (Alpha_context.finalize ctxt)
......@@ -1053,10 +1053,10 @@ let rec step :
logged_return ((None, rest), ctxt) )
| (Transfer_tokens, (p, (amount, ((tp, (destination, entrypoint)), rest))))
->
collect_big_maps ctxt tp p
collect_lazy_storage ctxt tp p
>>=? fun (to_duplicate, ctxt) ->
let to_update = no_big_map_id in
extract_big_map_diff
let to_update = no_lazy_storage_id in
extract_lazy_storage_diff
ctxt
Optimized
tp
......@@ -1064,7 +1064,7 @@ let rec step :
~to_duplicate
~to_update
~temporary:true
>>=? fun (p, big_map_diff, ctxt) ->
>>=? fun (p, lazy_storage_diff, ctxt) ->
unparse_data ctxt Optimized tp p
>>=? fun (p, ctxt) ->
let operation =
......@@ -1081,7 +1081,7 @@ let rec step :
logged_return
( ( ( Internal_operation
{source = step_constants.self; operation; nonce},
big_map_diff ),
lazy_storage_diff ),
rest ),
ctxt )
| (Create_account, (manager, (delegate, (_delegatable, (credit, rest))))) ->
......@@ -1134,10 +1134,10 @@ let rec step :
Prim (0, K_storage, [unparsed_storage_type], []);
Prim (0, K_code, [code], []) ] ))
in
collect_big_maps ctxt storage_type init
collect_lazy_storage ctxt storage_type init
>>=? fun (to_duplicate, ctxt) ->
let to_update = no_big_map_id in
extract_big_map_diff
let to_update = no_lazy_storage_id in
extract_lazy_storage_diff
ctxt
Optimized
storage_type
......@@ -1145,7 +1145,7 @@ let rec step :
~to_duplicate
~to_update
~temporary:true
>>=? fun (init, big_map_diff, ctxt) ->
>>=? fun (init, lazy_storage_diff, ctxt) ->
unparse_data ctxt Optimized storage_type init
>>=? fun (storage, ctxt) ->
let storage = Script.lazy_expr @@ Micheline.strip_locations storage in
......@@ -1180,7 +1180,7 @@ let rec step :
logged_return
( ( ( Internal_operation
{source = step_constants.self; operation; nonce},
big_map_diff ),
lazy_storage_diff ),
((contract, "default"), rest) ),
ctxt )
| ( Create_contract_2 (storage_type, param_type, Lam (_, code), root_name),
......@@ -1204,10 +1204,10 @@ let rec step :
Prim (0, K_storage, [unparsed_storage_type], []);
Prim (0, K_code, [code], []) ] ))
in
collect_big_maps ctxt storage_type init
collect_lazy_storage ctxt storage_type init
>>=? fun (to_duplicate, ctxt) ->
let to_update = no_big_map_id in
extract_big_map_diff
let to_update = no_lazy_storage_id in
extract_lazy_storage_diff
ctxt
Optimized
storage_type
......@@ -1215,7 +1215,7 @@ let rec step :
~to_duplicate
~to_update
~temporary:true
>>=? fun (init, big_map_diff, ctxt) ->
>>=? fun (init, lazy_storage_diff, ctxt) ->
unparse_data ctxt Optimized storage_type init
>>=? fun (storage, ctxt) ->
let storage = Micheline.strip_locations storage in
......@@ -1239,7 +1239,7 @@ let rec step :
logged_return
( ( ( Internal_operation
{source = step_constants.self; operation; nonce},
big_map_diff ),
lazy_storage_diff ),
((contract, "default"), rest) ),
ctxt )
| (Set_delegate, (delegate, rest)) ->
......@@ -1364,15 +1364,15 @@ let execute logger ctxt mode step_constants ~entrypoint unparsed_script arg :
>>=? fun (arg, ctxt) ->
Script.force_decode ctxt unparsed_script.code
>>=? fun (script_code, ctxt) ->
Script_ir_translator.collect_big_maps ctxt arg_type arg
Script_ir_translator.collect_lazy_storage ctxt arg_type arg
>>=? fun (to_duplicate, ctxt) ->
Script_ir_translator.collect_big_maps ctxt storage_type storage
Script_ir_translator.collect_lazy_storage ctxt storage_type storage
>>=? fun (to_update, ctxt) ->
trace
(Runtime_contract_error (step_constants.self, script_code))
(interp logger ctxt step_constants code (arg, storage))
>>=? fun ((ops, storage), ctxt) ->
Script_ir_translator.extract_big_map_diff
Script_ir_translator.extract_lazy_storage_diff
ctxt
mode
~temporary:false
......@@ -1380,21 +1380,21 @@ let execute logger ctxt mode step_constants ~entrypoint unparsed_script arg :
~to_update
storage_type
storage
>>=? fun (storage, big_map_diff, ctxt) ->
>>=? fun (storage, lazy_storage_diff, ctxt) ->
trace Cannot_serialize_storage (unparse_data ctxt mode storage_type storage)
>>=? fun (storage, ctxt) ->
let (ops, op_diffs) = List.split ops.elements in
let big_map_diff =
let lazy_storage_diff =
match
List.flatten
(List.map (Option.unopt ~default:[]) (op_diffs @ [big_map_diff]))
(List.map (Option.unopt ~default:[]) (op_diffs @ [lazy_storage_diff]))
with
| [] ->
None
| diff ->
Some diff
in
return (Micheline.strip_locations storage, ops, ctxt, big_map_diff)
return (Micheline.strip_locations storage, ops, ctxt, lazy_storage_diff)
type execution_result = {
ctxt : context;
......
......@@ -5519,17 +5519,18 @@ let big_map_get ctxt key {id; diff; key_type; value_type} =
let big_map_update key value ({diff; _} as map) =
{map with diff = map_set key value diff}
module Ids = Set.Make (Compare.Z)
module Ids = Set.Make (Lazy_storage.KId)
type big_map_ids = Ids.t
type lazy_storage_ids = Ids.t
let no_big_map_id = Ids.empty
let no_lazy_storage_id = Ids.empty
let diff_of_big_map ctxt mode ~temporary ~ids {id; key_type; value_type; diff}
=
( match id with
| Some id ->
if Ids.mem id ids then
let kid = Lazy_storage.KId.make Big_map id in
if Ids.mem kid ids then
Big_map.fresh ~temporary ctxt
>>=? fun (ctxt, duplicate) ->
return (ctxt, Lazy_storage.Copy {src = id}, duplicate)
......@@ -5540,7 +5541,7 @@ let diff_of_big_map ctxt mode ~temporary ~ids {id; key_type; value_type; diff}
the global diff, otherwise the duplicates will use the
updated version as a base. This is true because we add
this diff first in the accumulator of
`extract_big_map_updates`, and this accumulator is not
`extract_lazy_storage_updates`, and this accumulator is not
reversed before being flattened. *)
return (ctxt, Lazy_storage.Existing, id)
| None ->
......@@ -5585,7 +5586,7 @@ let diff_of_big_map ctxt mode ~temporary ~ids {id; key_type; value_type; diff}
map.
This flag is built in [has_big_map] and used only in
[extract_big_map_updates] and [collect_big_maps].
[extract_lazy_storage_updates] and [collect_lazy_storage].
This flag is necessary to avoid these two functions to have a quadratic
complexity in the size of the type.
......@@ -5651,7 +5652,7 @@ let rec has_big_map : type t. t ty -> t has_big_map =
| Map_t (_, t, _) ->
aux1 (fun h -> Map_f h) t
let extract_big_map_updates ctxt mode ~temporary ids acc ty x =
let extract_lazy_storage_updates ctxt mode ~temporary ids acc ty x =
let rec aux :
type a.
context ->
......@@ -5675,7 +5676,8 @@ let extract_big_map_updates ctxt mode ~temporary ids acc ty x =
let (module Map) = map.diff in
let map = {map with diff = empty_map Map.key_ty; id = Some id} in
let diff = Lazy_storage.make Big_map id diff in
return (ctxt, map, Ids.add id ids, diff :: acc)
let kid = Lazy_storage.KId.make Big_map id in
return (ctxt, map, Ids.add kid ids, diff :: acc)
| (Pair_f (hl, hr), Pair_t ((tyl, _, _), (tyr, _, _), _), (xl, xr)) ->
aux ctxt mode ~temporary ids acc tyl xl ~has_big_map:hl
>>=? fun (ctxt, xl, ids, acc) ->
......@@ -5743,7 +5745,7 @@ let extract_big_map_updates ctxt mode ~temporary ids acc ty x =
let has_big_map = has_big_map ty in
aux ctxt mode ~temporary ids acc ty x ~has_big_map
let collect_big_maps ctxt ty x =
let collect_lazy_storage ctxt ty x =
let rec collect :
type a.
context ->
......@@ -5760,7 +5762,9 @@ let collect_big_maps ctxt ty x =
ok (acc, ctxt)
| (_, Big_map_t (_, _, _), {id = Some id}) ->
Gas.consume ctxt Typecheck_costs.cycle
>>? fun ctxt -> ok (Ids.add id acc, ctxt)
>>? fun ctxt ->
let kid = Lazy_storage.KId.make Big_map id in
ok (Ids.add kid acc, ctxt)
| (Pair_f (hl, hr), Pair_t ((tyl, _, _), (tyr, _, _), _), (xl, xr)) ->
collect ctxt tyl xl ~has_big_map:hl acc
>>? fun (acc, ctxt) -> collect ctxt tyr xr ~has_big_map:hr acc
......@@ -5793,20 +5797,18 @@ let collect_big_maps ctxt ty x =
(* TODO: fix injectivity of types *)
in
let has_big_map = has_big_map ty in
Lwt.return (collect ctxt ty x ~has_big_map no_big_map_id)
Lwt.return (collect ctxt ty x ~has_big_map no_lazy_storage_id)
let extract_big_map_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v =
let extract_lazy_storage_diff ctxt mode ~temporary ~to_duplicate ~to_update ty
v =
let to_duplicate = Ids.diff to_duplicate to_update in
extract_big_map_updates ctxt mode ~temporary to_duplicate [] ty v
extract_lazy_storage_updates ctxt mode ~temporary to_duplicate [] ty v
>>=? fun (ctxt, v, alive, diffs) ->
let diffs =
if temporary then diffs
else
let dead = Ids.diff to_update alive in
Ids.fold
(fun id acc -> Lazy_storage.(make Big_map id Remove) :: acc)
dead
diffs
Ids.fold (fun kid acc -> Lazy_storage.make_remove kid :: acc) dead diffs
in
match diffs with
| [] ->
......@@ -5814,4 +5816,9 @@ let extract_big_map_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v =
| diffs ->
return (v, Some diffs (* do not reverse *), ctxt)
let list_of_big_map_ids ids = Ids.elements ids
let list_of_big_map_ids kids =
Ids.fold
(fun (Lazy_storage.KId.E (kind, id)) acc ->
match kind with Lazy_storage.Kind.Big_map -> id :: acc)
kids
[]
......@@ -303,24 +303,24 @@ val hash_data :
'a ->
(Script_expr_hash.t * context) tzresult Lwt.t
type big_map_ids
type lazy_storage_ids
val no_big_map_id : big_map_ids
val no_lazy_storage_id : lazy_storage_ids
val collect_big_maps :
val collect_lazy_storage :
context ->
'a Script_typed_ir.ty ->
'a ->
(big_map_ids * context) tzresult Lwt.t
(lazy_storage_ids * context) tzresult Lwt.t
val list_of_big_map_ids : big_map_ids -> Z.t list
val list_of_big_map_ids : lazy_storage_ids -> Z.t list
val extract_big_map_diff :
val extract_lazy_storage_diff :
context ->
unparsing_mode ->
temporary:bool ->
to_duplicate:big_map_ids ->
to_update:big_map_ids ->
to_duplicate:lazy_storage_ids ->
to_update:lazy_storage_ids ->
'a Script_typed_ir.ty ->
'a ->
('a * Lazy_storage.diffs option * context) tzresult Lwt.t
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment