balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Data_encoding: more 'inlining' in binary description

Browse Source
This commit is contained in:
Grégoire Henry 2018-05-31 12:38:32 +02:00 committed by Benjamin Canou
parent 705d6fb282
commit 7c2ef081d5
1 changed files with 109 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

179
src/lib_data_encoding/binary_description.ml
View File

@ -120,6 +120,7 @@ let add_n_reference uf { descriptions } =
description = Some n_reference_description } ; description = Some n_reference_description } ;
{ descriptions = (n_reference_name, n_encoding) :: descriptions } { descriptions = (n_reference_name, n_encoding) :: descriptions }
type pdesc = P : 'x Encoding.desc -> pdesc
let describe (type x) ?toplevel_name (encoding : x Encoding.t) = let describe (type x) ?toplevel_name (encoding : x Encoding.t) =
let open Encoding in let open Encoding in
let uf = UF.empty () in let uf = UF.empty () in
@ -134,27 +135,42 @@ let describe (type x) ?toplevel_name (encoding : x Encoding.t) =
let name = "X_" ^ string_of_int !x in let name = "X_" ^ string_of_int !x in
uf_add_name name ; uf_add_name name ;
name in name in
let extract_dynamic : let may_new_reference = function
type x. x Encoding.desc -> Binary_schema.field_descr list * x Encoding.desc = | None -> new_reference ()
function | Some name ->
| Dynamic_size { encoding } -> ([ Dynamic_field 1 ], encoding.encoding) uf_add_name name ;
| enc -> ([], enc) in name in
let rec extract_dynamic :
type x. string option -> x Encoding.desc -> bool * string option * pdesc =
fun ref_name -> function
| Conv { encoding } -> extract_dynamic ref_name encoding.encoding
| Describe { id = ref_name ; encoding } -> extract_dynamic (Some ref_name) encoding.encoding
| Splitted { encoding } -> extract_dynamic ref_name encoding.encoding
| Delayed f -> extract_dynamic ref_name (f ()).encoding
| Dynamic_size { encoding } -> (true, ref_name, P encoding.encoding)
| enc -> (false, ref_name, P enc) in
let rec field_descr : let rec field_descr :
type a. recursives -> references -> type a. recursives -> references ->
a Encoding.field -> Binary_schema.field_descr list * references = a Encoding.field -> Binary_schema.field_descr list * references =
fun recursives references -> function fun recursives references -> function
| Req { name ; encoding = { encoding } } | Req { name ; encoding = { encoding } }
| Dft { name ; encoding = { encoding } } -> | Dft { name ; encoding = { encoding } } ->
let (dynamics, field) = extract_dynamic encoding in let (dynamics, ref_name, P field) = extract_dynamic None encoding in
let (layout, references) = layout recursives references field in let (layout, references) = layout ref_name recursives references field in
(dynamics @ [ Named_field (name, classify_desc encoding, layout) ], references) let field_descr =
Binary_schema.Named_field (name, classify_desc field, layout) in
if dynamics then
([ Dynamic_field 1 ; field_descr ], references)
else
([ field_descr], references)
| Opt { kind = `Variable ; name ; encoding = { encoding } } -> | Opt { kind = `Variable ; name ; encoding = { encoding } } ->
let (layout, references) = layout recursives references encoding in let (layout, references) =
layout None recursives references encoding in
([ Named_field (name, `Variable, layout) ], references) ([ Named_field (name, `Variable, layout) ], references)
| Opt { kind = `Dynamic ; name ; encoding = { encoding } } -> | Opt { kind = `Dynamic ; name ; encoding = { encoding } } ->
let (dynamics, field) = extract_dynamic encoding in let (layout, references) =
let (layout, references) = layout recursives references field in layout None recursives references encoding in
(Binary_schema.Option_indicator_field name :: dynamics @ [ Named_field (name, `Dynamic, layout) ], references) ([Binary_schema.Option_indicator_field name ; Named_field (name, classify_desc encoding, layout) ], references)
and obj fields = and obj fields =
Binary_schema.Obj { fields } Binary_schema.Obj { fields }
and union : and union :
@ -172,7 +188,7 @@ let describe (type x) ?toplevel_name (encoding : x Encoding.t) =
let (cases, references) = let (cases, references) =
List.fold_right List.fold_right
(fun (tag, Case case) (cases, references) -> (fun (tag, Case case) (cases, references) ->
let fields, references = fields recursives references case.encoding.encoding in let fields, references = fields None recursives references case.encoding.encoding in
((tag, case.name, tag_field :: fields) :: cases, references)) ((tag, case.name, tag_field :: fields) :: cases, references))
cases cases
([], references) in ([], references) in
@ -189,7 +205,7 @@ let describe (type x) ?toplevel_name (encoding : x Encoding.t) =
fun ?description ~name recursives references encoding -> fun ?description ~name recursives references encoding ->
let new_cannonical = { Binary_schema.name ; description } in let new_cannonical = { Binary_schema.name ; description } in
UF.add uf new_cannonical ; UF.add uf new_cannonical ;
let layout, references = layout recursives references encoding in let layout, references = layout None recursives references encoding in
begin begin
match layout with match layout with
| Ref ref_name -> | Ref ref_name ->
@ -208,40 +224,42 @@ let describe (type x) ?toplevel_name (encoding : x Encoding.t) =
(fun i -> (i, fst @@ Hashtbl.find tbl encoding_array.(i))) (fun i -> (i, fst @@ Hashtbl.find tbl encoding_array.(i)))
Utils.Infix.(0 -- ((Array.length encoding_array) - 1))) Utils.Infix.(0 -- ((Array.length encoding_array) - 1)))
and fields : and fields :
type b. recursives -> references -> type b. string option -> recursives -> references ->
b Encoding.desc -> Binary_schema.fields * references = b Encoding.desc -> Binary_schema.fields * references =
fun recursives references -> function fun ref_name recursives references -> function
| Obj field -> | Obj field ->
field_descr recursives references field field_descr recursives references field
| Objs { left ; right } -> | Objs { left ; right } ->
let (left_fields, references) = let (left_fields, references) =
fields recursives references left.encoding in fields None recursives references left.encoding in
let (right_fields, references) = fields recursives references right.encoding in let (right_fields, references) = fields None recursives references right.encoding in
(left_fields @ right_fields, references) (left_fields @ right_fields, references)
| Null -> ([ Anonymous_field (`Fixed 0, Zero_width) ], references) | Null -> ([ Anonymous_field (`Fixed 0, Zero_width) ], references)
| Empty -> ([ Anonymous_field (`Fixed 0, Zero_width) ], references) | Empty -> ([ Anonymous_field (`Fixed 0, Zero_width) ], references)
| Ignore -> ([ Anonymous_field (`Fixed 0, Zero_width) ], references) | Ignore -> ([ Anonymous_field (`Fixed 0, Zero_width) ], references)
| Constant _ -> ([ Anonymous_field (`Fixed 0, Zero_width) ], references) | Constant _ -> ([ Anonymous_field (`Fixed 0, Zero_width) ], references)
| Dynamic_size { encoding } -> | Dynamic_size { encoding } ->
let (fields, refs) = fields recursives references encoding.encoding in let (fields, refs) =
fields None recursives references encoding.encoding in
(Dynamic_field (List.length fields) :: fields, refs) (Dynamic_field (List.length fields) :: fields, refs)
| Check_size { encoding } -> | Check_size { encoding } ->
fields recursives references encoding.encoding fields ref_name recursives references encoding.encoding
| Conv { encoding } -> | Conv { encoding } ->
fields recursives references encoding.encoding fields ref_name recursives references encoding.encoding
| Describe { id = name ; description ; encoding } -> | Describe { id = name ; encoding } ->
let (name, references) = describe ~name ?description recursives references encoding.encoding in fields (Some name) recursives references encoding.encoding
([ Anonymous_field (classify encoding, Ref name) ], references)
| Splitted { encoding } -> | Splitted { encoding } ->
fields recursives references encoding.encoding fields ref_name recursives references encoding.encoding
| Delayed func -> | Delayed func ->
fields recursives references (func ()).encoding fields ref_name recursives references (func ()).encoding
| List { encoding } -> | List { encoding } ->
let (layout, references) = layout recursives references encoding in let (layout, references) =
layout None recursives references encoding in
([ Anonymous_field (`Variable, Seq layout) ], ([ Anonymous_field (`Variable, Seq layout) ],
references) references)
| Array { encoding } -> | Array { encoding } ->
let (layout, references) = layout recursives references encoding in let (layout, references) =
layout None recursives references encoding in
([ Anonymous_field (`Variable, Seq layout) ], ([ Anonymous_field (`Variable, Seq layout) ],
references) references)
| Bytes kind -> | Bytes kind ->
@ -250,15 +268,18 @@ let describe (type x) ?toplevel_name (encoding : x Encoding.t) =
([ Anonymous_field ((kind :> Kind.t), String) ], references) ([ Anonymous_field ((kind :> Kind.t), String) ], references)
| (String_enum (tbl, encoding_array) as encoding) -> | (String_enum (tbl, encoding_array) as encoding) ->
let size, cases = enum tbl encoding_array in let size, cases = enum tbl encoding_array in
let name = new_reference () in let name = may_new_reference ref_name in
([ Anonymous_field (classify_desc encoding, Ref name) ], ([ Anonymous_field (classify_desc encoding, Ref name) ],
add_reference name (Int_enum { size ; cases }) references) add_reference name (Int_enum { size ; cases }) references)
| Tup { encoding } -> | Tup { encoding } ->
let (layout, references) = layout recursives references encoding in let (layout, references) =
layout ref_name recursives references encoding in
([ Anonymous_field (classify_desc encoding, layout) ], references) ([ Anonymous_field (classify_desc encoding, layout) ], references)
| Tups { left ; right } -> | Tups { left ; right } ->
let (fields1, references) = fields recursives references left.encoding in let (fields1, references) =
let (fields2, references) = fields recursives references right.encoding in fields None recursives references left.encoding in
let (fields2, references) =
fields None recursives references right.encoding in
(fields1 @ fields2, references) (fields1 @ fields2, references)
| Union { kind ; tag_size ; cases } -> | Union { kind ; tag_size ; cases } ->
let name, references = union recursives references kind tag_size cases in let name, references = union recursives references kind tag_size cases in
@ -272,48 +293,61 @@ let describe (type x) ?toplevel_name (encoding : x Encoding.t) =
let (name, references) = describe ~name ?description (name :: recursives) references encoding in let (name, references) = describe ~name ?description (name :: recursives) references encoding in
([ Anonymous_field (kind, Ref name) ], references) ([ Anonymous_field (kind, Ref name) ], references)
| Bool as encoding -> | Bool as encoding ->
let layout, references = layout recursives references encoding in let layout, references =
layout None recursives references encoding in
([ Anonymous_field (classify_desc encoding, layout) ], references) ([ Anonymous_field (classify_desc encoding, layout) ], references)
| Int8 as encoding -> | Int8 as encoding ->
let layout, references = layout recursives references encoding in let layout, references =
layout None recursives references encoding in
([ Anonymous_field (classify_desc encoding, layout) ], references) ([ Anonymous_field (classify_desc encoding, layout) ], references)
| Uint8 as encoding -> | Uint8 as encoding ->
let layout, references = layout recursives references encoding in let layout, references =
layout None recursives references encoding in
([ Anonymous_field (classify_desc encoding, layout) ], references) ([ Anonymous_field (classify_desc encoding, layout) ], references)
| Int16 as encoding -> | Int16 as encoding ->
let layout, references = layout recursives references encoding in let layout, references =
layout None recursives references encoding in
([ Anonymous_field (classify_desc encoding, layout) ], references) ([ Anonymous_field (classify_desc encoding, layout) ], references)
| Uint16 as encoding -> | Uint16 as encoding ->
let layout, references = layout recursives references encoding in let layout, references =
layout None recursives references encoding in
([ Anonymous_field (classify_desc encoding, layout) ], references) ([ Anonymous_field (classify_desc encoding, layout) ], references)
| Int31 as encoding -> | Int31 as encoding ->
let layout, references = layout recursives references encoding in let layout, references =
layout None recursives references encoding in
([ Anonymous_field (classify_desc encoding, layout) ], references) ([ Anonymous_field (classify_desc encoding, layout) ], references)
| Int32 as encoding -> | Int32 as encoding ->
let layout, references = layout recursives references encoding in let layout, references =
layout None recursives references encoding in
([ Anonymous_field (classify_desc encoding, layout) ], references) ([ Anonymous_field (classify_desc encoding, layout) ], references)
| Int64 as encoding -> | Int64 as encoding ->
let layout, references = layout recursives references encoding in let layout, references =
layout None recursives references encoding in
([ Anonymous_field (classify_desc encoding, layout) ], references) ([ Anonymous_field (classify_desc encoding, layout) ], references)
| N as encoding -> | N as encoding ->
let layout, references = layout recursives references encoding in let layout, references =
layout None recursives references encoding in
([ Anonymous_field (classify_desc encoding, layout) ], references) ([ Anonymous_field (classify_desc encoding, layout) ], references)
| Z as encoding -> | Z as encoding ->
let layout, references = layout recursives references encoding in let layout, references =
layout None recursives references encoding in
([ Anonymous_field (classify_desc encoding, layout) ], references) ([ Anonymous_field (classify_desc encoding, layout) ], references)
| RangedInt _ as encoding -> | RangedInt _ as encoding ->
let layout, references = layout recursives references encoding in let layout, references =
layout None recursives references encoding in
([ Anonymous_field (classify_desc encoding, layout) ], references) ([ Anonymous_field (classify_desc encoding, layout) ], references)
| RangedFloat _ as encoding -> | RangedFloat _ as encoding ->
let layout, references = layout recursives references encoding in let layout, references =
layout None recursives references encoding in
([ Anonymous_field (classify_desc encoding, layout) ], references) ([ Anonymous_field (classify_desc encoding, layout) ], references)
| Float as encoding -> | Float as encoding ->
let layout, references = layout recursives references encoding in let layout, references =
layout None recursives references encoding in
([ Anonymous_field (classify_desc encoding, layout) ], references) ([ Anonymous_field (classify_desc encoding, layout) ], references)
and layout : and layout :
type c. recursives -> references -> type c. string option -> recursives -> references ->
c Encoding.desc -> Binary_schema.layout * references = c Encoding.desc -> Binary_schema.layout * references =
fun recursives references -> function fun ref_name recursives references -> function
| Null -> (Zero_width, references) | Null -> (Zero_width, references)
| Empty -> (Zero_width, references) | Empty -> (Zero_width, references)
| Ignore -> (Zero_width, references) | Ignore -> (Zero_width, references)
@ -343,36 +377,43 @@ let describe (type x) ?toplevel_name (encoding : x Encoding.t) =
| String _kind -> | String _kind ->
(String, references) (String, references)
| String_enum (tbl, encoding_array) -> | String_enum (tbl, encoding_array) ->
let name = new_reference () in let name = may_new_reference ref_name in
let size, cases = enum tbl encoding_array in let size, cases = enum tbl encoding_array in
let references = add_reference name (Int_enum { size ; cases }) references in let references = add_reference name (Int_enum { size ; cases }) references in
(Enum (size, name), references) (Enum (size, name), references)
| Array data -> | Array data ->
let (descr, references) = layout recursives references data.encoding in let (descr, references) =
layout None recursives references data.encoding in
(Seq descr, references) (Seq descr, references)
| List data -> | List data ->
let layout, references = let layout, references =
layout recursives references data.encoding in layout None recursives references data.encoding in
(Seq layout, references) (Seq layout, references)
| (Obj _) as enc -> | Obj (Req { encoding = { encoding } })
let name = new_reference () in | Obj (Dft { encoding = { encoding } }) ->
let fields, references = fields recursives references enc in layout ref_name recursives references encoding
| Obj (Opt _) as enc ->
let name = may_new_reference ref_name in
let fields, references = fields None recursives references enc in
let references = add_reference name (obj fields) references in let references = add_reference name (obj fields) references in
(Ref name, references) (Ref name, references)
| Objs { left ; right } -> | Objs { left ; right } ->
let name = new_reference () in let name = may_new_reference ref_name in
let fields1, references = fields recursives references left.encoding in let fields1, references =
let fields2, references = fields recursives references right.encoding in fields None recursives references left.encoding in
let fields2, references =
fields None recursives references right.encoding in
let references = add_reference name (obj (fields1 @ fields2)) references in let references = add_reference name (obj (fields1 @ fields2)) references in
(Ref name, references) (Ref name, references)
| Tup { encoding } -> | Tup { encoding } ->
layout recursives references encoding layout ref_name recursives references encoding
| (Tups _ as descr) -> | (Tups _ as descr) ->
let fields, references = fields recursives references descr in let name = may_new_reference ref_name in
let name = new_reference () in let fields, references = fields None recursives references descr in
let references = add_reference name (obj fields) references in let references = add_reference name (obj fields) references in
(Ref name, references) (Ref name, references)
| Union { kind ; tag_size ; cases } -> | Union { kind ; tag_size ; cases } ->
(* FIXMe ref_name ?? *)
let name, references = union recursives references kind tag_size cases in let name, references = union recursives references kind tag_size cases in
(Ref name, references) (Ref name, references)
| Mu { name ; description ; fix } as encoding -> | Mu { name ; description ; fix } as encoding ->
@ -383,25 +424,23 @@ let describe (type x) ?toplevel_name (encoding : x Encoding.t) =
let (name, references) = describe ~name ?description (name :: recursives) references encoding in let (name, references) = describe ~name ?description (name :: recursives) references encoding in
(Ref name, references) (Ref name, references)
| Conv { encoding } -> | Conv { encoding } ->
layout recursives references encoding.encoding layout ref_name recursives references encoding.encoding
| Describe { id = name ; description ; encoding } -> | Describe { id = name ; encoding } ->
let name, references = layout (Some name) recursives references encoding.encoding
describe ~name ?description recursives references encoding.encoding in
(Ref name, references)
| Splitted { encoding } -> | Splitted { encoding } ->
layout recursives references encoding.encoding layout ref_name recursives references encoding.encoding
| (Dynamic_size _) as encoding -> | (Dynamic_size _) as encoding ->
let fields, references = fields recursives references encoding in let name = may_new_reference ref_name in
let name = new_reference () in let fields, references = fields None recursives references encoding in
UF.add uf { name ; description = None } ; UF.add uf { name ; description = None } ;
(Ref name, add_reference name (obj fields) references) (Ref name, add_reference name (obj fields) references)
| Check_size { encoding } -> | Check_size { encoding } ->
layout recursives references encoding.encoding layout ref_name recursives references encoding.encoding
| Delayed func -> | Delayed func ->
layout recursives references (func ()).encoding in layout ref_name recursives references (func ()).encoding in
let toplevel_name = Option.unopt ~default:"Toplevel encoding" toplevel_name in let toplevel_name = Option.unopt ~default:"Toplevel encoding" toplevel_name in
uf_add_name toplevel_name ; uf_add_name toplevel_name ;
let fields, references = fields [] { descriptions = [] } encoding.encoding in let fields, references = fields None [] { descriptions = [] } encoding.encoding in
let rev_references = (toplevel_name, obj fields) :: references.descriptions in let rev_references = (toplevel_name, obj fields) :: references.descriptions in
let dedup_canonicalize = let dedup_canonicalize =
let tbl : (Binary_schema.toplevel_encoding, Binary_schema.description) Hashtbl.t = Hashtbl.create 100 in let tbl : (Binary_schema.toplevel_encoding, Binary_schema.description) Hashtbl.t = Hashtbl.create 100 in