Alpha: lazily deserialize scripts

src/proto_alpha/lib_client/client_proto_context.ml

@@ -49,6 +49,7 @@ let transfer (cctxt : #Proto_alpha.full)
   Alpha_services.Contract.counter
     cctxt block source >>=? fun pcounter ->
   let counter = Int32.succ pcounter in
+  let parameters = Option.map ~f:Script.lazy_expr parameters in
   let operations = [Transaction { amount ; parameters ; destination }] in
   append_reveal cctxt block ~source ~src_pk operations >>=? fun operations ->
   let contents =
@@ -221,6 +222,7 @@ let originate_contract
   Lwt.return (Michelson_v1_parser.parse_expression initial_storage) >>= fun result ->
   Lwt.return (Micheline_parser.no_parsing_error result) >>=?
   fun { Michelson_v1_parser.expanded = storage } ->
+  let code = Script.lazy_expr code and storage = Script.lazy_expr storage in
   let origination =
     Origination { manager ;
                   delegate ;

src/proto_alpha/lib_client/michelson_v1_error_reporter.ml

@@ -248,6 +248,10 @@ let report_errors ~details ~show_source ?parsed ppf errs =
                 Contract.pp c
                 print_expr expected
           | Apply.Bad_contract_parameter (c, Some expected, Some argument) ->
+              let argument =
+                Option.unopt_exn
+                  (Failure "ill-serialized argument")
+                  (Data_encoding.force_decode argument) in
               Format.fprintf ppf
                 "@[<v 0>Contract %a expected an argument of type@,  %a@,but received@,  %a@]"
                 Contract.pp c

src/proto_alpha/lib_client/operation_result.ml

@@ -28,6 +28,10 @@ let pp_manager_operation_content ppf source operation internal pp_result result
         begin match parameters with
           | None -> ()
           | Some expr ->
+              let expr =
+                Option.unopt_exn
+                  (Failure "ill-serialized argument")
+                  (Data_encoding.force_decode expr) in
               Format.fprintf ppf
                 "@,Parameter: @[<v 0>%a@]"
                 Michelson_v1_printer.print_expr expr
@@ -47,6 +51,14 @@ let pp_manager_operation_content ppf source operation internal pp_result result
         begin match script with
           | None -> Format.fprintf ppf "@,No script (accepts all transactions)"
           | Some { code ; storage } ->
+              let code =
+                Option.unopt_exn
+                  (Failure "ill-serialized code")
+                  (Data_encoding.force_decode code)
+              and storage =
+                Option.unopt_exn
+                  (Failure "ill-serialized storage")
+                  (Data_encoding.force_decode storage) in
               Format.fprintf ppf
                 "@,@[<hv 2>Script:@ %a\
                  @,@[<hv 2>Initial storage:@ %a@]"

src/proto_alpha/lib_protocol/src/alpha_context.mli

@@ -272,16 +272,23 @@ module Script : sig
 
   type expr = prim Micheline.canonical
 
+  type lazy_expr = expr Data_encoding.lazy_t
+
+  val force_decode : lazy_expr -> expr tzresult
+  val force_bytes : lazy_expr -> MBytes.t tzresult
+  val lazy_expr : expr -> lazy_expr
+
   type node = (location, prim) Micheline.node
 
   type t =
-    { code: expr ;
+    { code: lazy_expr ;
-      storage: expr }
+      storage: lazy_expr }
 
   val location_encoding: location Data_encoding.t
   val expr_encoding: expr Data_encoding.t
   val prim_encoding: prim Data_encoding.t
   val encoding: t Data_encoding.t
+  val lazy_expr_encoding: lazy_expr Data_encoding.t
 end
 
 module Constants : sig
@@ -788,7 +795,7 @@ and manager_operation =
   | Reveal of Signature.Public_key.t
   | Transaction of {
       amount: Tez.t ;
-      parameters: Script.expr option ;
+      parameters: Script.lazy_expr option ;
       destination: Contract.contract ;
     }
   | Origination of {

src/proto_alpha/lib_protocol/src/apply.ml

@@ -14,7 +14,7 @@ open Alpha_context
 type error += Wrong_voting_period of Voting_period.t * Voting_period.t (* `Temporary *)
 type error += Wrong_endorsement_predecessor of Block_hash.t * Block_hash.t (* `Temporary *)
 type error += Duplicate_endorsement of int (* `Branch *)
-type error += Bad_contract_parameter of Contract.t * Script.expr option * Script.expr option (* `Permanent *)
+type error += Bad_contract_parameter of Contract.t * Script.expr option * Script.lazy_expr option (* `Permanent *)
 type error += Invalid_endorsement_level
 type error += Invalid_commitment of { expected: bool }
 
@@ -79,7 +79,7 @@ let () =
     Data_encoding.(obj3
                      (req "contract" Contract.encoding)
                      (opt "expectedType" Script.expr_encoding)
-                     (opt "providedArgument" Script.expr_encoding))
+                     (opt "providedArgument" Script.lazy_expr_encoding))
     (function Bad_contract_parameter (c, expected, supplied) ->
        Some (c, expected, supplied) | _ -> None)
     (fun (c, expected, supplied) -> Bad_contract_parameter (c, expected, supplied)) ;
@@ -404,6 +404,7 @@ let apply_manager_operation_content ctxt ~payer ~source ~internal operation =
           match parameters with
           | None -> return ()
           | Some arg ->
+              Lwt.return (Script.force_decode arg) >>=? fun arg ->
               match Micheline.root arg with
               | Prim (_, D_Unit, [], _) ->
                   return ()
@@ -422,16 +423,18 @@ let apply_manager_operation_content ctxt ~payer ~source ~internal operation =
                 storage_size_diff = 0L } in
           return (ctxt, result)
       | Some script ->
-          Lwt.return @@ Script_ir_translator.parse_toplevel script.code >>=? fun (arg_type, _, _) ->
+          Lwt.return (Script.force_decode script.code) >>=? fun code ->
+          Lwt.return @@ Script_ir_translator.parse_toplevel code >>=? fun (arg_type, _, _) ->
           let arg_type = Micheline.strip_locations arg_type in
           begin match parameters, Micheline.root arg_type with
             | None, Prim (_, T_unit, _, _) ->
                 return (ctxt, (Micheline.strip_locations (Prim (0, Script.D_Unit, [], None))))
             | Some parameters, _ ->
+                Lwt.return (Script.force_decode parameters) >>=? fun arg ->
                 trace
                   (Bad_contract_parameter (destination, Some arg_type, Some parameters))
-                  (Script_ir_translator.typecheck_data ctxt ~check_operations:true (parameters, arg_type)) >>=? fun ctxt ->
+                  (Script_ir_translator.typecheck_data ctxt ~check_operations:true (arg, arg_type)) >>=? fun ctxt ->
-                return (ctxt, parameters)
+                return (ctxt, arg)
             | None, _ -> fail (Bad_contract_parameter (destination, Some arg_type, None))
           end >>=? fun (ctxt, parameter) ->
           Script_interpreter.execute

src/proto_alpha/lib_protocol/src/contract_storage.ml

@@ -309,7 +309,12 @@ let get_script c contract =
   | Some code, Some storage -> return (c, Some { Script_repr.code ; storage })
   | None, Some _ | Some _, None -> failwith "get_script"
 
-let get_storage = Storage.Contract.Storage.get_option
+let get_storage ctxt contract =
+  Storage.Contract.Storage.get_option ctxt contract >>=? function
+  | (ctxt, None) -> return (ctxt, None)
+  | (ctxt, Some storage) ->
+      Lwt.return (Script_repr.force_decode storage) >>=? fun storage ->
+      return (ctxt, Some storage)
 
 let get_counter c contract =
   Storage.Contract.Counter.get_option c contract >>=? function
@@ -370,6 +375,7 @@ let is_spendable c contract =
       Storage.Contract.Spendable.mem c contract >>= return
 
 let update_script_storage c contract storage big_map_diff =
+  let storage = Script_repr.lazy_expr storage in
   update_script_big_map c contract big_map_diff >>=? fun (c, big_map_size_diff) ->
   Storage.Contract.Storage.set c contract storage >>=? fun (c, size_diff) ->
   Storage.Contract.Used_storage_space.get c contract >>=? fun previous_size ->

src/proto_alpha/lib_protocol/src/helpers_services.ml

@@ -158,6 +158,8 @@ let () =
     (code, storage, parameter, amount, contract) ->
     Lwt.return (Gas.set_limit ctxt (Constants.hard_gas_limit_per_operation ctxt)) >>=? fun ctxt ->
     let ctxt = Contract.init_origination_nonce ctxt Operation_hash.zero in
+    let storage = Script.lazy_expr storage in
+    let code = Script.lazy_expr code in
     Script_interpreter.execute
       ctxt
       ~check_operations:true
@@ -172,6 +174,8 @@ let () =
     (code, storage, parameter, amount, contract) ->
     Lwt.return (Gas.set_limit ctxt (Constants.hard_gas_limit_per_operation ctxt)) >>=? fun ctxt ->
     let ctxt = Contract.init_origination_nonce ctxt Operation_hash.zero in
+    let storage = Script.lazy_expr storage in
+    let code = Script.lazy_expr code in
     Script_interpreter.trace
       ctxt
       ~check_operations:true
@@ -328,6 +332,7 @@ module Forge = struct
         block ~branch ~source ?sourcePubKey ~counter
         ~amount ~destination ?parameters
         ~gas_limit ~storage_limit ~fee ()=
+      let parameters = Option.map ~f:Script.lazy_expr parameters in
       operations ctxt block ~branch ~source ?sourcePubKey ~counter
         ~fee ~gas_limit ~storage_limit
         Alpha_context.[Transaction { amount ; parameters ; destination }]

src/proto_alpha/lib_protocol/src/operation_repr.ml

@@ -82,7 +82,7 @@ and manager_operation =
   | Reveal of Signature.Public_key.t
   | Transaction of {
       amount: Tez_repr.tez ;
-      parameters: Script_repr.expr option ;
+      parameters: Script_repr.lazy_expr option ;
       destination: Contract_repr.contract ;
     }
   | Origination of {
@@ -131,7 +131,7 @@ module Encoding = struct
       (req "kind" (constant "transaction"))
       (req "amount" Tez_repr.encoding)
       (req "destination" Contract_repr.encoding)
-      (opt "parameters" Script_repr.expr_encoding)
+      (opt "parameters" Script_repr.lazy_expr_encoding)
 
   let transaction_case tag =
     case tag ~name:"Transaction" transaction_encoding

src/proto_alpha/lib_protocol/src/operation_repr.mli

@@ -82,7 +82,7 @@ and manager_operation =
   | Reveal of Signature.Public_key.t
   | Transaction of {
       amount: Tez_repr.tez ;
-      parameters: Script_repr.expr option ;
+      parameters: Script_repr.lazy_expr option ;
       destination: Contract_repr.contract ;
     }
   | Origination of {

src/proto_alpha/lib_protocol/src/script_interpreter.ml

@@ -165,7 +165,9 @@ let rec interp
             let operation =
               Origination
                 { credit ; manager ; delegate ; preorigination = Some contract ;
-                  delegatable ; script = Some { code ; storage } ; spendable } in
+                  delegatable ; spendable ;
+                  script = Some { code = Script.lazy_expr code ;
+                                  storage = Script.lazy_expr storage } } in
             logged_return descr (Item ({ source = self ; operation ; signature = None },
                                        Item (contract, rest)), ctxt) in
         let logged_return :
@@ -666,7 +668,7 @@ let rec interp
             let operation =
               Transaction
                 { amount ; destination ;
-                  parameters = Some (Micheline.strip_locations p) } in
+                  parameters = Some (Script.lazy_expr (Micheline.strip_locations p)) } in
             logged_return (Item ({ source = self ; operation ; signature = None }, rest), ctxt)
         | Create_account,
           Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) ->
@@ -758,8 +760,9 @@ and execute ?log ctxt ~check_operations ~source ~payer ~self script amount arg :
   parse_script ctxt ~check_operations script
   >>=? fun ((Ex_script { code ; arg_type ; storage ; storage_type }), ctxt) ->
   parse_data ctxt ~check_operations arg_type arg >>=? fun (arg, ctxt) ->
+  Lwt.return (Script.force_decode script.code) >>=? fun script_code ->
   trace
-    (Runtime_contract_error (self, script.code))
+    (Runtime_contract_error (self, script_code))
     (interp ?log ctxt ~source ~payer ~self amount code (arg, storage))
   >>=? fun ((ops, sto), ctxt) ->
   Lwt.return @@ unparse_data ctxt storage_type sto >>=? fun (storage, ctxt) ->

src/proto_alpha/lib_protocol/src/script_ir_translator.ml

@@ -2267,7 +2267,8 @@ and parse_contract
                ok (contract, ctxt))
         | Some { code ; _ } ->
             Lwt.return
-              (parse_toplevel code >>? fun (arg_type, _, _) ->
+              (Script.force_decode code >>? fun code ->
+               parse_toplevel code >>? fun (arg_type, _, _) ->
                parse_ty ~allow_big_map:false arg_type >>? fun (Ex_ty targ, _) ->
                ty_eq targ arg >>? fun Eq ->
                let contract : arg typed_contract = (arg, contract) in
@@ -2318,6 +2319,8 @@ let parse_script
   : ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
     context -> check_operations:bool -> Script.t -> (ex_script * context) tzresult Lwt.t
   = fun ?type_logger ctxt ~check_operations { code ; storage } ->
+    Lwt.return (Script.force_decode code) >>=? fun code ->
+    Lwt.return (Script.force_decode storage) >>=? fun storage ->
     Lwt.return (parse_toplevel code) >>=? fun (arg_type, storage_type, code_field) ->
     trace
       (Ill_formed_type (Some "parameter", code, location arg_type))
@@ -2348,7 +2351,8 @@ let parse_contract :
           | _ -> fail (Invalid_contract (loc, contract))
         end
     | Some script ->
-        Lwt.return @@ parse_toplevel script.code >>=? fun (arg_type, _, _) ->
+        Lwt.return (Script.force_decode script.code) >>=? fun code ->
+        Lwt.return @@ parse_toplevel code >>=? fun (arg_type, _, _) ->
         let arg_type = Micheline.strip_locations arg_type in
         Lwt.return (parse_ty ~allow_big_map:false (Micheline.root arg_type)) >>=? fun (Ex_ty arg_type, _) ->
         Lwt.return (ty_eq ty arg_type) >>=? fun Eq ->
@@ -2468,6 +2472,8 @@ let to_printable_big_map ctxt (Ex_bm { diff ; key_type ; value_type }) =
          Option.map ~f:(fun x -> Micheline.strip_locations @@ unparse value_type x) value) :: acc)) [] pairs
 
 let erase_big_map_initialization ctxt ({ code ; storage } : Script.t) =
+  Lwt.return (Script.force_decode code) >>=? fun code ->
+  Lwt.return (Script.force_decode storage) >>=? fun storage ->
   Lwt.return @@ parse_toplevel code >>=? fun (_, storage_type, _) ->
   Lwt.return @@ parse_ty ~allow_big_map:true storage_type >>=? fun (Ex_ty ty, _) ->
   parse_data ctxt ~check_operations:true ty
@@ -2479,4 +2485,5 @@ let erase_big_map_initialization ctxt ({ code ; storage } : Script.t) =
         return (Some bm, ctxt)
   end >>=? fun (bm, ctxt) ->
   Lwt.return @@ unparse_data ctxt ty storage >>=? fun (storage, ctxt) ->
-  return ({ code ; storage = Micheline.strip_locations storage }, bm, ctxt)
+  return ({ code = Script.lazy_expr code ;
+            storage = Script.lazy_expr (Micheline.strip_locations storage) }, bm, ctxt)

src/proto_alpha/lib_protocol/src/script_repr.ml

@@ -13,6 +13,8 @@ let location_encoding = Micheline.canonical_location_encoding
 
 type expr = Michelson_v1_primitives.prim Micheline.canonical
 
+type lazy_expr = expr Data_encoding.lazy_t
+
 type node = (location, Michelson_v1_primitives.prim) Micheline.node
 
 let expr_encoding =
@@ -20,11 +22,44 @@ let expr_encoding =
     ~variant:"michelson_v1"
     Michelson_v1_primitives.prim_encoding
 
-type t = { code : expr ; storage : expr }
+type error += Lazy_script_decode (* `Permanent *)
+
+let () =
+  register_error_kind `Permanent
+    ~id:"invalid_binary_format"
+    ~title:"Invalid binary format"
+    ~description:"Could not deserialize some piece of data \
+                  from its binary representation"
+    Data_encoding.empty
+    (function Lazy_script_decode -> Some () | _ -> None)
+    (fun () -> Lazy_script_decode)
+
+let lazy_expr_encoding =
+  Data_encoding.lazy_encoding expr_encoding
+
+let lazy_expr expr =
+  Data_encoding.make_lazy expr_encoding expr
+
+let force_decode expr =
+  match Data_encoding.force_decode expr with
+  | Some v -> ok v
+  | None -> error Lazy_script_decode
+
+let force_bytes expr =
+  match Data_encoding.force_bytes expr with
+  | bytes -> ok bytes
+  | exception _ -> error Lazy_script_decode
+
+type t = {
+  code : lazy_expr ;
+  storage : lazy_expr
+}
 
 let encoding =
   let open Data_encoding in
   conv
     (fun { code ; storage } -> (code, storage))
     (fun (code, storage) -> { code ; storage })
-    (obj2 (req "code" expr_encoding) (req "storage" expr_encoding))
+    (obj2
+       (req "code" lazy_expr_encoding)
+       (req "storage" lazy_expr_encoding))

src/proto_alpha/lib_protocol/src/script_repr.mli

@@ -11,12 +11,24 @@ type location = Micheline.canonical_location
 
 type expr = Michelson_v1_primitives.prim Micheline.canonical
 
+type error += Lazy_script_decode (* `Permanent *)
+
+type lazy_expr = expr Data_encoding.lazy_t
+
+val force_decode : lazy_expr -> expr tzresult
+
+val force_bytes : lazy_expr -> MBytes.t tzresult
+
 type node = (location, Michelson_v1_primitives.prim) Micheline.node
 
 val location_encoding : location Data_encoding.t
 
 val expr_encoding : expr Data_encoding.t
 
-type t = { code : expr ; storage : expr }
+val lazy_expr_encoding : lazy_expr Data_encoding.t
+
+val lazy_expr : expr -> lazy_expr
+
+type t = { code : lazy_expr ; storage : lazy_expr }
 
 val encoding : t Data_encoding.encoding

src/proto_alpha/lib_protocol/src/storage.ml

@@ -141,16 +141,16 @@ module Contract = struct
     Indexed_context.Make_carbonated_map
       (struct let name = ["code"] end)
       (Make_carbonated_value(struct
-         type t = Script_repr.expr
+         type t = Script_repr.lazy_expr
-         let encoding = Script_repr.expr_encoding
+         let encoding = Script_repr.lazy_expr_encoding
        end))
 
   module Storage =
     Indexed_context.Make_carbonated_map
       (struct let name = ["storage"] end)
       (Make_carbonated_value(struct
-         type t = Script_repr.expr
+         type t = Script_repr.lazy_expr
-         let encoding = Script_repr.expr_encoding
+         let encoding = Script_repr.lazy_expr_encoding
        end))
 
   type bigmap_key = Raw_context.t * Contract_repr.t

src/proto_alpha/lib_protocol/src/storage.mli

@@ -164,12 +164,12 @@ module Contract : sig
 
   module Code : Indexed_carbonated_data_storage
     with type key = Contract_repr.t
-     and type value = Script_repr.expr
+     and type value = Script_repr.lazy_expr
      and type t := Raw_context.t
 
   module Storage : Indexed_carbonated_data_storage
     with type key = Contract_repr.t
-     and type value = Script_repr.expr
+     and type value = Script_repr.lazy_expr
      and type t := Raw_context.t
 
   (** Current storage space in bytes.

src/proto_alpha/lib_protocol/test/helpers/helpers_operation.ml

@@ -35,6 +35,7 @@ let manager_full src ?(fee = Tez.zero) ops context gas_limit =
 
 
 let transaction ?parameters amount destination =
+  let parameters = Option.map ~f:Script.lazy_expr parameters in
   Transaction {
     amount ;
     parameters ;

src/proto_alpha/lib_protocol/test/test_big_maps.ml

@@ -25,7 +25,9 @@ let parse_expr s : Proto_alpha.Alpha_context.Script.expr tzresult =
 
 let parse_script code_str storage_str : Proto_alpha.Alpha_context.Script.t tzresult =
   parse_expr code_str >>? fun code ->
+  let code = Proto_alpha.Alpha_context.Script.lazy_expr code in
   parse_expr storage_str >>? fun storage ->
+  let storage = Proto_alpha.Alpha_context.Script.lazy_expr storage in
   ok { Proto_alpha.Alpha_context.Script.code ; storage }
 
 let code = {|

src/proto_alpha/lib_protocol/test/test_michelson.ml

@@ -30,8 +30,8 @@ let parse_param s : Proto_alpha.Alpha_context.Script.expr =
 
 
 let parse_script code_str storage_str : Proto_alpha.Alpha_context.Script.t =
-  let code = parse_param code_str in
+  let code = Script_repr.lazy_expr (parse_param code_str) in
-  let storage = parse_param storage_str in
+  let storage = Script_repr.lazy_expr (parse_param storage_str) in
   let return: Proto_alpha.Alpha_context.Script.t = {code ; storage} in
   return