script_interpreter.ml 54.2 KB
Newer Older
Pierre Boutillier's avatar
Pierre Boutillier committed
1 2 3 4
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
5
(* Copyright (c) 2020 Metastate AG <hello@metastate.dev>                     *)
Pierre Boutillier's avatar
Pierre Boutillier committed
6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)
Tezos's avatar
Tezos committed
26

27
open Alpha_context
Tezos's avatar
Tezos committed
28 29 30
open Script
open Script_typed_ir
open Script_ir_translator
31
module S = Saturation_repr
Tezos's avatar
Tezos committed
32 33 34

(* ---- Run-time errors -----------------------------------------------------*)

35
type execution_trace =
Ilias Garnier's avatar
Ilias Garnier committed
36
  (Script.location * Gas.t * (Script.expr * string option) list) list
37

38 39 40
type error +=
  | Reject of Script.location * Script.expr * execution_trace option

41
type error += Overflow of Script.location * execution_trace option
42

43
type error += Runtime_contract_error : Contract.t * Script.expr -> error
44

45
type error += Bad_contract_parameter of Contract.t (* `Permanent *)
46

47
type error += Cannot_serialize_failure
48

49
type error += Cannot_serialize_storage
Tezos's avatar
Tezos committed
50

Gabriel Alfour's avatar
Gabriel Alfour committed
51 52
type error += Michelson_too_many_recursive_calls

Tezos's avatar
Tezos committed
53 54
let () =
  let open Data_encoding in
55
  let trace_encoding =
56
    list
Ilias Garnier's avatar
Ilias Garnier committed
57
    @@ obj3
58 59 60 61 62 63
         (req "location" Script.location_encoding)
         (req "gas" Gas.encoding)
         (req
            "stack"
            (list (obj2 (req "item" Script.expr_encoding) (opt "annot" string))))
  in
64
  (* Reject *)
Tezos's avatar
Tezos committed
65 66
  register_error_kind
    `Temporary
67
    ~id:"michelson_v1.script_rejected"
68 69
    ~title:"Script failed"
    ~description:"A FAILWITH instruction was reached"
70
    (obj3
71
       (req "location" Script.location_encoding)
Alain Mebsout's avatar
Alain Mebsout committed
72
       (req "with" Script.expr_encoding)
73
       (opt "trace" trace_encoding))
74
    (function Reject (loc, v, trace) -> Some (loc, v, trace) | _ -> None)
75
    (fun (loc, v, trace) -> Reject (loc, v, trace)) ;
76 77 78
  (* Overflow *)
  register_error_kind
    `Temporary
79
    ~id:"michelson_v1.script_overflow"
80 81 82
    ~title:"Script failed (overflow error)"
    ~description:
      "A FAIL instruction was reached due to the detection of an overflow"
83 84 85 86
    (obj2
       (req "location" Script.location_encoding)
       (opt "trace" trace_encoding))
    (function Overflow (loc, trace) -> Some (loc, trace) | _ -> None)
87
    (fun (loc, trace) -> Overflow (loc, trace)) ;
88
  (* Runtime contract error *)
89 90
  register_error_kind
    `Temporary
91
    ~id:"michelson_v1.runtime_error"
92 93
    ~title:"Script runtime error"
    ~description:"Toplevel error for all runtime script errors"
94
    (obj2
95 96
       (req "contract_handle" Contract.encoding)
       (req "contract_code" Script.expr_encoding))
97
    (function
98 99
      | Runtime_contract_error (contract, expr) ->
          Some (contract, expr)
100 101 102
      | _ ->
          None)
    (fun (contract, expr) -> Runtime_contract_error (contract, expr)) ;
103 104 105
  (* Bad contract parameter *)
  register_error_kind
    `Permanent
106
    ~id:"michelson_v1.bad_contract_parameter"
107
    ~title:"Contract supplied an invalid parameter"
108 109 110 111
    ~description:
      "Either no parameter was supplied to a contract with a non-unit \
       parameter type, a non-unit parameter was passed to an account, or a \
       parameter was supplied of the wrong type"
112 113
    Data_encoding.(obj1 (req "contract" Contract.encoding))
    (function Bad_contract_parameter c -> Some c | _ -> None)
114 115 116 117
    (fun c -> Bad_contract_parameter c) ;
  (* Cannot serialize failure *)
  register_error_kind
    `Temporary
118
    ~id:"michelson_v1.cannot_serialize_failure"
119
    ~title:"Not enough gas to serialize argument of FAILWITH"
120 121
    ~description:
      "Argument of FAILWITH was too big to be serialized with the provided gas"
122 123 124 125 126 127
    Data_encoding.empty
    (function Cannot_serialize_failure -> Some () | _ -> None)
    (fun () -> Cannot_serialize_failure) ;
  (* Cannot serialize storage *)
  register_error_kind
    `Temporary
128
    ~id:"michelson_v1.cannot_serialize_storage"
129
    ~title:"Not enough gas to serialize execution storage"
130 131
    ~description:
      "The returned storage was too big to be serialized with the provided gas"
132 133
    Data_encoding.empty
    (function Cannot_serialize_storage -> Some () | _ -> None)
Gabriel Alfour's avatar
Gabriel Alfour committed
134 135 136 137 138 139 140 141 142 143 144
    (fun () -> Cannot_serialize_storage) ;
  (* Michelson Stack Overflow *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.interp_too_many_recursive_calls"
    ~title:"Too many recursive calls during interpretation"
    ~description:
      "Too many recursive calls were needed for interpretation of a Michelson \
       script"
    Data_encoding.empty
    (function Michelson_too_many_recursive_calls -> Some () | _ -> None)
Mehdi Bouaziz's avatar
Mehdi Bouaziz committed
145
    (fun () -> Michelson_too_many_recursive_calls)
Tezos's avatar
Tezos committed
146

147
(* ---- interpreter ---------------------------------------------------------*)
Tezos's avatar
Tezos committed
148

149
module Interp_costs = Michelson_v1_gas.Cost_of.Interpreter
150

151 152
let rec interp_stack_prefix_preserving_operation :
    type fbef bef faft aft result.
153
    (fbef -> (faft * result) tzresult Lwt.t) ->
154
    (fbef, faft, bef, aft) stack_prefix_preservation_witness ->
155 156
    bef ->
    (aft * result) tzresult Lwt.t =
157 158 159 160 161 162 163 164 165 166 167 168 169 170
 fun f n stk ->
  match (n, stk) with
  | ( Prefix
        (Prefix
          (Prefix
            (Prefix
              (Prefix
                (Prefix
                  (Prefix
                    (Prefix
                      (Prefix
                        (Prefix
                          (Prefix
                            (Prefix (Prefix (Prefix (Prefix (Prefix n))))))))))))))),
171 172 173 174 175 176 177 178 179
      ( v0,
        ( v1,
          ( v2,
            ( v3,
              ( v4,
                ( v5,
                  ( v6,
                    (v7, (v8, (v9, (va, (vb, (vc, (vd, (ve, (vf, rest)))))))))
                  ) ) ) ) ) ) ) ) ->
180
      interp_stack_prefix_preserving_operation f n rest
Mehdi Bouaziz's avatar
Mehdi Bouaziz committed
181 182 183 184 185 186 187 188 189 190 191 192
      >|=? fun (rest', result) ->
      ( ( v0,
          ( v1,
            ( v2,
              ( v3,
                ( v4,
                  ( v5,
                    ( v6,
                      ( v7,
                        (v8, (v9, (va, (vb, (vc, (vd, (ve, (vf, rest'))))))))
                      ) ) ) ) ) ) ) ),
        result )
193
  | (Prefix (Prefix (Prefix (Prefix n))), (v0, (v1, (v2, (v3, rest))))) ->
194
      interp_stack_prefix_preserving_operation f n rest
Mehdi Bouaziz's avatar
Mehdi Bouaziz committed
195
      >|=? fun (rest', result) -> ((v0, (v1, (v2, (v3, rest')))), result)
196
  | (Prefix n, (v, rest)) ->
197
      interp_stack_prefix_preserving_operation f n rest
Mehdi Bouaziz's avatar
Mehdi Bouaziz committed
198
      >|=? fun (rest', result) -> ((v, rest'), result)
199 200
  | (Rest, v) ->
      f v
201
 [@@coq_axiom_with_reason "gadt"]
202

203 204 205 206 207 208 209
type step_constants = {
  source : Contract.t;
  payer : Contract.t;
  self : Contract.t;
  amount : Tez.t;
  chain_id : Chain_id.t;
}
210

211 212
module type STEP_LOGGER = sig
  val log_interp :
213
    context -> ('bef, 'aft) Script_typed_ir.descr -> 'bef -> unit
214

215
  val log_entry : context -> ('bef, 'aft) Script_typed_ir.descr -> 'bef -> unit
216

217
  val log_exit : context -> ('bef, 'aft) Script_typed_ir.descr -> 'aft -> unit
218

219
  val get_log : unit -> execution_trace option tzresult Lwt.t
220 221 222 223 224
end

type logger = (module STEP_LOGGER)

module No_trace : STEP_LOGGER = struct
225
  let log_interp _ctxt _descr _stack = ()
226

227
  let log_entry _ctxt _descr _stack = ()
228

229
  let log_exit _ctxt _descr _stack = ()
230

231
  let get_log () = return_none
232 233
end

234
let cost_of_instr : type b a. (b, a) descr -> b -> Gas.cost =
235
 fun descr stack ->
236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252
  match (descr.instr, stack) with
  | (Drop, _) ->
      Interp_costs.drop
  | (Dup, _) ->
      Interp_costs.dup
  | (Swap, _) ->
      Interp_costs.swap
  | (Const _, _) ->
      Interp_costs.push
  | (Cons_some, _) ->
      Interp_costs.cons_some
  | (Cons_none _, _) ->
      Interp_costs.cons_none
  | (If_none _, _) ->
      Interp_costs.if_none
  | (Cons_pair, _) ->
      Interp_costs.cons_pair
253 254
  | (Unpair, _) ->
      Interp_costs.unpair
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
  | (Car, _) ->
      Interp_costs.car
  | (Cdr, _) ->
      Interp_costs.cdr
  | (Cons_left, _) ->
      Interp_costs.cons_left
  | (Cons_right, _) ->
      Interp_costs.cons_right
  | (If_left _, _) ->
      Interp_costs.if_left
  | (Cons_list, _) ->
      Interp_costs.cons_list
  | (Nil, _) ->
      Interp_costs.nil
  | (If_cons _, _) ->
      Interp_costs.if_cons
  | (List_map _, (list, _)) ->
      Interp_costs.list_map list
  | (List_size, _) ->
      Interp_costs.list_size
  | (List_iter _, (l, _)) ->
      Interp_costs.list_iter l
  | (Empty_set _, _) ->
      Interp_costs.empty_set
  | (Set_iter _, (set, _)) ->
      Interp_costs.set_iter set
  | (Set_mem, (v, (set, _))) ->
      Interp_costs.set_mem v set
  | (Set_update, (v, (_, (set, _)))) ->
      Interp_costs.set_update v set
  | (Set_size, _) ->
      Interp_costs.set_size
  | (Empty_map _, _) ->
      Interp_costs.empty_map
  | (Map_map _, (map, _)) ->
      Interp_costs.map_map map
  | (Map_iter _, (map, _)) ->
      Interp_costs.map_iter map
  | (Map_mem, (v, (map, _rest))) ->
      Interp_costs.map_mem v map
  | (Map_get, (v, (map, _rest))) ->
      Interp_costs.map_get v map
  | (Map_update, (k, (_, (map, _)))) ->
      Interp_costs.map_update k map
299 300
  | (Map_get_and_update, (k, (_, (map, _)))) ->
      Interp_costs.map_get_and_update k map
301 302 303 304
  | (Map_size, _) ->
      Interp_costs.map_size
  | (Empty_big_map _, _) ->
      Interp_costs.empty_map
305 306 307 308 309 310 311 312
  | (Big_map_mem, (_, (map, _))) ->
      Interp_costs.big_map_mem map.diff
  | (Big_map_get, (_, (map, _))) ->
      Interp_costs.big_map_get map.diff
  | (Big_map_update, (_, (_, (map, _)))) ->
      Interp_costs.big_map_update map.diff
  | (Big_map_get_and_update, (_, (_, (map, _)))) ->
      Interp_costs.big_map_get_and_update map.diff
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 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458
  | (Add_seconds_to_timestamp, (n, (t, _))) ->
      Interp_costs.add_seconds_timestamp n t
  | (Add_timestamp_to_seconds, (t, (n, _))) ->
      Interp_costs.add_seconds_timestamp n t
  | (Sub_timestamp_seconds, (t, (n, _))) ->
      Interp_costs.sub_seconds_timestamp n t
  | (Diff_timestamps, (t1, (t2, _))) ->
      Interp_costs.diff_timestamps t1 t2
  | (Concat_string_pair, (x, (y, _))) ->
      Interp_costs.concat_string_pair x y
  | (Concat_string, (ss, _)) ->
      Interp_costs.concat_string_precheck ss
  | (Slice_string, (_offset, (_length, (s, _)))) ->
      Interp_costs.slice_string s
  | (String_size, _) ->
      Interp_costs.string_size
  | (Concat_bytes_pair, (x, (y, _))) ->
      Interp_costs.concat_bytes_pair x y
  | (Concat_bytes, (ss, _)) ->
      Interp_costs.concat_string_precheck ss
  | (Slice_bytes, (_offset, (_length, (s, _)))) ->
      Interp_costs.slice_bytes s
  | (Bytes_size, _) ->
      Interp_costs.bytes_size
  | (Add_tez, _) ->
      Interp_costs.add_tez
  | (Sub_tez, _) ->
      Interp_costs.sub_tez
  | (Mul_teznat, (_, (n, _))) ->
      Interp_costs.mul_teznat n
  | (Mul_nattez, (n, (_, _))) ->
      Interp_costs.mul_teznat n
  | (Or, _) ->
      Interp_costs.bool_or
  | (And, _) ->
      Interp_costs.bool_and
  | (Xor, _) ->
      Interp_costs.bool_xor
  | (Not, _) ->
      Interp_costs.bool_not
  | (Is_nat, _) ->
      Interp_costs.is_nat
  | (Abs_int, (x, _)) ->
      Interp_costs.abs_int x
  | (Int_nat, _) ->
      Interp_costs.int_nat
  | (Neg_int, (x, _)) ->
      Interp_costs.neg_int x
  | (Neg_nat, (x, _)) ->
      Interp_costs.neg_nat x
  | (Add_intint, (x, (y, _))) ->
      Interp_costs.add_bigint x y
  | (Add_intnat, (x, (y, _))) ->
      Interp_costs.add_bigint x y
  | (Add_natint, (x, (y, _))) ->
      Interp_costs.add_bigint x y
  | (Add_natnat, (x, (y, _))) ->
      Interp_costs.add_bigint x y
  | (Sub_int, (x, (y, _))) ->
      Interp_costs.sub_bigint x y
  | (Mul_intint, (x, (y, _))) ->
      Interp_costs.mul_bigint x y
  | (Mul_intnat, (x, (y, _))) ->
      Interp_costs.mul_bigint x y
  | (Mul_natint, (x, (y, _))) ->
      Interp_costs.mul_bigint x y
  | (Mul_natnat, (x, (y, _))) ->
      Interp_costs.mul_bigint x y
  | (Ediv_teznat, (x, (y, _))) ->
      Interp_costs.ediv_teznat x y
  | (Ediv_tez, _) ->
      Interp_costs.ediv_tez
  | (Ediv_intint, (x, (y, _))) ->
      Interp_costs.ediv_bigint x y
  | (Ediv_intnat, (x, (y, _))) ->
      Interp_costs.ediv_bigint x y
  | (Ediv_natint, (x, (y, _))) ->
      Interp_costs.ediv_bigint x y
  | (Ediv_natnat, (x, (y, _))) ->
      Interp_costs.ediv_bigint x y
  | (Lsl_nat, (x, _)) ->
      Interp_costs.lsl_nat x
  | (Lsr_nat, (x, _)) ->
      Interp_costs.lsr_nat x
  | (Or_nat, (x, (y, _))) ->
      Interp_costs.or_nat x y
  | (And_nat, (x, (y, _))) ->
      Interp_costs.and_nat x y
  | (And_int_nat, (x, (y, _))) ->
      Interp_costs.and_nat x y
  | (Xor_nat, (x, (y, _))) ->
      Interp_costs.xor_nat x y
  | (Not_int, (x, _)) ->
      Interp_costs.not_nat x
  | (Not_nat, (x, _)) ->
      Interp_costs.not_nat x
  | (Seq _, _) ->
      Interp_costs.seq
  | (If _, _) ->
      Interp_costs.if_
  | (Loop _, _) ->
      Interp_costs.loop
  | (Loop_left _, _) ->
      Interp_costs.loop_left
  | (Dip _, _) ->
      Interp_costs.dip
  | (Exec, _) ->
      Interp_costs.exec
  | (Apply _, _) ->
      Interp_costs.apply
  | (Lambda _, _) ->
      Interp_costs.push
  | (Failwith _, _) ->
      Gas.free
  | (Nop, _) ->
      Interp_costs.nop
  | (Compare ty, (a, (b, _))) ->
      Interp_costs.compare ty a b
  | (Eq, _) ->
      Interp_costs.neq
  | (Neq, _) ->
      Interp_costs.neq
  | (Lt, _) ->
      Interp_costs.neq
  | (Le, _) ->
      Interp_costs.neq
  | (Gt, _) ->
      Interp_costs.neq
  | (Ge, _) ->
      Interp_costs.neq
  | (Pack _, _) ->
      Gas.free
  | (Unpack _, _) ->
      Gas.free
  | (Address, _) ->
      Interp_costs.address
  | (Contract _, _) ->
      Interp_costs.contract
  | (Transfer_tokens, _) ->
      Interp_costs.transfer_tokens
  | (Implicit_account, _) ->
      Interp_costs.implicit_account
  | (Set_delegate, _) ->
      Interp_costs.set_delegate
  | (Balance, _) ->
      Interp_costs.balance
459 460
  | (Level, _) ->
      Interp_costs.level
461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478
  | (Now, _) ->
      Interp_costs.now
  | (Check_signature, (key, (_, (message, _)))) ->
      Interp_costs.check_signature key message
  | (Hash_key, (pk, _)) ->
      Interp_costs.hash_key pk
  | (Blake2b, (bytes, _)) ->
      Interp_costs.blake2b bytes
  | (Sha256, (bytes, _)) ->
      Interp_costs.sha256 bytes
  | (Sha512, (bytes, _)) ->
      Interp_costs.sha512 bytes
  | (Source, _) ->
      Interp_costs.source
  | (Sender, _) ->
      Interp_costs.source
  | (Self _, _) ->
      Interp_costs.self
479 480
  | (Self_address, _) ->
      Interp_costs.self
481 482 483 484 485 486 487 488 489 490 491 492
  | (Amount, _) ->
      Interp_costs.amount
  | (Dig (n, _), _) ->
      Interp_costs.dign n
  | (Dug (n, _), _) ->
      Interp_costs.dugn n
  | (Dipn (n, _, _), _) ->
      Interp_costs.dipn n
  | (Dropn (n, _), _) ->
      Interp_costs.dropn n
  | (ChainId, _) ->
      Interp_costs.chain_id
493
  | (Create_contract _, _) ->
494
      Interp_costs.create_contract
495 496
  | (Never, (_, _)) ->
      .
497 498
  | (Voting_power, _) ->
      Interp_costs.voting_power
499 500
  | (Total_voting_power, _) ->
      Interp_costs.total_voting_power
501 502 503 504
  | (Keccak, (bytes, _)) ->
      Interp_costs.keccak bytes
  | (Sha3, (bytes, _)) ->
      Interp_costs.sha3 bytes
505 506 507 508 509 510 511 512 513 514 515 516
  | (Add_bls12_381_g1, _) ->
      Interp_costs.add_bls12_381_g1
  | (Add_bls12_381_g2, _) ->
      Interp_costs.add_bls12_381_g2
  | (Add_bls12_381_fr, _) ->
      Interp_costs.add_bls12_381_fr
  | (Mul_bls12_381_g1, _) ->
      Interp_costs.mul_bls12_381_g1
  | (Mul_bls12_381_g2, _) ->
      Interp_costs.mul_bls12_381_g2
  | (Mul_bls12_381_fr, _) ->
      Interp_costs.mul_bls12_381_fr
517
  | (Mul_bls12_381_fr_z, _) ->
518
      Interp_costs.mul_bls12_381_fr_z
519
  | (Mul_bls12_381_z_fr, _) ->
520
      Interp_costs.mul_bls12_381_fr_z
521 522
  | (Int_bls12_381_fr, _) ->
      Interp_costs.int_bls12_381_fr
523 524 525 526 527 528 529 530
  | (Neg_bls12_381_g1, _) ->
      Interp_costs.neg_bls12_381_g1
  | (Neg_bls12_381_g2, _) ->
      Interp_costs.neg_bls12_381_g2
  | (Neg_bls12_381_fr, _) ->
      Interp_costs.neg_bls12_381_fr
  | (Pairing_check_bls12_381, (pairs, _)) ->
      Interp_costs.pairing_check_bls12_381 pairs
531 532 533 534 535 536 537 538
  | (Comb (n, _), _) ->
      Interp_costs.comb n
  | (Uncomb (n, _), _) ->
      Interp_costs.uncomb n
  | (Comb_get (n, _), _) ->
      Interp_costs.comb_get n
  | (Comb_set (n, _), _) ->
      Interp_costs.comb_set n
Gabriel Alfour's avatar
Gabriel Alfour committed
539 540
  | (Dup_n (n, _), _) ->
      Interp_costs.dupn n
541 542
  | (Sapling_empty_state _, _) ->
      Interp_costs.sapling_empty_state
543 544 545 546
  | (Sapling_verify_update, (tx, _)) ->
      let inputs = List.length tx.inputs in
      let outputs = List.length tx.outputs in
      Interp_costs.sapling_verify_update ~inputs ~outputs
Gabriel Alfour's avatar
Gabriel Alfour committed
547 548
  | (Ticket, _) ->
      Interp_costs.ticket
549
  | (Read_ticket, _) ->
550
      Interp_costs.read_ticket
551 552
  | (Split_ticket, (ticket, ((amount_a, amount_b), _))) ->
      Interp_costs.split_ticket ticket.amount amount_a amount_b
553 554
  | (Join_tickets ty, ((ticket_a, ticket_b), _)) ->
      Interp_costs.join_tickets ty ticket_a ticket_b
555

556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571
let unpack ctxt ~ty ~bytes =
  Gas.check_enough ctxt (Script.serialized_cost bytes)
  >>?= fun () ->
  if
    Compare.Int.(Bytes.length bytes >= 1)
    && Compare.Int.(TzEndian.get_uint8 bytes 0 = 0x05)
  then
    let bytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in
    match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with
    | None ->
        Lwt.return
          ( Gas.consume ctxt (Interp_costs.unpack_failed bytes)
          >|? fun ctxt -> (None, ctxt) )
    | Some expr -> (
        Gas.consume ctxt (Script.deserialized_cost expr)
        >>?= fun ctxt ->
572 573 574 575 576 577
        parse_data
          ctxt
          ~legacy:false
          ~allow_forged:false
          ty
          (Micheline.root expr)
578 579 580 581 582 583 584 585
        >|= function
        | Ok (value, ctxt) ->
            ok (Some value, ctxt)
        | Error _ignored ->
            Gas.consume ctxt (Interp_costs.unpack_failed bytes)
            >|? fun ctxt -> (None, ctxt) )
  else return (None, ctxt)

Gabriel Alfour's avatar
Gabriel Alfour committed
586
let rec step_bounded :
587
    type b a.
588
    logger ->
Gabriel Alfour's avatar
Gabriel Alfour committed
589
    stack_depth:int ->
590 591 592
    context ->
    step_constants ->
    (b, a) descr ->
593 594
    b ->
    (a * context) tzresult Lwt.t =
Gabriel Alfour's avatar
Gabriel Alfour committed
595
 fun logger ~stack_depth ctxt step_constants ({instr; loc; _} as descr) stack ->
596
  let gas = cost_of_instr descr stack in
Mehdi Bouaziz's avatar
Mehdi Bouaziz committed
597 598
  Gas.consume ctxt gas
  >>?= fun ctxt ->
599
  let module Log = (val logger) in
600
  Log.log_entry ctxt descr stack ;
601
  let logged_return : a * context -> (a * context) tzresult Lwt.t =
602
   fun (ret, ctxt) ->
603 604
    Log.log_exit ctxt descr ret ;
    return (ret, ctxt)
605
  in
Gabriel Alfour's avatar
Gabriel Alfour committed
606 607 608 609 610 611
  let non_terminal_recursion ~ctxt ?(stack_depth = stack_depth + 1) descr stack
      =
    if Compare.Int.(stack_depth >= 10_000) then
      fail Michelson_too_many_recursive_calls
    else step_bounded logger ~stack_depth ctxt step_constants descr stack
  in
612 613
  match (instr, stack) with
  (* stack ops *)
614
  | (Drop, (_, rest)) ->
615
      logged_return (rest, ctxt)
616 617 618 619
  | (Dup, (v, rest)) ->
      logged_return ((v, (v, rest)), ctxt)
  | (Swap, (vi, (vo, rest))) ->
      logged_return ((vo, (vi, rest)), ctxt)
620
  | (Const v, rest) ->
621
      logged_return ((v, rest), ctxt)
622
  (* options *)
623 624
  | (Cons_some, (v, rest)) ->
      logged_return ((Some v, rest), ctxt)
625
  | (Cons_none _, rest) ->
626 627
      logged_return ((None, rest), ctxt)
  | (If_none (bt, _), (None, rest)) ->
Gabriel Alfour's avatar
Gabriel Alfour committed
628
      step_bounded logger ~stack_depth ctxt step_constants bt rest
629
  | (If_none (_, bf), (Some v, rest)) ->
Gabriel Alfour's avatar
Gabriel Alfour committed
630
      step_bounded logger ~stack_depth ctxt step_constants bf (v, rest)
631
  (* pairs *)
632 633
  | (Cons_pair, (a, (b, rest))) ->
      logged_return (((a, b), rest), ctxt)
634 635
  | (Unpair, ((a, b), rest)) ->
      logged_return ((a, (b, rest)), ctxt)
636 637 638 639
  | (Car, ((a, _), rest)) ->
      logged_return ((a, rest), ctxt)
  | (Cdr, ((_, b), rest)) ->
      logged_return ((b, rest), ctxt)
640
  (* unions *)
641
  | (Cons_left, (v, rest)) ->
642
      logged_return ((L v, rest), ctxt)
643
  | (Cons_right, (v, rest)) ->
644 645
      logged_return ((R v, rest), ctxt)
  | (If_left (bt, _), (L v, rest)) ->
Gabriel Alfour's avatar
Gabriel Alfour committed
646
      step_bounded logger ~stack_depth ctxt step_constants bt (v, rest)
647
  | (If_left (_, bf), (R v, rest)) ->
Gabriel Alfour's avatar
Gabriel Alfour committed
648
      step_bounded logger ~stack_depth ctxt step_constants bf (v, rest)
649
  (* lists *)
650 651
  | (Cons_list, (hd, (tl, rest))) ->
      logged_return ((list_cons hd tl, rest), ctxt)
652
  | (Nil, rest) ->
653 654
      logged_return ((list_empty, rest), ctxt)
  | (If_cons (_, bf), ({elements = []; _}, rest)) ->
Gabriel Alfour's avatar
Gabriel Alfour committed
655
      step_bounded logger ~stack_depth ctxt step_constants bf rest
656
  | (If_cons (bt, _), ({elements = hd :: tl; length}, rest)) ->
657
      let tl = {elements = tl; length = length - 1} in
Gabriel Alfour's avatar
Gabriel Alfour committed
658
      step_bounded logger ~stack_depth ctxt step_constants bt (hd, (tl, rest))
659
  | (List_map body, (list, rest)) ->
660 661 662
      let rec loop rest ctxt l acc =
        match l with
        | [] ->
663
            let result = {elements = List.rev acc; length = list.length} in
664
            return ((result, rest), ctxt)
665
        | hd :: tl ->
Gabriel Alfour's avatar
Gabriel Alfour committed
666
            non_terminal_recursion ~ctxt body (hd, rest)
667
            >>=? fun ((hd, rest), ctxt) -> loop rest ctxt tl (hd :: acc)
668
      in
669 670
      loop rest ctxt list.elements []
      >>=? fun (res, ctxt) -> logged_return (res, ctxt)
671 672 673
  | (List_size, (list, rest)) ->
      logged_return ((Script_int.(abs (of_int list.length)), rest), ctxt)
  | (List_iter body, (l, init)) ->
674 675 676 677 678
      let rec loop ctxt l stack =
        match l with
        | [] ->
            return (stack, ctxt)
        | hd :: tl ->
Gabriel Alfour's avatar
Gabriel Alfour committed
679
            non_terminal_recursion ~ctxt body (hd, stack)
680 681
            >>=? fun (stack, ctxt) -> loop ctxt tl stack
      in
682 683
      loop ctxt l.elements init
      >>=? fun (res, ctxt) -> logged_return (res, ctxt)
684 685
  (* sets *)
  | (Empty_set t, rest) ->
686 687
      logged_return ((empty_set t, rest), ctxt)
  | (Set_iter body, (set, init)) ->
688 689 690 691 692 693
      let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in
      let rec loop ctxt l stack =
        match l with
        | [] ->
            return (stack, ctxt)
        | hd :: tl ->
Gabriel Alfour's avatar
Gabriel Alfour committed
694
            non_terminal_recursion ~ctxt body (hd, stack)
695 696 697
            >>=? fun (stack, ctxt) -> loop ctxt tl stack
      in
      loop ctxt l init >>=? fun (res, ctxt) -> logged_return (res, ctxt)
698 699 700 701 702 703
  | (Set_mem, (v, (set, rest))) ->
      logged_return ((set_mem v set, rest), ctxt)
  | (Set_update, (v, (presence, (set, rest)))) ->
      logged_return ((set_update v presence set, rest), ctxt)
  | (Set_size, (set, rest)) ->
      logged_return ((set_size set, rest), ctxt)
704 705
  (* maps *)
  | (Empty_map (t, _), rest) ->
706 707
      logged_return ((empty_map t, rest), ctxt)
  | (Map_map body, (map, rest)) ->
708 709 710 711
      let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
      let rec loop rest ctxt l acc =
        match l with
        | [] ->
712
            return ((acc, rest), ctxt)
713
        | ((k, _) as hd) :: tl ->
Gabriel Alfour's avatar
Gabriel Alfour committed
714
            non_terminal_recursion ~ctxt body (hd, rest)
715
            >>=? fun ((hd, rest), ctxt) ->
716 717 718
            loop rest ctxt tl (map_update k (Some hd) acc)
      in
      loop rest ctxt l (empty_map (map_key_ty map))
719
      >>=? fun (res, ctxt) -> logged_return (res, ctxt)
720
  | (Map_iter body, (map, init)) ->
721 722 723 724 725 726
      let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
      let rec loop ctxt l stack =
        match l with
        | [] ->
            return (stack, ctxt)
        | hd :: tl ->
Gabriel Alfour's avatar
Gabriel Alfour committed
727
            non_terminal_recursion ~ctxt body (hd, stack)
728 729 730
            >>=? fun (stack, ctxt) -> loop ctxt tl stack
      in
      loop ctxt l init >>=? fun (res, ctxt) -> logged_return (res, ctxt)
731 732 733 734 735 736
  | (Map_mem, (v, (map, rest))) ->
      logged_return ((map_mem v map, rest), ctxt)
  | (Map_get, (v, (map, rest))) ->
      logged_return ((map_get v map, rest), ctxt)
  | (Map_update, (k, (v, (map, rest)))) ->
      logged_return ((map_update k v map, rest), ctxt)
737 738 739 740
  | (Map_get_and_update, (k, (v, (map, rest)))) ->
      let map' = map_update k v map in
      let v' = map_get k map in
      logged_return ((v', (map', rest)), ctxt)
741 742
  | (Map_size, (map, rest)) ->
      logged_return ((map_size map, rest), ctxt)
743 744
  (* Big map operations *)
  | (Empty_big_map (tk, tv), rest) ->
745 746
      logged_return ((Script_ir_translator.empty_big_map tk tv, rest), ctxt)
  | (Big_map_mem, (key, (map, rest))) ->
747
      Script_ir_translator.big_map_mem ctxt key map
748 749
      >>=? fun (res, ctxt) -> logged_return ((res, rest), ctxt)
  | (Big_map_get, (key, (map, rest))) ->
750
      Script_ir_translator.big_map_get ctxt key map
751 752
      >>=? fun (res, ctxt) -> logged_return ((res, rest), ctxt)
  | (Big_map_update, (key, (maybe_value, (map, rest)))) ->
753 754
      Script_ir_translator.big_map_update ctxt key maybe_value map
      >>=? fun (res, ctxt) -> logged_return ((res, rest), ctxt)
755
  | (Big_map_get_and_update, (k, (v, (map, rest)))) ->
756 757
      Script_ir_translator.big_map_get_and_update ctxt k v map
      >>=? fun (v', map', ctxt) -> logged_return ((v', (map', rest)), ctxt)
758
  (* timestamp operations *)
759
  | (Add_seconds_to_timestamp, (n, (t, rest))) ->
760
      let result = Script_timestamp.add_delta t n in
761 762
      logged_return ((result, rest), ctxt)
  | (Add_timestamp_to_seconds, (t, (n, rest))) ->
763
      let result = Script_timestamp.add_delta t n in
764 765
      logged_return ((result, rest), ctxt)
  | (Sub_timestamp_seconds, (t, (s, rest))) ->
766
      let result = Script_timestamp.sub_delta t s in
767 768
      logged_return ((result, rest), ctxt)
  | (Diff_timestamps, (t1, (t2, rest))) ->
769
      let result = Script_timestamp.diff t1 t2 in
770
      logged_return ((result, rest), ctxt)
771
  (* string operations *)
772
  | (Concat_string_pair, (x, (y, rest))) ->
773
      let s = String.concat "" [x; y] in
774 775
      logged_return ((s, rest), ctxt)
  | (Concat_string, (ss, rest)) ->
776 777
      (* The cost for this fold_left has been paid upfront *)
      let total_length =
778
        List.fold_left
779
          (fun acc s -> S.add acc (S.safe_int (String.length s)))
780
          S.zero
781
          ss.elements
782 783 784
      in
      Gas.consume ctxt (Interp_costs.concat_string total_length)
      >>?= fun ctxt ->
785
      let s = String.concat "" ss.elements in
786 787
      logged_return ((s, rest), ctxt)
  | (Slice_string, (offset, (length, (s, rest)))) ->
788 789 790 791
      let s_length = Z.of_int (String.length s) in
      let offset = Script_int.to_zint offset in
      let length = Script_int.to_zint length in
      if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then
792
        logged_return
793
          ( (Some (String.sub s (Z.to_int offset) (Z.to_int length)), rest),
794
            ctxt )
795 796 797
      else logged_return ((None, rest), ctxt)
  | (String_size, (s, rest)) ->
      logged_return ((Script_int.(abs (of_int (String.length s))), rest), ctxt)
798
  (* bytes operations *)
799
  | (Concat_bytes_pair, (x, (y, rest))) ->
Marco Stronati's avatar
Marco Stronati committed
800
      let s = Bytes.cat x y in
801 802
      logged_return ((s, rest), ctxt)
  | (Concat_bytes, (ss, rest)) ->
803 804
      (* The cost for this fold_left has been paid upfront *)
      let total_length =
805
        List.fold_left
806
          (fun acc s -> S.add acc (S.safe_int (Bytes.length s)))
807
          S.zero
808
          ss.elements
809 810 811
      in
      Gas.consume ctxt (Interp_costs.concat_string total_length)
      >>?= fun ctxt ->
Marco Stronati's avatar
Marco Stronati committed
812
      let s = Bytes.concat Bytes.empty ss.elements in
813 814
      logged_return ((s, rest), ctxt)
  | (Slice_bytes, (offset, (length, (s, rest)))) ->
Marco Stronati's avatar
Marco Stronati committed
815
      let s_length = Z.of_int (Bytes.length s) in
816 817 818
      let offset = Script_int.to_zint offset in
      let length = Script_int.to_zint length in
      if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then
819
        logged_return
Marco Stronati's avatar
Marco Stronati committed
820
          ((Some (Bytes.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt)
821 822
      else logged_return ((None, rest), ctxt)
  | (Bytes_size, (s, rest)) ->
Marco Stronati's avatar
Marco Stronati committed
823
      logged_return ((Script_int.(abs (of_int (Bytes.length s))), rest), ctxt)
824
  (* currency operations *)
825
  | (Add_tez, (x, (y, rest))) ->
Mehdi Bouaziz's avatar
Mehdi Bouaziz committed
826
      Tez.(x +? y) >>?= fun res -> logged_return ((res, rest), ctxt)
827
  | (Sub_tez, (x, (y, rest))) ->
Mehdi Bouaziz's avatar
Mehdi Bouaziz committed
828
      Tez.(x -? y) >>?= fun res -> logged_return ((res, rest), ctxt)
829
  | (Mul_teznat, (x, (y, rest))) -> (
830 831
    match Script_int.to_int64 y with
    | None ->
832
        Log.get_log () >>=? fun log -> fail (Overflow (loc, log))
833
    | Some y ->
Mehdi Bouaziz's avatar
Mehdi Bouaziz committed
834
        Tez.(x *? y) >>?= fun res -> logged_return ((res, rest), ctxt) )
835
  | (Mul_nattez, (y, (x, rest))) -> (
836 837
    match Script_int.to_int64 y with
    | None ->
838
        Log.get_log () >>=? fun log -> fail (Overflow (loc, log))
839
    | Some y ->
Mehdi Bouaziz's avatar
Mehdi Bouaziz committed
840
        Tez.(x *? y) >>?= fun res -> logged_return ((res, rest), ctxt) )
841
  (* boolean operations *)
842 843 844 845 846 847 848 849
  | (Or, (x, (y, rest))) ->
      logged_return ((x || y, rest), ctxt)
  | (And, (x, (y, rest))) ->
      logged_return ((x && y, rest), ctxt)
  | (Xor, (x, (y, rest))) ->
      logged_return ((Compare.Bool.(x <> y), rest), ctxt)
  | (Not, (x, rest)) ->
      logged_return ((not x, rest), ctxt)
850
  (* integer operations *)
851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879
  | (Is_nat, (x, rest)) ->
      logged_return ((Script_int.is_nat x, rest), ctxt)
  | (Abs_int, (x, rest)) ->
      logged_return ((Script_int.abs x, rest), ctxt)
  | (Int_nat, (x, rest)) ->
      logged_return ((Script_int.int x, rest), ctxt)
  | (Neg_int, (x, rest)) ->
      logged_return ((Script_int.neg x, rest), ctxt)
  | (Neg_nat, (x, rest)) ->
      logged_return ((Script_int.neg x, rest), ctxt)
  | (Add_intint, (x, (y, rest))) ->
      logged_return ((Script_int.add x y, rest), ctxt)
  | (Add_intnat, (x, (y, rest))) ->
      logged_return ((Script_int.add x y, rest), ctxt)
  | (Add_natint, (x, (y, rest))) ->
      logged_return ((Script_int.add x y, rest), ctxt)
  | (Add_natnat, (x, (y, rest))) ->
      logged_return ((Script_int.add_n x y, rest), ctxt)
  | (Sub_int, (x, (y, rest))) ->
      logged_return ((Script_int.sub x y, rest), ctxt)
  | (Mul_intint, (x, (y, rest))) ->
      logged_return ((Script_int.mul x y, rest), ctxt)
  | (Mul_intnat, (x, (y, rest))) ->
      logged_return ((Script_int.mul x y, rest), ctxt)
  | (Mul_natint, (x, (y, rest))) ->
      logged_return ((Script_int.mul x y, rest), ctxt)
  | (Mul_natnat, (x, (y, rest))) ->
      logged_return ((Script_int.mul_n x y, rest), ctxt)
  | (Ediv_teznat, (x, (y, rest))) ->
880
      let x = Script_int.of_int64 (Tez.to_mutez x) in
881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897
      let result =
        match Script_int.ediv x y with
        | None ->
            None
        | Some (q, r) -> (
          match (Script_int.to_int64 q, Script_int.to_int64 r) with
          | (Some q, Some r) -> (
            match (Tez.of_mutez q, Tez.of_mutez r) with
            | (Some q, Some r) ->
                Some (q, r)
            (* Cannot overflow *)
            | _ ->
                assert false )
          (* Cannot overflow *)
          | _ ->
              assert false )
      in
898 899
      logged_return ((result, rest), ctxt)
  | (Ediv_tez, (x, (y, rest))) ->
900 901
      let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in
      let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in
902 903 904 905 906 907 908 909 910 911
      let result =