Michelson: add SLICE instruction on strings and bytes

src/proto_alpha/lib_protocol/src/alpha_context.mli

@@ -258,6 +258,7 @@ module Script : sig
     | I_SOURCE
     | I_SENDER
     | I_SELF
+    | I_SLICE
     | I_STEPS_TO_QUOTA
     | I_SUB
     | I_SWAP

src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml

@@ -62,6 +62,9 @@ module Cost_of = struct
   let concat_string ss = concat string String.length ss
   let concat_bytes ss = concat bytes MBytes.length ss
 
+  let slice_string length = string length
+  let slice_bytes = alloc_cost 0
+
   (* Cost per cycle of a loop, fold, etc *)
   let loop_cycle = step_cost 2
 
@@ -308,6 +311,8 @@ module Cost_of = struct
         | Big_map_update -> alloc_cost 1
         | Concat_string -> alloc_cost 1
         | Concat_bytes -> alloc_cost 1
+        | Slice_string -> alloc_cost 1
+        | Slice_bytes -> alloc_cost 1
         | Add_seconds_to_timestamp -> alloc_cost 1
         | Add_timestamp_to_seconds -> alloc_cost 1
         | Sub_timestamp_seconds -> alloc_cost 1

src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli

@@ -40,6 +40,8 @@ module Cost_of : sig
   val branch : Gas.cost
   val concat_string : string list -> Gas.cost
   val concat_bytes : MBytes.t list -> Gas.cost
+  val slice_string : int -> Gas.cost
+  val slice_bytes : Gas.cost
   val map_mem :
     'a -> ('b, 'c) Script_typed_ir.map -> Gas.cost
   val map_to_list :

src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml

@@ -104,6 +104,7 @@ type prim =
   | I_SOURCE
   | I_SENDER
   | I_SELF
+  | I_SLICE
   | I_STEPS_TO_QUOTA
   | I_SUB
   | I_SWAP
@@ -236,6 +237,7 @@ let string_of_prim = function
   | I_SOURCE -> "SOURCE"
   | I_SENDER -> "SENDER"
   | I_SELF -> "SELF"
+  | I_SLICE -> "SLICE"
   | I_STEPS_TO_QUOTA -> "STEPS_TO_QUOTA"
   | I_SUB -> "SUB"
   | I_SWAP -> "SWAP"
@@ -349,6 +351,7 @@ let prim_of_string = function
   | "SOURCE" -> ok I_SOURCE
   | "SENDER" -> ok I_SENDER
   | "SELF" -> ok I_SELF
+  | "SLICE" -> ok I_SLICE
   | "STEPS_TO_QUOTA" -> ok I_STEPS_TO_QUOTA
   | "SUB" -> ok I_SUB
   | "SWAP" -> ok I_SWAP
@@ -507,6 +510,7 @@ let prim_encoding =
     ("SOURCE", I_SOURCE) ;
     ("SENDER", I_SENDER) ;
     ("SELF", I_SELF) ;
+    ("SLICE", I_SLICE) ;
     ("STEPS_TO_QUOTA", I_STEPS_TO_QUOTA) ;
     ("SUB", I_SUB) ;
     ("SWAP", I_SWAP) ;

src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli

@@ -102,6 +102,7 @@ type prim =
   | I_SOURCE
   | I_SENDER
   | I_SELF
+  | I_SLICE
   | I_STEPS_TO_QUOTA
   | I_SUB
   | I_SWAP

src/proto_alpha/lib_protocol/src/script_interpreter.ml

@@ -419,11 +419,31 @@ let rec interp
             Lwt.return (Gas.consume ctxt (Interp_costs.concat_string ss)) >>=? fun ctxt ->
             let s = String.concat "" ss in
             logged_return (Item (s, rest), ctxt)
+        | Slice_string, Item (offset, Item (length, Item (s, rest))) ->
+            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
+              Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt ->
+              logged_return (Item (Some (String.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt)
+            else
+              Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt ->
+              logged_return (Item (None, rest), ctxt)
         (* bytes operations *)
         | Concat_bytes, Item (ss, rest) ->
             Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes ss)) >>=? fun ctxt ->
             let s = MBytes.concat "" ss in
             logged_return (Item (s, rest), ctxt)
+        | Slice_bytes, Item (offset, Item (length, Item (s, rest))) ->
+            let s_length = Z.of_int (MBytes.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
+              Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt ->
+              logged_return (Item (Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt)
+            else
+              Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt ->
+              logged_return (Item (None, rest), ctxt)
         (* currency operations *)
         | Add_tez, Item (x, Item (y, rest)) ->
             Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt ->

src/proto_alpha/lib_protocol/src/script_ir_annot.ml

@@ -46,6 +46,7 @@ let default_addr_annot = Some (`Field_annot "address")
 let default_manager_annot = Some (`Field_annot "manager")
 let default_pack_annot = Some (`Field_annot "packed")
 let default_unpack_annot = Some (`Field_annot "unpacked")
+let default_slice_annot = Some (`Field_annot "slice")
 
 let default_elt_annot = Some (`Field_annot "elt")
 let default_key_annot = Some (`Field_annot "key")

src/proto_alpha/lib_protocol/src/script_ir_annot.mli

@@ -46,6 +46,7 @@ val default_addr_annot : field_annot option
 val default_manager_annot : field_annot option
 val default_pack_annot : field_annot option
 val default_unpack_annot : field_annot option
+val default_slice_annot : field_annot option
 
 val default_elt_annot : field_annot option
 val default_key_annot : field_annot option

src/proto_alpha/lib_protocol/src/script_ir_translator.ml

@@ -156,7 +156,9 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function
   | Big_map_update -> 0
   | Big_map_mem -> 0
   | Concat_string -> 0
+  | Slice_string -> 0
   | Concat_bytes -> 0
+  | Slice_bytes -> 0
   | Add_seconds_to_timestamp -> 0
   | Add_timestamp_to_seconds -> 0
   | Sub_timestamp_seconds -> 0
@@ -326,6 +328,7 @@ let namespace = function
   | I_SOURCE
   | I_SENDER
   | I_SELF
+  | I_SLICE
   | I_STEPS_TO_QUOTA
   | I_SUB
   | I_SWAP
@@ -2116,12 +2119,26 @@ and parse_instr
         parse_var_annot ~default:list_annot loc annot >>=? fun annot ->
         typed ctxt loc Concat_string
           (Item_t (String_t tname, rest, annot))
+    | Prim (loc, I_SLICE, [], annot),
+      Item_t (Nat_t _, Item_t (Nat_t _, Item_t (String_t tname, rest, string_annot), _), _) ->
+        parse_var_annot
+          ~default:(gen_access_annot string_annot default_slice_annot)
+          loc annot >>=? fun annot ->
+        typed ctxt loc Slice_string
+          (Item_t (Option_t ((String_t tname, None), None, None), rest, annot))
     (* bytes operations *)
     | Prim (loc, I_CONCAT, [], annot),
       Item_t (List_t (Bytes_t tname, _), rest, list_annot) ->
         parse_var_annot ~default:list_annot loc annot >>=? fun annot ->
         typed ctxt loc Concat_bytes
           (Item_t (Bytes_t tname, rest, annot))
+    | Prim (loc, I_SLICE, [], annot),
+      Item_t (Nat_t _, Item_t (Nat_t _, Item_t (Bytes_t tname, rest, bytes_annot), _), _) ->
+        parse_var_annot
+          ~default:(gen_access_annot bytes_annot default_slice_annot)
+          loc annot >>=? fun annot ->
+        typed ctxt loc Slice_bytes
+          (Item_t (Option_t ((Bytes_t tname, None), None, None), rest, annot))
     (* currency operations *)
     | Prim (loc, I_ADD, [], annot),
       Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ->
@@ -2617,7 +2634,7 @@ and parse_instr
         get_toplevel_type tc_context
     (* Primitive parsing errors *)
     | Prim (loc, (I_DROP | I_DUP | I_SWAP | I_SOME | I_UNIT
-                 | I_PAIR | I_CAR | I_CDR | I_CONS | I_CONCAT
+                 | I_PAIR | I_CAR | I_CDR | I_CONS | I_CONCAT | I_SLICE
                  | I_MEM | I_UPDATE | I_MAP
                  | I_GET | I_EXEC | I_FAILWITH | I_SIZE
                  | I_ADD | I_SUB
@@ -2660,10 +2677,10 @@ and parse_instr
       Item_t (t, _, _) ->
         Lwt.return @@ serialize_ty_for_error ctxt t >>=? fun (t, _ctxt) ->
         fail (Undefined_unop (loc, name, t))
-    | Prim (loc, I_UPDATE, [], _),
+    | Prim (loc, (I_UPDATE | I_SLICE as name), [], _),
       stack ->
         serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) ->
-        fail (Bad_stack (loc, I_UPDATE, 3, stack))
+        fail (Bad_stack (loc, name, 3, stack))
     | Prim (loc, I_CREATE_CONTRACT, [], _),
       stack ->
         serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) ->

src/proto_alpha/lib_protocol/src/script_typed_ir.ml

@@ -204,9 +204,13 @@ and ('bef, 'aft) instr =
   (* string operations *)
   | Concat_string :
       (string list * 'rest, string * 'rest) instr
+  | Slice_string :
+      (n num * (n num * (string * 'rest)), string option * 'rest) instr
   (* bytes operations *)
   | Concat_bytes :
       (MBytes.t list * 'rest, MBytes.t * 'rest) instr
+  | Slice_bytes :
+      (n num * (n num * (MBytes.t * 'rest)), MBytes.t option * 'rest) instr
   (* timestamp operations *)
   | Add_seconds_to_timestamp :
       (z num * (Script_timestamp.t * 'rest),