diff --git a/EverParse.fst.config.json b/EverParse.fst.config.json new file mode 100644 index 000000000..4c9cbe7fe --- /dev/null +++ b/EverParse.fst.config.json @@ -0,0 +1,16 @@ +{ + "fstar_exe": "fstar.exe", + "options": [ + "--max_fuel", "0", + "--max_ifuel", "2", + "--initial_ifuel", "2" + ], + "include_dirs": [ + "./src/lowparse", + "${KRML_HOME}/krmllib", + "${KRML_HOME}/krmllib/obj", + "./src/3d", + "./src/3d/prelude" + ] + } + \ No newline at end of file diff --git a/src/3d/Ast.fst b/src/3d/Ast.fst index 239520694..c8da04789 100644 --- a/src/3d/Ast.fst +++ b/src/3d/Ast.fst @@ -468,6 +468,14 @@ type field_array_t = | FieldString of (option expr) | FieldConsumeAll // [:consume-all] +[@@ PpxDerivingYoJson ] +noeq +type probe_call = { + probe_fn:option ident; + probe_length:expr; + probe_dest:ident +} + [@@ PpxDerivingYoJson ] noeq type atomic_field' = { @@ -477,7 +485,8 @@ type atomic_field' = { field_array_opt: field_array_t; field_constraint:option expr; //refinement constraint field_bitwidth:option field_bitwidth_t; //bits used for the field; elaborate from Inl to Inr - field_action:option (action & bool); //boo indicates if the action depends on the field value + field_action:option (action & bool); //bool indicates if the action depends on the field value + field_probe:option probe_call; //set in case this field has to be probed then validated } and atomic_field = with_meta_t atomic_field' @@ -565,6 +574,7 @@ type decl' = | OutputType : out_typ -> decl' | ExternType : typedef_names -> decl' | ExternFn : ident -> typ -> list param -> decl' + | ExternProbe : ident -> decl' [@@ PpxDerivingYoJson ] noeq @@ -780,6 +790,7 @@ let puint8 = mk_prim_t "PUINT8" let tuint16 = mk_prim_t "UINT16" let tuint32 = mk_prim_t "UINT32" let tuint64 = mk_prim_t "UINT64" +let tcopybuffer = mk_prim_t "EVERPARSE_COPY_BUFFER_T" let tunknown = mk_prim_t "?" let unit_atomic_field rng = let dummy_identifier = with_range (to_ident' "_empty_") rng in @@ -790,7 +801,8 @@ let unit_atomic_field rng = field_array_opt=FieldScalar; field_constraint=None; field_bitwidth=None; - field_action=None + field_action=None; + field_probe=None } in with_range f rng @@ -896,11 +908,13 @@ let subst_decl' (s:subst) (d:decl') : ML decl' = CaseType names (subst_params s params) (subst_switch_case s cases) | OutputType _ | ExternType _ - | ExternFn _ _ _ -> d + | ExternFn _ _ _ + | ExternProbe _ -> d let subst_decl (s:subst) (d:decl) : ML decl = decl_with_v d (subst_decl' s d.d_decl.v) (*** Printing the source AST; for debugging only **) -let print_constant (c:constant) = +let print_constant (c:constant) = + let print_tag = function | UInt8 -> "uy" | UInt16 -> "us" @@ -1108,13 +1122,18 @@ and print_atomic_field (f:atomic_field) : ML string = | FieldConsumeAll -> Printf.sprintf "[:consume-all]" in let sf = f.v in - Printf.sprintf "%s%s %s%s%s%s;" + Printf.sprintf "%s%s %s%s%s%s%s;" (if sf.field_dependence then "dependent " else "") (print_typ sf.field_type) (print_ident sf.field_ident) (print_bitfield sf.field_bitwidth) (print_array sf.field_array_opt) (print_opt sf.field_constraint (fun e -> Printf.sprintf "{%s}" (print_expr e))) + (print_opt sf.field_probe + (fun p -> Printf.sprintf "probe %s (length=%s, destination=%s)" + (print_opt p.probe_fn print_ident) + (print_expr p.probe_length) + (print_ident p.probe_dest))) and print_switch_case (s:switch_case) : ML string = let head, cases = s in @@ -1177,7 +1196,8 @@ let print_decl' (d:decl') : ML string = (ident_to_string td.typedef_ptr_abbrev) | OutputType out_t -> "Printing for output types is TBD" | ExternType _ -> "Printing for extern types is TBD" - | ExternFn _ _ _ -> "Printing for extern functions is TBD" + | ExternFn _ _ _ + | ExternProbe _ -> "Printing for extern functions is TBD" let print_decl (d:decl) : ML string = match d.d_decl.comments with @@ -1269,11 +1289,11 @@ let decl'_prune_actions | OutputType _ | ExternType _ | ExternFn _ _ _ - -> d - | Record names params where fields - -> Record names params where (record_prune_actions fields) - | CaseType names params cases - -> CaseType names params (switch_case_prune_actions cases) + | ExternProbe _ -> d + | Record names params where fields -> + Record names params where (record_prune_actions fields) + | CaseType names params cases -> + CaseType names params (switch_case_prune_actions cases) let decl_prune_actions (d: decl) diff --git a/src/3d/Binding.fst b/src/3d/Binding.fst index 69c32e9ea..3220fa84f 100644 --- a/src/3d/Binding.fst +++ b/src/3d/Binding.fst @@ -59,12 +59,14 @@ let copy_env (e:env) = globals = e.globals; locals = locals } - + +#push-options "--warn_error -272" //intentional top-level effect let env_of_global_env : global_env -> env = let locals = H.create 1 in fun g -> { this = None; locals; globals = g } - +#pop-options + let global_env_of_env e = e.globals let params_of_decl (d:decl) : list param = @@ -78,6 +80,7 @@ let params_of_decl (d:decl) : list param = | OutputType _ -> [] | ExternType _ -> [] | ExternFn _ _ ps -> ps + | ExternProbe _ -> [] let check_shadow (e:H.t ident' 'a) (i:ident) (r:range) = match H.try_find e i.v with @@ -291,9 +294,9 @@ let parser_weak_kind (env:global_env) (id:ident) : ML (option _) = | Some (_, Inl attrs) -> Some attrs.parser_weak_kind | _ -> None -let typ_weak_kind env (t:typ) : ML (option weak_kind) = +let rec typ_weak_kind env (t:typ) : ML (option weak_kind) = match t.v with - | Pointer _ -> None + | Pointer _ -> typ_weak_kind env tuint64 | Type_app hd _ _ -> parser_weak_kind env.globals hd let typ_has_reader env (t:typ) : ML bool = @@ -462,6 +465,15 @@ let add_extern_type (ge:global_env) (i:ident) (d:decl{ExternType? d.d_decl.v}) : let td_abbrev = (ExternType?._0 d.d_decl.v).typedef_abbrev in insert td_abbrev.v +(* + * Add extern probe function to the environment + * + * TODO: check shadow + *) +let add_extern_probe (ge:global_env) (i:ident) (d:decl{ExternProbe? d.d_decl.v}) : ML unit = + H.insert ge.ge_probe_fn i.v d + + (* * Add extern function to the environment * @@ -655,6 +667,11 @@ let rec check_typ (pointer_ok:bool) (env:env) (t:typ) | Type_app _ KindOutput _ -> error "Impossible, check_typ is not supposed to typecheck output types!" t.range +and check_ident (env:env) (i:ident) + : ML (ident & typ) + = let t = lookup_expr_name env i in + i, t + and check_expr (env:env) (e:expr) : ML (expr & typ) = let w e' = with_range e' e.range in @@ -683,8 +700,8 @@ and check_expr (env:env) (e:expr) e, type_of_constant e.range c | Identifier i -> - let t = lookup_expr_name env i in - e, t + let i, t = check_ident env i in + { e with v = Identifier i }, t | Static _ -> failwith "Static expressions should have been desugared already" @@ -1080,7 +1097,7 @@ let rec check_field_action (env:env) (f:atomic_field) (a:action) let check_atomic_field (env:env) (extend_scope: bool) (f:atomic_field) : ML atomic_field = let sf = f.v in - let sf_field_type = check_typ false env sf.field_type in + let sf_field_type = check_typ (Some? sf.field_probe) env sf.field_type in let check_annot (e: expr) : ML expr = let e, t = check_expr env e in if not (eq_typ env t tuint32) @@ -1117,14 +1134,72 @@ let check_atomic_field (env:env) (extend_scope: bool) (f:atomic_field) remove_local env sf.field_ident; a, dependent) in + let f_probe = + match sf.field_probe with + | None -> None + | Some p -> + let length, typ = check_expr env p.probe_length in + let length = + if not (eq_typ env typ tuint64) + then match try_cast_integer env (length, typ) tuint64 with + | Some e -> e + | _ -> error (Printf.sprintf "Probe length expression %s has type %s instead of UInt64" + (print_expr length) + (print_typ typ)) + length.range + else length + in + let dest, dest_typ = check_ident env p.probe_dest in + if not (eq_typ env dest_typ tcopybuffer) + then error (Printf.sprintf "Probe destination expression %s has type %s instead of EVERPARSE_COPY_BUFFER_T" + (print_ident dest) + (print_typ dest_typ)) + dest.range; + let probe_fn = + match p.probe_fn with + | None -> ( + match GlobalEnv.default_probe_fn env.globals with + | None -> + error (Printf.sprintf "Probe function not specified and no default probe function found") + p.probe_length.range + | Some i -> i + ) + | Some p -> ( + match GlobalEnv.resolve_probe_fn env.globals p with + | None -> + error (Printf.sprintf "Probe function %s not found" (print_ident p)) + p.range + | Some i -> + i + ) + in + Some { probe_fn=Some probe_fn; probe_length=length; probe_dest=dest } + in if extend_scope then add_local env sf.field_ident sf.field_type; let sf = { sf with field_type = sf_field_type; field_array_opt = fa; field_constraint = fc; - field_action = f_act + field_action = f_act; + field_probe = f_probe; } in + let _ = + match sf.field_type.v, sf.field_array_opt, + sf.field_constraint, sf.field_bitwidth, + sf.field_action, sf.field_probe + with + | Pointer _, FieldScalar, + None, None, + None, Some _ -> + () + | _, _, + _, _, + _, Some _ -> + error (Printf.sprintf "Probe annotation is only allowed on pointer fields with no other constraints") + f.range + | _ -> () + in Options.debug_print_string (Printf.sprintf "Field %s has comments <%s>\n" (print_ident sf.field_ident) @@ -1582,7 +1657,8 @@ let elaborate_record_decl (e:global_env) field_array_opt = FieldScalar; field_constraint = w; field_bitwidth = None; - field_action = None + field_action = None; + field_probe = None } in let af = with_range (AtomicField (with_range field e.range)) e.range in @@ -1734,73 +1810,210 @@ let bind_decl (e:global_env) (d:decl) : ML decl = add_extern_fn e f d; d + | ExternProbe i -> + add_extern_probe e i d; + d + let bind_decls (g:global_env) (p:list decl) : ML (list decl & global_env) = List.map (bind_decl g) p, g let initial_global_env () = let cfg = Deps.get_config () in - let e = { - ge_h = H.create 10; - ge_out_t = H.create 10; - ge_extern_t = H.create 10; - ge_extern_fn = H.create 10; - ge_cfg = cfg - } + let e = + { + ge_h = H.create 10; + ge_out_t = H.create 10; + ge_extern_t = H.create 10; + ge_extern_fn = H.create 10; + ge_probe_fn = H.create 10; + ge_cfg = cfg + } in let nullary_decl i = - let td_name = { - typedef_name = i; - typedef_abbrev = i; - typedef_ptr_abbrev = i; - typedef_attributes = [] - } + let td_name = + { typedef_name = i; typedef_abbrev = i; typedef_ptr_abbrev = i; typedef_attributes = [] } in mk_decl (Record td_name [] None []) dummy_range [] true in let _type_names = - [ ("unit", { may_fail = false; integral = None; bit_order = None; has_reader = true; parser_weak_kind = WeakKindStrongPrefix; parser_kind_nz=Some false}); - ("Bool", { may_fail = true; integral = None; bit_order = None; has_reader = true; parser_weak_kind = WeakKindStrongPrefix; parser_kind_nz=Some true}); - ("UINT8", { may_fail = true; integral = Some UInt8 ; bit_order = Some LSBFirst ; has_reader = true; parser_weak_kind = WeakKindStrongPrefix; parser_kind_nz=Some true }); - ("UINT16", { may_fail = true; integral = Some UInt16 ; bit_order = Some LSBFirst ; has_reader = true; parser_weak_kind = WeakKindStrongPrefix; parser_kind_nz=Some true }); - ("UINT32", { may_fail = true; integral = Some UInt32 ; bit_order = Some LSBFirst ; has_reader = true; parser_weak_kind = WeakKindStrongPrefix; parser_kind_nz=Some true}); - ("UINT64", { may_fail = true; integral = Some UInt64 ; bit_order = Some LSBFirst ; has_reader = true; parser_weak_kind = WeakKindStrongPrefix; parser_kind_nz=Some true}); - ("UINT8BE", { may_fail = true; integral = Some UInt8 ; bit_order = Some MSBFirst ; has_reader = true; parser_weak_kind = WeakKindStrongPrefix; parser_kind_nz=Some true }); - ("UINT16BE", { may_fail = true; integral = Some UInt16 ; bit_order = Some MSBFirst ; has_reader = true; parser_weak_kind = WeakKindStrongPrefix; parser_kind_nz=Some true }); - ("UINT32BE", { may_fail = true; integral = Some UInt32 ; bit_order = Some MSBFirst ; has_reader = true; parser_weak_kind = WeakKindStrongPrefix; parser_kind_nz=Some true}); - ("UINT64BE", { may_fail = true; integral = Some UInt64 ; bit_order = Some MSBFirst ; has_reader = true; parser_weak_kind = WeakKindStrongPrefix; parser_kind_nz=Some true}); - ("field_id", { may_fail = true; integral = Some UInt32 ; bit_order = None ; has_reader = false; parser_weak_kind = WeakKindStrongPrefix; parser_kind_nz=Some true}); - ("all_bytes", { may_fail = false; integral = None ; bit_order = None ; has_reader = false; parser_weak_kind = WeakKindConsumesAll; parser_kind_nz=Some false}); - ("all_zeros", { may_fail = true; integral = None ; bit_order = None ; has_reader = false; parser_weak_kind = WeakKindConsumesAll; parser_kind_nz=Some false}); - ("PUINT8", { may_fail = true; integral = None ; bit_order = None ; has_reader = false; parser_weak_kind = WeakKindStrongPrefix; parser_kind_nz=Some true})] - |> List.iter (fun (i, attrs) -> - let i = with_dummy_range (to_ident' i) in - add_global e i (nullary_decl i) (Inl attrs)) + [ + ("unit", + { + may_fail = false; + integral = None; + bit_order = None; + has_reader = true; + parser_weak_kind = WeakKindStrongPrefix; + parser_kind_nz = Some false + }); + ("Bool", + { + may_fail = true; + integral = None; + bit_order = None; + has_reader = true; + parser_weak_kind = WeakKindStrongPrefix; + parser_kind_nz = Some true + }); + ("UINT8", + { + may_fail = true; + integral = Some UInt8; + bit_order = Some LSBFirst; + has_reader = true; + parser_weak_kind = WeakKindStrongPrefix; + parser_kind_nz = Some true + }); + ("UINT16", + { + may_fail = true; + integral = Some UInt16; + bit_order = Some LSBFirst; + has_reader = true; + parser_weak_kind = WeakKindStrongPrefix; + parser_kind_nz = Some true + }); + ("UINT32", + { + may_fail = true; + integral = Some UInt32; + bit_order = Some LSBFirst; + has_reader = true; + parser_weak_kind = WeakKindStrongPrefix; + parser_kind_nz = Some true + }); + ("UINT64", + { + may_fail = true; + integral = Some UInt64; + bit_order = Some LSBFirst; + has_reader = true; + parser_weak_kind = WeakKindStrongPrefix; + parser_kind_nz = Some true + }); + ("UINT8BE", + { + may_fail = true; + integral = Some UInt8; + bit_order = Some MSBFirst; + has_reader = true; + parser_weak_kind = WeakKindStrongPrefix; + parser_kind_nz = Some true + }); + ("UINT16BE", + { + may_fail = true; + integral = Some UInt16; + bit_order = Some MSBFirst; + has_reader = true; + parser_weak_kind = WeakKindStrongPrefix; + parser_kind_nz = Some true + }); + ("UINT32BE", + { + may_fail = true; + integral = Some UInt32; + bit_order = Some MSBFirst; + has_reader = true; + parser_weak_kind = WeakKindStrongPrefix; + parser_kind_nz = Some true + }); + ("UINT64BE", + { + may_fail = true; + integral = Some UInt64; + bit_order = Some MSBFirst; + has_reader = true; + parser_weak_kind = WeakKindStrongPrefix; + parser_kind_nz = Some true + }); + ("field_id", + { + may_fail = true; + integral = Some UInt32; + bit_order = None; + has_reader = false; + parser_weak_kind = WeakKindStrongPrefix; + parser_kind_nz = Some true + }); + ("all_bytes", + { + may_fail = false; + integral = None; + bit_order = None; + has_reader = false; + parser_weak_kind = WeakKindConsumesAll; + parser_kind_nz = Some false + }); + ("all_zeros", + { + may_fail = true; + integral = None; + bit_order = None; + has_reader = false; + parser_weak_kind = WeakKindConsumesAll; + parser_kind_nz = Some false + }); + ("PUINT8", + { + may_fail = true; + integral = None; + bit_order = None; + has_reader = false; + parser_weak_kind = WeakKindStrongPrefix; + parser_kind_nz = Some true + }); + ("EVERPARSE_COPY_BUFFER_T", + { + may_fail = true; + integral = None; + bit_order = None; + has_reader = false; + parser_weak_kind = WeakKindStrongPrefix; + parser_kind_nz = Some true + }); + ] |> + List.iter (fun (i, attrs) -> + let i = with_dummy_range (to_ident' i) in + add_global e i (nullary_decl i) (Inl attrs)) in let _operators = - [ ("is_range_okay", { macro_arguments_t=[tuint32;tuint32;tuint32]; macro_result_t=tbool; macro_defn_t = None}) ] - |> List.iter (fun (i, d) -> - let i = with_dummy_range (to_ident' i) in - add_global e i (nullary_decl i) (Inr d)) + [ + ("is_range_okay", + { + macro_arguments_t = [tuint32; tuint32; tuint32]; + macro_result_t = tbool; + macro_defn_t = None + }) + ] |> + List.iter (fun (i, d) -> + let i = with_dummy_range (to_ident' i) in + add_global e i (nullary_decl i) (Inr d)) in let _void = let void_ident = with_dummy_range (to_ident' "void") in - add_extern_type e void_ident (mk_decl (ExternType ({ - typedef_name = void_ident; - typedef_abbrev = void_ident; - typedef_ptr_abbrev = void_ident; - typedef_attributes = [] - })) dummy_range [] false) + add_extern_type e + void_ident + (mk_decl (ExternType + ({ + typedef_name = void_ident; + typedef_abbrev = void_ident; + typedef_ptr_abbrev = void_ident; + typedef_attributes = [] + })) + dummy_range + [] + false) in - let _ = + let _ = match cfg with | None -> () | Some (cfg, module_name) -> - List.iter - (fun flag -> - let ms = nullary_macro tbool None in - let i = with_dummy_range { to_ident' flag with modul_name = Some module_name } in - let d = mk_decl (ExternFn i tbool []) dummy_range [] false in - add_global e i d (Inr ms)) + List.iter (fun flag -> + let ms = nullary_macro tbool None in + let i = with_dummy_range ({ to_ident' flag with modul_name = Some module_name }) in + let d = mk_decl (ExternFn i tbool []) dummy_range [] false in + add_global e i d (Inr ms)) cfg.compile_time_flags.flags in e diff --git a/src/3d/BitFields.fst b/src/3d/BitFields.fst index 5288aa3a5..9fd6e1d24 100644 --- a/src/3d/BitFields.fst +++ b/src/3d/BitFields.fst @@ -123,6 +123,7 @@ let coalesce_grouped_bit_field env (f:bitfield_group) field_constraint = field_constraint; field_bitwidth = None; field_action = field_action; + field_probe = None } in let af = with_dummy_range struct_field in with_dummy_range (AtomicField af), diff --git a/src/3d/Deps.fst b/src/3d/Deps.fst index 8b5ee65a4..f33c70002 100644 --- a/src/3d/Deps.fst +++ b/src/3d/Deps.fst @@ -17,7 +17,8 @@ type dep_graph = { modules_with_output_types: list string; modules_with_out_exprs: list string; modules_with_extern_types: list string; - modules_with_extern_functions: list string + modules_with_extern_functions: list string; + modules_with_extern_probe: list string; } let all_edges_from (g:dep_graph') (node:string) : Tot (list edge) = @@ -63,7 +64,8 @@ type scan_deps_t = { sd_has_output_types: bool; sd_has_out_exprs: bool; sd_has_extern_types: bool; - sd_has_extern_functions: bool + sd_has_extern_functions: bool; + sd_has_extern_probe: bool; } let scan_deps (fn:string) : ML scan_deps_t = @@ -196,7 +198,8 @@ let scan_deps (fn:string) : ML scan_deps_t = (deps_of_switch_case sc) | OutputType _ | ExternType _ - | ExternFn _ _ _ -> [] //AR: no dependencies from the output/extern types yet + | ExternFn _ _ _ + | ExternProbe _ -> [] //AR: no dependencies from the output/extern types yet in let has_output_types (ds:list decl) : bool = @@ -211,6 +214,9 @@ let scan_deps (fn:string) : ML scan_deps_t = let has_extern_functions (ds:list decl) : bool = List.Tot.existsb (fun d -> ExternFn? d.d_decl.v) ds in + let has_extern_probe (ds: list decl) : bool = + List.Tot.existsb (fun d -> ExternProbe? d.d_decl.v) ds in + { sd_deps = List.collect deps_of_decl decls; sd_has_entrypoint = has_entrypoint; @@ -219,6 +225,7 @@ let scan_deps (fn:string) : ML scan_deps_t = sd_has_out_exprs = has_out_exprs decls; sd_has_extern_types = has_extern_types decls; sd_has_extern_functions = has_extern_functions decls; + sd_has_extern_probe = has_extern_probe decls; } let rec build_dep_graph_aux (dirname:string) (mname:string) (acc:dep_graph & list string) @@ -233,7 +240,9 @@ let rec build_dep_graph_aux (dirname:string) (mname:string) (acc:dep_graph & lis sd_has_output_types = has_output_types; sd_has_out_exprs = has_out_exprs; sd_has_extern_types = has_extern_types; - sd_has_extern_functions = has_extern_functions} = + sd_has_extern_functions = has_extern_functions; + sd_has_extern_probe = has_extern_probe; + } = scan_deps (Options.get_file_name (OS.concat dirname mname)) in let edges = List.fold_left (fun edges dep -> @@ -248,6 +257,7 @@ let rec build_dep_graph_aux (dirname:string) (mname:string) (acc:dep_graph & lis modules_with_out_exprs = (if has_out_exprs then mname::g.modules_with_out_exprs else g.modules_with_out_exprs); modules_with_extern_types = (if has_extern_types then mname::g.modules_with_extern_types else g.modules_with_extern_types); modules_with_extern_functions = (if has_extern_functions then mname::g.modules_with_extern_functions else g.modules_with_extern_functions); + modules_with_extern_probe = (if has_extern_probe then mname::g.modules_with_extern_probe else g.modules_with_extern_probe); } in List.fold_left (fun acc dep -> build_dep_graph_aux dirname dep acc) @@ -261,7 +271,8 @@ let build_dep_graph_from_list files = modules_with_output_types = []; modules_with_out_exprs = []; modules_with_extern_types = []; - modules_with_extern_functions = [] + modules_with_extern_functions = []; + modules_with_extern_probe = []; } in let g1 = List.fold_left (fun acc fn -> build_dep_graph_aux (OS.dirname fn) (Options.get_module_name fn) acc) (g0, []) files @@ -303,6 +314,8 @@ let has_extern_types g m = List.Tot.mem m g.modules_with_extern_types let has_extern_functions g m = List.Tot.mem m g.modules_with_extern_functions +let has_extern_probe g m = List.Tot.mem m g.modules_with_extern_probe + #push-options "--warn_error -272" let parsed_config : ref (option (Config.config & string)) = ST.alloc None diff --git a/src/3d/Deps.fsti b/src/3d/Deps.fsti index cb917eb16..2fbc71d2c 100644 --- a/src/3d/Deps.fsti +++ b/src/3d/Deps.fsti @@ -25,4 +25,6 @@ val has_extern_types (g:dep_graph) (modul:string) : bool val has_extern_functions (g:dep_graph) (modul:string) : bool +val has_extern_probe (g:dep_graph) (modul:string) : bool + val get_config (_:unit) : ML (option (Config.config & string)) diff --git a/src/3d/Desugar.fst b/src/3d/Desugar.fst index 2b8f9614d..0fb881750 100644 --- a/src/3d/Desugar.fst +++ b/src/3d/Desugar.fst @@ -166,7 +166,7 @@ let push_name (env:qenv) (name:string) : qenv = let prim_consts = [ "unit"; "Bool"; "UINT8"; "UINT16"; "UINT32"; "UINT64"; "UINT8BE"; "UINT16BE"; "UINT32BE"; "UINT64BE"; - "field_id"; "PUINT8"; + "field_id"; "PUINT8"; "EVERPARSE_COPY_BUFFER_T"; "all_bytes"; "all_zeros"; "is_range_okay"; "void" ] @@ -331,6 +331,13 @@ let resolve_field_array_t (env:qenv) (farr:field_array_t) : ML field_array_t = | FieldString (Some e) -> FieldString (Some (resolve_expr env e)) | FieldConsumeAll -> farr +let resolve_probe_call env pc = + { + probe_fn = map_opt (resolve_ident env) pc.probe_fn; + probe_length = resolve_expr env pc.probe_length; + probe_dest = resolve_ident env pc.probe_dest; + } + let rec resolve_field (env:qenv) (ff:field) : ML (field & qenv) = match ff.v with | AtomicField f -> let f, e = resolve_atomic_field env f in {ff with v = AtomicField f}, e @@ -350,7 +357,8 @@ and resolve_atomic_field (env:qenv) (f:atomic_field) : ML (atomic_field & qenv) field_array_opt = resolve_field_array_t env sf.field_array_opt; field_constraint = map_opt (resolve_expr env) sf.field_constraint; field_bitwidth = map_opt (resolve_field_bitwidth_t env) sf.field_bitwidth; - field_action = map_opt (fun (a, b) -> resolve_action env a, b) sf.field_action } + field_action = map_opt (fun (a, b) -> resolve_action env a, b) sf.field_action; + field_probe = map_opt (resolve_probe_call env) sf.field_probe } ) in let env = push_name env f.v.field_ident.v.name in @@ -427,6 +435,9 @@ let resolve_decl' (env:qenv) (d:decl') : ML decl' = let ret = resolve_typ env ret in let params, _ = resolve_params env params in ExternFn id ret params + | ExternProbe id -> + let id = resolve_ident env id in + ExternProbe id let resolve_decl (env:qenv) (d:decl) : ML decl = decl_with_v d (resolve_decl' env d.d_decl.v) diff --git a/src/3d/EverParse3DCompiler.fst.config.json b/src/3d/EverParse3DCompiler.fst.config.json new file mode 100644 index 000000000..0e1c65c70 --- /dev/null +++ b/src/3d/EverParse3DCompiler.fst.config.json @@ -0,0 +1,9 @@ +{ + "fstar_exe": "fstar.exe", + "options": [ + ], + "include_dirs": [ + "." + ] + } + \ No newline at end of file diff --git a/src/3d/EverParseEndianness.h b/src/3d/EverParseEndianness.h index 79fb5a45c..c247bbf7a 100644 --- a/src/3d/EverParseEndianness.h +++ b/src/3d/EverParseEndianness.h @@ -30,11 +30,16 @@ extern "C" { ********* Implementation of LowStar.Endianness (selected bits) ************** *****************************************************************************/ +#if defined(_MSC_VER) +# include +#endif + #include #include typedef const char * EVERPARSE_STRING; typedef EVERPARSE_STRING PRIMS_STRING; +typedef void* EVERPARSE_COPY_BUFFER_T; #ifndef KRML_MAYBE_UNUSED_VAR # define KRML_MAYBE_UNUSED_VAR(x) (void)(x) @@ -69,7 +74,6 @@ typedef EVERPARSE_STRING PRIMS_STRING; #if defined(_MSC_VER) # include -# include # define htobe16(x) _byteswap_ushort(x) # define htole16(x) (x) diff --git a/src/3d/EverParseEndianness_Windows_NT.h b/src/3d/EverParseEndianness_Windows_NT.h index d15e424e4..9f6d391d6 100755 --- a/src/3d/EverParseEndianness_Windows_NT.h +++ b/src/3d/EverParseEndianness_Windows_NT.h @@ -25,6 +25,7 @@ nswamy, protz, taramana 5-Feb-2020 ********* Implementation of LowStar.Endianness (selected bits) ************** *****************************************************************************/ +#include #include /* ... for Windows (MSVC)... not targeting XBOX 360! */ @@ -32,10 +33,9 @@ nswamy, protz, taramana 5-Feb-2020 # include # include -# include - typedef const char * EVERPARSE_STRING; typedef EVERPARSE_STRING PRIMS_STRING; +typedef void* EVERPARSE_COPY_BUFFER_T; #ifndef KRML_MAYBE_UNUSED_VAR # define KRML_MAYBE_UNUSED_VAR(x) (void)(x) diff --git a/src/3d/GenMakefile.fst b/src/3d/GenMakefile.fst index 930e6f935..521a7dde1 100644 --- a/src/3d/GenMakefile.fst +++ b/src/3d/GenMakefile.fst @@ -16,7 +16,12 @@ type rule_t = { let input_dir = "$(EVERPARSE_INPUT_DIR)" let output_dir = "$(EVERPARSE_OUTPUT_DIR)" -let print_gnu_make_rule +let oext = function +| HashingOptions.MakefileGMake -> "o" +| HashingOptions.MakefileNMake -> "obj" + +let print_make_rule + mtype input_stream_binding (r: rule_t) : Tot string @@ -29,9 +34,17 @@ let print_gnu_make_rule match r.ty with | EverParse -> Printf.sprintf "$(EVERPARSE_CMD) --odir %s" output_dir | CC -> + let iopt = match mtype with + | HashingOptions.MakefileGMake -> "-I" + | HashingOptions.MakefileNMake -> "/I" + in + let copt = match mtype with + | HashingOptions.MakefileGMake -> "-c" + | HashingOptions.MakefileNMake -> "/c" + in let ddd_home = "$(EVERPARSE_HOME)" `OS.concat` "src" `OS.concat` "3d" in let ddd_actions_home = ddd_home `OS.concat` "prelude" `OS.concat` (HashingOptions.string_of_input_stream_binding input_stream_binding) in - Printf.sprintf "$(CC) $(CFLAGS) -I %s -I %s -c" ddd_home ddd_actions_home + Printf.sprintf "$(CC) $(CFLAGS) %s %s %s %s %s" iopt ddd_home iopt ddd_actions_home copt in let rule = Printf.sprintf "%s\t%s %s\n\n" rule cmd r.args in rule @@ -102,6 +115,7 @@ let has_external_api_fsti (modul: string) : Tot bool = + Deps.has_extern_probe g modul || Deps.has_out_exprs g modul || Deps.has_extern_types g modul || Deps.has_extern_functions g modul @@ -389,7 +403,15 @@ let produce_h_rules List.Tot.map (produce_nop_rule [to]) (maybe_krml_generated_h g m) ) all_files +let c_to_o mtype o c = + let oflag = match mtype with + | HashingOptions.MakefileGMake -> "-o" + | HashingOptions.MakefileNMake -> "/Fo:" + in + Printf.sprintf "%s %s %s" oflag o c + let produce_output_types_o_rule + mtype (emit_output_types_defs: bool) (g:Deps.dep_graph) (modul:string) @@ -398,61 +420,64 @@ let produce_output_types_o_rule if Deps.has_out_exprs g modul then let c = mk_filename (Printf.sprintf "%s_OutputTypes" modul) "c" in - let o = mk_filename (Printf.sprintf "%s_OutputTypes" modul) "o" in + let o = mk_filename (Printf.sprintf "%s_OutputTypes" modul) (oext mtype) in [{ ty = CC; from = c :: maybe_external_typedefs_h emit_output_types_defs g modul; to = o; - args = Printf.sprintf "-o %s %s" o c; }] + args = c_to_o mtype o c; }] else let _ = FStar.IO.print_string (Printf.sprintf "%s has no output types\n" modul) in [] let produce_o_rule + mtype (modul: string) : Tot rule_t = let c = mk_filename modul "c" in - let o = mk_filename modul "o" in + let o = mk_filename modul (oext mtype) in { ty = CC; from = [c; mk_filename modul "h"]; to = o; - args = Printf.sprintf "-o %s %s" o c; + args = c_to_o mtype o c; } let produce_wrapper_o_rule + mtype (g: Deps.dep_graph) (modul: string) : Tot (list rule_t) = let wc = mk_filename (Printf.sprintf "%sWrapper" modul) "c" in let wh = mk_filename (Printf.sprintf "%sWrapper" modul) "h" in - let wo = mk_filename (Printf.sprintf "%sWrapper" modul) "o" in + let wo = mk_filename (Printf.sprintf "%sWrapper" modul) (oext mtype) in let h = mk_filename modul "h" in if Deps.has_entrypoint g modul then [{ ty = CC; from = [wc; wh; h]; to = wo; - args = Printf.sprintf "-o %s %s" wo wc; + args = c_to_o mtype wo wc; }] else [] let produce_static_assertions_o_rule + mtype (g: Deps.dep_graph) (modul: string) : Tot (list rule_t) = let wc = mk_filename (Printf.sprintf "%sStaticAssertions" modul) "c" in - let wo = mk_filename (Printf.sprintf "%sStaticAssertions" modul) "o" in + let wo = mk_filename (Printf.sprintf "%sStaticAssertions" modul) (oext mtype) in let h = mk_filename modul "h" in if Deps.has_static_assertions g modul then [{ ty = CC; from = [wc; h]; to = wo; - args = Printf.sprintf "-o %s %s" wo wc; + args = c_to_o mtype wo wc; }] else [] @@ -476,6 +501,7 @@ type produce_makefile_res = { } let produce_makefile + mtype (emit_output_types_defs: bool) (skip_o_rules: bool) (clang_format: bool) @@ -488,10 +514,10 @@ let produce_makefile let rules = produce_clang_format_rule clang_format `List.Tot.append` (if skip_o_rules then [] else - List.Tot.concatMap (produce_wrapper_o_rule g) all_modules `List.Tot.append` - List.Tot.concatMap (produce_static_assertions_o_rule g) all_modules `List.Tot.append` - List.concatMap (produce_output_types_o_rule emit_output_types_defs g) all_modules `List.Tot.append` - List.Tot.map produce_o_rule all_modules + List.Tot.concatMap (produce_wrapper_o_rule mtype g) all_modules `List.Tot.append` + List.Tot.concatMap (produce_static_assertions_o_rule mtype g) all_modules `List.Tot.append` + List.concatMap (produce_output_types_o_rule mtype emit_output_types_defs g) all_modules `List.Tot.append` + List.Tot.map (produce_o_rule mtype) all_modules ) `List.Tot.append` List.concatMap (produce_fst_rules emit_output_types_defs g clang_format) all_files `List.Tot.append` List.concatMap (produce_external_types_fsti_checked_rule g) all_modules `List.Tot.append` @@ -509,7 +535,8 @@ let produce_makefile all_files = all_files; } -let write_gnu_makefile +let write_makefile + mtype input_stream_binding (emit_output_types_defs: bool) (skip_o_rules: bool) @@ -519,8 +546,8 @@ let write_gnu_makefile = let makefile = Options.get_makefile_name () in let file = FStar.IO.open_write_file makefile in - let {graph = g; rules; all_files} = produce_makefile emit_output_types_defs skip_o_rules clang_format files in - FStar.IO.write_string file (String.concat "" (List.Tot.map (print_gnu_make_rule input_stream_binding) rules)); + let {graph = g; rules; all_files} = produce_makefile mtype emit_output_types_defs skip_o_rules clang_format files in + FStar.IO.write_string file (String.concat "" (List.Tot.map (print_make_rule mtype input_stream_binding) rules)); let write_all_ext_files (ext_cap: string) (ext: string) : FStar.All.ML unit = let ln = begin if ext <> "h" @@ -548,21 +575,5 @@ let write_gnu_makefile in write_all_ext_files "H" "h"; write_all_ext_files "C" "c"; - write_all_ext_files "O" "o"; + write_all_ext_files "O" (oext mtype); FStar.IO.close_write_file file - -let write_nmakefile = write_gnu_makefile - -let write_makefile - (mtype: HashingOptions.makefile_type) -: Tot ( - (_: HashingOptions.input_stream_binding_t) -> - (emit_output_types_defs: bool) -> - (skip_o_rules: bool) -> - (clang_format: bool) -> - (files: list string) -> - FStar.All.ML unit - ) -= match mtype with - | HashingOptions.MakefileGMake -> write_gnu_makefile - | HashingOptions.MakefileNMake -> write_nmakefile diff --git a/src/3d/GlobalEnv.fst b/src/3d/GlobalEnv.fst index 9ed65b84f..39c46391e 100755 --- a/src/3d/GlobalEnv.fst +++ b/src/3d/GlobalEnv.fst @@ -76,5 +76,23 @@ type global_env = { ge_out_t: H.t ident' decl; //a table for output types declarations ge_extern_t: H.t ident' decl; //a table for extern type declarations ge_extern_fn: H.t ident' decl; //a table for extern function declarations + ge_probe_fn: H.t ident' decl; //a table for probe function declarations ge_cfg: option (Config.config & string) } + +let default_probe_fn (g:global_env) + : ML (option ident) + = if H.length g.ge_probe_fn <> 1 + then None + else ( + match H.fold (fun k v _ -> Some v) g.ge_probe_fn (None #decl) with + | Some {d_decl={v=ExternProbe id}} -> Some id + | _ -> None + ) + +let resolve_probe_fn (g:global_env) (id:ident) + : ML (option ident) + = match H.try_find g.ge_probe_fn id.v with + | Some {d_decl={v=ExternProbe id}} -> Some id + | _ -> None + \ No newline at end of file diff --git a/src/3d/InlineSingletonRecords.fst b/src/3d/InlineSingletonRecords.fst index f2f7fad2d..fc4f8be82 100644 --- a/src/3d/InlineSingletonRecords.fst +++ b/src/3d/InlineSingletonRecords.fst @@ -41,7 +41,11 @@ let simplify_atomic_field (env:env) (f:atomic_field) = let field = f.v in let field = match field.field_type.v with - | Pointer _ -> failwith "Impossible: field types cannot be pointers" + | Pointer _ -> ( + if Some? field.field_probe + then field + else failwith "Impossible: field types cannot be pointers" + ) | Type_app hd _ args -> begin match H.try_find env hd.v with @@ -168,7 +172,8 @@ let simplify_decl (env:env) (d:decl) : ML decl = field_array_opt = FieldScalar; field_constraint = Some constraint; field_bitwidth = None; - field_action = None } + field_action = None; + field_probe = None } in let af = with_dummy_range field in Options.debug_print_string @@ -202,7 +207,8 @@ let simplify_decl (env:env) (d:decl) : ML decl = | OutputType _ | ExternType _ - | ExternFn _ _ _ -> d + | ExternFn _ _ _ + | ExternProbe _ -> d let simplify_prog (p:list decl) = let env = H.create 10 in diff --git a/src/3d/InterpreterTarget.fst b/src/3d/InterpreterTarget.fst index acc0a6482..dd7e746e6 100644 --- a/src/3d/InterpreterTarget.fst +++ b/src/3d/InterpreterTarget.fst @@ -21,20 +21,97 @@ module A = Ast module T = Target module H = Hashtable + noeq type inv = - | Inv_true : inv | Inv_conj : inv -> inv -> inv - | Inv_ptr : A.ident -> inv - | Inv_name : A.ident -> list expr -> inv + | Inv_ptr : expr -> inv + | Inv_copy_buf: expr -> inv noeq type eloc = - | Eloc_none : eloc | Eloc_output : eloc | Eloc_union : eloc -> eloc -> eloc - | Eloc_ptr : A.ident -> eloc - | Eloc_name : A.ident -> list expr -> eloc + | Eloc_ptr : expr -> eloc + | Eloc_copy_buf: e:expr { T.Identifier? (fst e) } -> eloc + +noeq +type disj = + | Disj_pair : l:eloc{ Eloc_copy_buf? l } -> eloc -> disj + | Disj_conj : disj -> disj -> disj + +let index a = option a + +let disj_pair l m : index disj = + match l, m with + | None, i + | i, None -> None + | Some l, Some m -> Some (Disj_pair l m) + + +let subst_index (s:'a -> ML 'a) (i:index 'a) = + match i with + | None -> None + | Some i -> Some (s i) + +let join_index j d0 d1 = + match d0, d1 with + | None, d + | d, None -> d + | Some d0, Some d1 -> Some (j d0 d1) + +let join_inv = join_index Inv_conj +let join_eloc = join_index Eloc_union +let join_disj = join_index Disj_conj + +let rec subst_inv' subst (i:inv) + : inv + = match i with + | Inv_conj i j -> + Inv_conj (subst_inv' subst i) + (subst_inv' subst j) + | Inv_ptr x -> + Inv_ptr (T.subst_expr subst x) + | Inv_copy_buf x -> + Inv_copy_buf (T.subst_expr subst x) +let subst_inv s = subst_index (subst_inv' s) + +let eq_tags e e' = + match e, e' with + | Eloc_output, Eloc_output + | Eloc_union _ _, Eloc_union _ _ + | Eloc_ptr _, Eloc_ptr _ + | Eloc_copy_buf _, Eloc_copy_buf _ -> true + | _ -> false + +let rec subst_eloc' subst (e:eloc) + : ML (e':eloc { eq_tags e e' }) + = match e with + | Eloc_output -> e + | Eloc_union i j -> + Eloc_union (subst_eloc' subst i) + (subst_eloc' subst j) + | Eloc_ptr x -> Eloc_ptr (T.subst_expr subst x) + | Eloc_copy_buf x -> + let y = T.subst_expr subst x in + if not (T.Identifier? (fst y)) + then ( + Ast.error "Unexpected non-identifier in subst_eloc" (snd x) + ) + else + Eloc_copy_buf y +let subst_eloc s = subst_index (subst_eloc' s) + +let rec subst_disj' subst (d:disj) + : ML disj + = match d with + | Disj_pair e1 e2 -> + Disj_pair (subst_eloc' subst e1) + (subst_eloc' subst e2) + | Disj_conj d1 d2 -> + Disj_conj (subst_disj' subst d1) + (subst_disj' subst d2) +let subst_disj s = subst_index (subst_disj' s) noeq type on_success = @@ -42,10 +119,13 @@ type on_success = | On_success_named : A.ident -> list expr -> on_success | On_success_union : on_success -> on_success -> on_success -let inv_eloc = inv & eloc & on_success -let inv_eloc_nil = Inv_true, Eloc_none, On_success false -let inv_eloc_union (i, e, b) (i', e', b') = Inv_conj i i', Eloc_union e e', On_success_union b b' -let inv_eloc_name hd args = Inv_name hd args, Eloc_name hd args, On_success_named hd args +let typ_indexes = index inv & index eloc & index disj & on_success +let typ_indexes_nil : typ_indexes = None, None, None, On_success false +let typ_indexes_union (i, e, d, b) (i', e', d', b') = + join_inv i i', + join_eloc e e', + join_disj d d', + On_success_union b b' let env = H.t A.ident' type_decl let create_env (_:unit) : ML env = H.create 100 @@ -59,31 +139,45 @@ let rec free_vars_of_expr (e:T.expr) | App _ args -> List.collect free_vars_of_expr args | Record _ args -> List.collect (fun (_, e) -> free_vars_of_expr e) args -let rec free_vars_of_inv (i:inv) +let map_index (def:'b) (f:'a -> ML 'b) (i:index 'a) : ML 'b = + match i with + | None -> def + | Some i -> f i + +let rec free_vars_of_inv' (i:inv) : ML (list A.ident) = match i with - | Inv_true -> [] - | Inv_conj i j -> free_vars_of_inv i @ free_vars_of_inv j - | Inv_ptr x -> [x] - | Inv_name _ args -> List.collect free_vars_of_expr args + | Inv_conj i j -> free_vars_of_inv' i @ free_vars_of_inv' j + | Inv_ptr x -> free_vars_of_expr x + | Inv_copy_buf x -> free_vars_of_expr x +let free_vars_of_inv = map_index [] free_vars_of_inv' -let rec free_vars_of_eloc (e:eloc) +let rec free_vars_of_eloc' (e:eloc) : ML (list A.ident) = match e with - | Eloc_none | Eloc_output -> [] - | Eloc_union i j -> free_vars_of_eloc i @ free_vars_of_eloc j - | Eloc_ptr x -> [x] - | Eloc_name _ args -> List.collect free_vars_of_expr args + | Eloc_union i j -> free_vars_of_eloc' i @ free_vars_of_eloc' j + | Eloc_ptr x -> free_vars_of_expr x + | Eloc_copy_buf x -> free_vars_of_expr x +let free_vars_of_eloc = map_index [] free_vars_of_eloc' -let free_vars_of_inv_eloc (i:inv_eloc) = - let i, j, _ = i in - free_vars_of_inv i @ free_vars_of_eloc j +let rec free_vars_of_disj' (d:disj) + : ML (list A.ident) + = match d with + | Disj_conj d0 d1 -> free_vars_of_disj' d0 @ free_vars_of_disj' d1 + | Disj_pair i j -> free_vars_of_eloc' i @ free_vars_of_eloc' j +let free_vars_of_disj = map_index [] free_vars_of_disj' + +let free_vars_of_typ_indexes (i:typ_indexes) = + let i, j, d, _ = i in + free_vars_of_inv i @ + free_vars_of_eloc j @ + free_vars_of_disj d let filter_args_for_inv (args:list expr) (td:type_decl) : ML (list expr) - = let fvs = free_vars_of_inv_eloc td.inv_eloc in + = let fvs = free_vars_of_typ_indexes td.typ_indexes in let args = List.map2 (fun (b, _) a -> @@ -152,6 +246,7 @@ let tag_of_parser p | Parse_impos -> "Parse_impos" | Parse_with_comment _ _ -> "Parse_with_comment" | Parse_string _ _ -> "Parse_string" + | Parse_with_probe _ _ _ _ -> "Parse_with_probe" let as_lam (x:T.lam 'a) : lam 'a @@ -162,60 +257,92 @@ let as_lam (x:T.lam 'a) in i, snd x -let rec inv_eloc_of_action (a:T.action) - : ML inv_eloc +let id_as_expr (i:A.ident) = T.mk_expr (T.Identifier i) + +let rec typ_indexes_of_action (a:T.action) + : ML typ_indexes = let open T in let of_atomic_action (a:T.atomic_action) - : ML inv_eloc + : ML typ_indexes = match a with | Action_return _ | Action_abort | Action_field_pos_32 - | Action_field_pos_64 -> inv_eloc_nil - | Action_field_ptr_after _ write_to -> Inv_ptr write_to, Eloc_ptr write_to, On_success false - | Action_field_ptr_after_with_setter _ _ _ -> Inv_true, Eloc_output, On_success false - | Action_field_ptr -> Inv_true, Eloc_none, On_success true - | Action_deref x -> Inv_ptr x, Eloc_none, On_success false - | Action_assignment x _ -> Inv_ptr x, Eloc_ptr x, On_success false - | Action_call f args -> Inv_true, Eloc_output, On_success false + | Action_field_pos_64 -> typ_indexes_nil + | Action_field_ptr_after _ write_to -> + Some (Inv_ptr (id_as_expr write_to)), + Some (Eloc_ptr (id_as_expr write_to)), + None, + On_success false + | Action_field_ptr_after_with_setter _ _ _ -> + None, + Some Eloc_output, + None, + On_success false + | Action_field_ptr -> + None, None, None, On_success true + | Action_deref x -> + Some (Inv_ptr (id_as_expr x)), None, None, On_success false + | Action_assignment x _ -> + Some (Inv_ptr (id_as_expr x)), + Some (Eloc_ptr (id_as_expr x)), + None, + On_success false + | Action_call f args -> + None, + Some Eloc_output, + None, + On_success false in match a with | Atomic_action aa -> of_atomic_action aa | Action_seq hd tl | Action_let _ hd tl -> - inv_eloc_union (of_atomic_action hd) (inv_eloc_of_action tl) + typ_indexes_union (of_atomic_action hd) (typ_indexes_of_action tl) | Action_ite _ a0 a1 -> - inv_eloc_union (inv_eloc_of_action a0) (inv_eloc_of_action a1) + typ_indexes_union (typ_indexes_of_action a0) (typ_indexes_of_action a1) | Action_act a -> - inv_eloc_of_action a + typ_indexes_of_action a -let rec inv_eloc_of_parser (en:env) (p:T.parser) - : ML inv_eloc - = let inv_eloc_of_parser = inv_eloc_of_parser en in +let rec typ_indexes_of_parser (en:env) (p:T.parser) + : ML typ_indexes + = let typ_indexes_of_parser = typ_indexes_of_parser en in match p.p_parser with | T.Parse_impos -> - inv_eloc_nil + typ_indexes_nil | T.Parse_app hd args -> let dt = dtyp_of_app en hd args in begin match dt with | DT_IType _ -> - inv_eloc_nil + typ_indexes_nil | DT_App _ hd args -> let td = match H.try_find en hd.v with | Some td -> td | _ -> failwith (Printf.sprintf "Type decl not found for %s" (A.ident_to_string hd)) in - inv_eloc_name hd (filter_args_for_inv args td) + let inv, eloc, disj, _ = td.typ_indexes in + let subst = + match T.mk_subst td.name.td_params args with + | None -> + failwith (Printf.sprintf "Unexpected number of arguments to type %s" (A.ident_to_string td.name.td_name)) + | Some s -> s + in + subst_inv subst inv, + subst_eloc subst eloc, + subst_disj subst disj, + On_success_named hd args end | T.Parse_if_else _ p q - | T.Parse_pair _ p q + | T.Parse_pair _ p q -> + typ_indexes_union (typ_indexes_of_parser p) (typ_indexes_of_parser q) + | T.Parse_dep_pair _ p (_, q) | T.Parse_dep_pair_with_refinement _ p _ (_, q) -> - inv_eloc_union (inv_eloc_of_parser p) (inv_eloc_of_parser q) + typ_indexes_union (typ_indexes_of_parser p) (typ_indexes_of_parser q) | T.Parse_weaken_left p _ | T.Parse_weaken_right p _ @@ -224,22 +351,42 @@ let rec inv_eloc_of_parser (en:env) (p:T.parser) | T.Parse_nlist _ p | T.Parse_t_at_most _ p | T.Parse_t_exact _ p -> - inv_eloc_of_parser p + typ_indexes_of_parser p | T.Parse_dep_pair_with_action p (_, a) (_, q) | T.Parse_dep_pair_with_refinement_and_action _ p _ (_, a) (_, q) -> - inv_eloc_union (inv_eloc_of_parser p) - (inv_eloc_union (inv_eloc_of_action a) (inv_eloc_of_parser q)) + typ_indexes_union + (typ_indexes_of_parser p) + (typ_indexes_union + (typ_indexes_of_action a) + (typ_indexes_of_parser q)) + + | T.Parse_with_action _ p a -> + typ_indexes_union + (typ_indexes_of_parser p) + (typ_indexes_of_action a) - | T.Parse_with_action _ p a | T.Parse_with_dep_action _ p (_, a) -> - inv_eloc_union (inv_eloc_of_parser p) (inv_eloc_of_action a) + typ_indexes_union + (typ_indexes_of_parser p) + (typ_indexes_of_action a) | T.Parse_string p _ -> - inv_eloc_nil + typ_indexes_nil | T.Parse_refinement_with_action n p f (_, a) -> - inv_eloc_union (inv_eloc_of_parser p) (inv_eloc_of_action a) + typ_indexes_union + (typ_indexes_of_parser p) + (typ_indexes_of_action a) + + | T.Parse_with_probe p _ _ dest -> + let i, l, d, s = typ_indexes_of_parser p in + typ_indexes_union + (i, l, d, s) + (Some (Inv_copy_buf (id_as_expr dest)), + Some (Eloc_copy_buf (id_as_expr dest)), + disj_pair (Some (Eloc_copy_buf (id_as_expr dest))) l, + On_success true) | T.Parse_map _ _ | T.Parse_return _ -> failwith "Unnecessary" @@ -261,7 +408,7 @@ let typ_of_parser (en: env) : Tot (T.parser -> ML typ) | _ -> failwith (Printf.sprintf "Expected a named type, got %s" - (T.print_parser "" p)) + (tag_of_parser p)) in let fn = nes p.p_fieldname in match p.p_parser with @@ -370,6 +517,10 @@ let typ_of_parser (en: env) : Tot (T.parser -> ML typ) | T.Parse_weaken_right p _ -> typ_of_parser p + | T.Parse_with_probe p probe_fn len dest -> + let d = dtyp_of_parser p in + T_probe_then_validate fn d probe_fn len dest + | T.Parse_map _ _ | T.Parse_return _ -> failwith "Unnecessary" @@ -391,6 +542,39 @@ let rec allow_reading_of_typ (t:typ) | _ -> false +let check_validity_of_typ_indexes (td:T.type_decl) indexes = + let rec atomic_locs_of l = + match l with + | Eloc_output -> [l] + | Eloc_union l1 l2 -> atomic_locs_of l1 @ atomic_locs_of l2 + | Eloc_ptr _ -> [l] + | Eloc_copy_buf _ -> [l] + in + let rec valid_disj (d:disj) : ML unit = + match d with + | Disj_conj d1 d2 -> + valid_disj d1; + valid_disj d2 + + | Disj_pair (Eloc_copy_buf (T.Identifier x, rx)) l2 -> + let l2_locs = atomic_locs_of l2 in + if List.existsb + (function + | Eloc_copy_buf (T.Identifier y, ry) -> A.eq_idents x y + | _ -> false) + l2_locs + then ( + A.error (Printf.sprintf "Nested mutation of the copy buffer [%s]" (T.print_ident x)) + td.decl_name.td_name.range + ) + else () + + in + let _, _, disj, _ = indexes in + match disj with + | None -> () + | Some disj -> valid_disj disj + let translate_decls (en:env) (ds:T.decls) : ML (list decl) = List.map @@ -409,11 +593,13 @@ let translate_decls (en:env) (ds:T.decls) | _ -> None else None in + let typ_indexes = typ_indexes_of_parser en td.decl_parser in + check_validity_of_typ_indexes td typ_indexes; let td = { name = td.decl_name; typ = typ_of_parser en td.decl_parser; kind = td.decl_parser.p_kind; - inv_eloc = inv_eloc_of_parser en td.decl_parser; + typ_indexes; allow_reading = ar; attrs = attrs; enum_typ = refined @@ -637,6 +823,14 @@ let rec print_typ (mname:string) (t:typ) (print_dtyp mname d) (T.print_expr mname z) + | T_probe_then_validate fn dt probe_fn len dest -> + Printf.sprintf "(t_probe_then_validate \"%s\" %s %s %s %s)" + fn + (T.print_maybe_qualified_ident mname probe_fn) + (T.print_expr mname len) + (T.print_maybe_qualified_ident mname dest) + (print_dtyp mname dt) + let print_param mname (p:T.param) = Printf.sprintf "(%s:%s)" (print_ident mname (fst p)) @@ -651,31 +845,43 @@ let print_type_decl mname (td:type_decl) = FStar.Printf.sprintf "[@@specialize; noextract_to \"krml\"]\n\ noextract\n\ - let def_%s = ( %s <: Tot (typ _ _ _ _) by (T.norm [delta_attr [`%%specialize]; zeta; iota; primops]; T.smt()))\n" + let def_%s = ( %s <: Tot (typ _ _ _ _ _) by (T.norm [delta_attr [`%%specialize]; zeta; iota; primops]; T.smt()))\n" (print_typedef_name mname td.name) (print_typ mname td.typ) let print_args mname (es:list expr) = List.map (T.print_expr mname) es |> String.concat " " -let rec print_inv mname (i:inv) +let print_index (f: 'a -> ML string) (i:index 'a) + : ML string + = map_index "Trivial" (fun s -> Printf.sprintf "(NonTrivial %s)" (f s)) i + +let rec print_inv' mname (i:inv) : ML string = match i with - | Inv_true -> "A.true_inv" - | Inv_conj i j -> Printf.sprintf "(A.conj_inv %s %s)" (print_inv mname i) (print_inv mname j) - | Inv_ptr x -> Printf.sprintf "(A.ptr_inv %s)" (print_ident mname x) - | Inv_name hd args -> Printf.sprintf "(%s %s)" (print_derived_name mname "inv" hd) (print_args mname args) + | Inv_conj i j -> Printf.sprintf "(A.conj_inv %s %s)" (print_inv' mname i) (print_inv' mname j) + | Inv_ptr x -> Printf.sprintf "(A.ptr_inv %s)" (T.print_expr mname x) + | Inv_copy_buf x -> Printf.sprintf "(A.copy_buffer_inv %s)" (T.print_expr mname x) +let print_inv mname = print_index (print_inv' mname) -let rec print_eloc mname (e:eloc) +let rec print_eloc' mname (e:eloc) : ML string = match e with - | Eloc_none -> "A.eloc_none" | Eloc_output -> "output_loc" //This is a bit sketchy - | Eloc_union i j -> Printf.sprintf "(A.eloc_union %s %s)" (print_eloc mname i) (print_eloc mname j) - | Eloc_ptr x -> Printf.sprintf "(A.ptr_loc %s)" (print_ident mname x) - | Eloc_name hd args -> Printf.sprintf "(%s %s)" (print_derived_name mname "eloc" hd) (print_args mname args) + | Eloc_union i j -> Printf.sprintf "(A.eloc_union %s %s)" (print_eloc' mname i) (print_eloc' mname j) + | Eloc_ptr x -> Printf.sprintf "(A.ptr_loc %s)" (T.print_expr mname x) + | Eloc_copy_buf x -> Printf.sprintf "(A.copy_buffer_loc %s)" (T.print_expr mname x) +let print_eloc mname = print_index (print_eloc' mname) + +let rec print_disj' mname (d:disj) + : ML string + = match d with + | Disj_pair i j -> Printf.sprintf "(A.disjoint %s %s)" (print_eloc' mname i) (print_eloc' mname j) + | Disj_conj i j -> Printf.sprintf "(join_disj %s %s)" (print_disj' mname i) (print_disj' mname j) +let print_disj mname = print_index (print_disj' mname) -let print_td_iface is_entrypoint mname root_name binders args inv_eloc_binders inv_eloc_args ar pk_wk pk_nz = +let print_td_iface is_entrypoint mname root_name binders args + inv eloc disj ar pk_wk pk_nz = let kind_t = Printf.sprintf "[@@noextract_to \"krml\"]\n\ inline_for_extraction\n\ @@ -685,29 +891,14 @@ let print_td_iface is_entrypoint mname root_name binders args inv_eloc_binders i pk_nz pk_wk in - let inv_t = - Printf.sprintf "[@@noextract_to \"krml\"]\n\ - noextract\n\ - val inv_%s %s : A.slice_inv" - root_name - inv_eloc_binders - in - let eloc_t = - Printf.sprintf "[@@noextract_to \"krml\"]\n\ - noextract\n\ - val eloc_%s %s : A.eloc" - root_name - inv_eloc_binders - in let def'_t = Printf.sprintf "[@@noextract_to \"krml\"]\n\ noextract\n\ - val def'_%s %s: typ kind_%s (inv_%s %s) (eloc_%s %s) %b" + val def'_%s %s: typ kind_%s %s %s %s %b" root_name binders root_name - root_name inv_eloc_args - root_name inv_eloc_args + inv disj eloc ar in let validator_t = @@ -725,198 +916,160 @@ let print_td_iface is_entrypoint mname root_name binders args inv_eloc_binders i binders root_name args in - String.concat "\n\n" [kind_t; inv_t; eloc_t; def'_t; validator_t; dtyp_t] + String.concat "\n\n" [kind_t; def'_t; validator_t; dtyp_t] + +let print_binders mname binders = + List.map (print_param mname) binders |> + String.concat " " + +let print_binders_as_args mname binders = + List.map (fun (i, _) -> print_ident mname i) binders |> + String.concat " " let print_binding mname (td:type_decl) - : ML (string & string) - = let tdn = td.name in - let typ = td.typ in - let k = td.kind in - let root_name = print_ident mname tdn.td_name in - let print_binders binders = - List.map (print_param mname) binders |> - String.concat " " +: ML (string & string) += let tdn = td.name in + let k = td.kind in + let typ = td.typ in + let root_name = print_ident mname tdn.td_name in + let print_binders = print_binders mname in + let print_args = print_binders_as_args mname in + let binders = print_binders tdn.td_params in + let args = print_args tdn.td_params in + let def = print_type_decl mname td in + let weak_kind = A.print_weak_kind k.pk_weak_kind in + let pk_of_binding = + Printf.sprintf "[@@noextract_to \"krml\"]\n\ + inline_for_extraction noextract\n\ + let kind_%s : P.parser_kind %s %s = coerce (_ by (T.norm [delta_only [`%%weak_kind_glb]; zeta; iota; primops]; T.trefl())) %s\n" + root_name + (string_of_bool k.pk_nz) + weak_kind + (T.print_kind mname k) + in + let inv, eloc, disj = + let inv, eloc, disj, _ = td.typ_indexes in + print_inv mname inv, + print_eloc mname eloc, + print_disj mname disj + in + let def' = + Printf.sprintf + "[@@specialize; noextract_to \"krml\"]\n\ + noextract\n\ + let def'_%s %s\n\ + : typ kind_%s %s %s %s %s\n\ + = coerce (_ by (coerce_validator [`%%kind_%s])) (def_%s %s)" + root_name + binders + root_name + inv disj eloc + (string_of_bool td.allow_reading) + root_name + root_name + args + in + let as_type_or_parser tag = + Printf.sprintf "[@@noextract_to \"krml\"]\n\ + noextract\n + let %s_%s %s = (as_%s (def'_%s %s))" + tag + root_name + binders + tag + root_name + args + in + let validate_binding = + let cinline = + if td.name.td_entrypoint + || td.attrs.is_exported + then "" + else "; CInline" in - let print_args binders = - List.map (fun (i, _) -> print_ident mname i) binders |> - String.concat " " + Printf.sprintf "[@@normalize_for_extraction specialization_steps%s]\n\ + let validate_%s %s = as_validator \"%s\" (def'_%s %s)\n" + cinline + root_name + binders + root_name + root_name + args + in + let dtyp : string = + let reader = + if td.allow_reading + then Printf.sprintf "(Some (as_reader (def_%s %s)))" + root_name + args + else "None" in - let binders = print_binders tdn.td_params in - let args = print_args tdn.td_params in - let def = print_type_decl mname td in - let weak_kind = A.print_weak_kind k.pk_weak_kind in - let pk_of_binding = - Printf.sprintf "[@@noextract_to \"krml\"]\n\ - inline_for_extraction noextract\n\ - let kind_%s : P.parser_kind %b %s = coerce (_ by (T.norm [delta_only [`%%weak_kind_glb]; zeta; iota; primops]; T.trefl())) %s\n" - root_name - k.pk_nz - weak_kind - (T.print_kind mname k) + let coerce_validator = + Printf.sprintf "(T.norm [delta_only [`%%parser_%s; `%%type_%s; `%%coerce]]; T.trefl())" + root_name + root_name in - let print_inv_or_eloc tag ty defn fvs - : ML (string & string & string) - = let fv_binders = - List.filter - (fun (i, _) -> - Some? (List.tryFind (fun j -> A.ident_name i = A.ident_name j) fvs)) - tdn.td_params - in - let fv_binders_string = print_binders fv_binders in - let fv_args_string = print_args fv_binders in - let f = - match fv_binders with - | [] -> - defn - | _ -> - Printf.sprintf "(fun %s -> %s)" - fv_binders_string - defn - in - let s0 = Printf.sprintf "[@@noextract_to \"krml\"]\n\ - noextract\n\ - let %s_%s = %s\n" - tag root_name f - in - let body = - let body = - Printf.sprintf "%s_%s %s" tag root_name fv_args_string - in - match tdn.td_params with - | [] -> body - | _ -> Printf.sprintf "(fun %s -> %s)" binders body - in - s0, fv_binders_string, fv_args_string - in - let inv_eloc_of_binding, fv_binders, fv_args = - let inv, eloc, _ = td.inv_eloc in - let fvs1 = free_vars_of_inv inv in - let fvs2 = free_vars_of_eloc eloc in - let s0, _, _ = print_inv_or_eloc "inv" "A.slice_inv" (print_inv mname inv) (fvs1@fvs2) in - let s1, fv_binders, fv_args = print_inv_or_eloc "eloc" "A.eloc" (print_eloc mname eloc) (fvs1@fvs2) in - s0 ^ s1, fv_binders, fv_args - in - - let def' = - FStar.Printf.sprintf - "[@@specialize; noextract_to \"krml\"]\n\ - noextract\n\ - let def'_%s %s\n\ - : typ kind_%s (inv_%s %s) (eloc_%s %s) %b\n\ - = coerce (_ by (coerce_validator [`%%kind_%s; `%%inv_%s; `%%eloc_%s])) (def_%s %s)" - root_name - binders - root_name - root_name fv_args - root_name fv_args - td.allow_reading - root_name - root_name - root_name - root_name - args - in - let as_type_or_parser tag = - Printf.sprintf "[@@noextract_to \"krml\"]\n\ - noextract\n - let %s_%s %s = (as_%s (def'_%s %s))" - tag - root_name - binders - tag - root_name - args - in - let validate_binding = - let cinline = - if td.name.td_entrypoint - || td.attrs.is_exported - then "" - else "; CInline" - in - FStar.Printf.sprintf "[@@normalize_for_extraction specialization_steps%s]\n\ - let validate_%s %s = as_validator \"%s\" (def'_%s %s)\n" - cinline - root_name - binders - root_name - root_name - args - in - let dtyp : string = - let reader = - if td.allow_reading - then Printf.sprintf "(Some (as_reader (def_%s %s)))" - root_name - args - else "None" - in - let coerce_validator = - Printf.sprintf "(T.norm [delta_only [`%%parser_%s; `%%type_%s; `%%coerce]]; T.trefl())" - root_name - root_name - in - Printf.sprintf "[@@specialize; noextract_to \"krml\"]\n\ - noextract\n\ - let dtyp_%s %s\n\ - : dtyp kind_%s %b (inv_%s %s) (eloc_%s %s)\n\ - = mk_dtyp_app\n\ - kind_%s\n - (inv_%s %s)\n - (eloc_%s %s)\n - (type_%s %s)\n\ - (coerce (_ by (T.norm [delta_only [`%%type_%s]]; T.trefl())) (parser_%s %s))\n\ - %s\n\ - %b\n\ - (coerce (_ by %s) (validate_%s %s))\n\ - (_ by (T.norm [delta_only [`%%Some?]; iota]; T.trefl()))\n" - root_name binders - root_name td.allow_reading root_name fv_args root_name fv_args - root_name - root_name fv_args - root_name fv_args - root_name args - root_name - root_name args - reader - td.allow_reading - coerce_validator root_name args - in - let enum_typ_of_binding = - match td.enum_typ with - | None -> "" - | Some t -> - Printf.sprintf "let %s = %s\n" + Printf.sprintf "[@@specialize; noextract_to \"krml\"]\n\ + noextract\n\ + let dtyp_%s %s\n\ + : dtyp kind_%s %b %s %s %s\n\ + = mk_dtyp_app\n\ + kind_%s\n\ + %s\n\ + %s\n\ + %s\n\ + (type_%s %s)\n\ + (coerce (_ by (T.norm [delta_only [`%%type_%s]]; T.trefl())) (parser_%s %s))\n\ + %s\n\ + %b\n\ + (coerce (_ by %s) (validate_%s %s))\n\ + (_ by (T.norm [delta_only [`%%Some?]; iota]; T.trefl()))\n" + root_name binders + root_name td.allow_reading + inv disj eloc + root_name + inv disj eloc + root_name args + root_name + root_name args + reader + td.allow_reading + coerce_validator root_name args + in + let enum_typ_of_binding = + match td.enum_typ with + | None -> "" + | Some t -> + Printf.sprintf "let %s = %s\n" root_name (T.print_typ mname t) - in - let impl = - String.concat "\n" - [def; - pk_of_binding; - inv_eloc_of_binding; - def'; - (as_type_or_parser "type"); - (as_type_or_parser "parser"); - validate_binding; - dtyp; - enum_typ_of_binding] - in - // impl, "" - if Some? td.enum_typ - && (td.name.td_entrypoint || td.attrs.is_exported) - then "", impl //exported enums are fully revealed - else if td.name.td_entrypoint - || td.attrs.is_exported - then - let iface = - print_td_iface td.name.td_entrypoint - mname root_name binders args - fv_binders fv_args td.allow_reading - weak_kind k.pk_nz - in - impl, iface - else impl, "" + in + let impl = + String.concat "\n" + [def; + pk_of_binding; + def'; + (as_type_or_parser "type"); + (as_type_or_parser "parser"); + validate_binding; + dtyp; + enum_typ_of_binding] + in + // impl, "" + if Some? td.enum_typ + && (td.name.td_entrypoint || td.attrs.is_exported) + then "", impl //exported enums are fully revealed + else if td.name.td_entrypoint + || td.attrs.is_exported + then + let iface = + print_td_iface td.name.td_entrypoint + mname root_name binders args + inv eloc disj td.allow_reading + weak_kind k.pk_nz + in + impl, iface + else impl, "" let print_decl mname (d:decl) : ML (string & string) = diff --git a/src/3d/InterpreterTarget.fsti b/src/3d/InterpreterTarget.fsti index 242c4c52e..c6d916b41 100644 --- a/src/3d/InterpreterTarget.fsti +++ b/src/3d/InterpreterTarget.fsti @@ -174,13 +174,21 @@ type typ : Type = terminator:expr -> typ -val inv_eloc : Type0 + | T_probe_then_validate: + fn:non_empty_string -> + t:dtyp -> + probe:A.ident -> + len:expr -> + dest:A.ident -> + typ + +val typ_indexes : Type0 noeq type type_decl = { name : T.typedef_name; typ : typ; kind : T.parser_kind; - inv_eloc : inv_eloc; + typ_indexes : typ_indexes; allow_reading: bool; attrs : T.decl_attributes; enum_typ: option (t:T.typ {T.T_refine? t }) diff --git a/src/3d/Main.fst b/src/3d/Main.fst index 52b848d4b..e8341b8e5 100644 --- a/src/3d/Main.fst +++ b/src/3d/Main.fst @@ -118,7 +118,7 @@ let parse_check_and_desugar (pa: opt_prune_actions) (en:env) (mname:string) (fn: let translate_module (pa: opt_prune_actions) (en:env) (mname:string) (fn:string) : ML (list Target.decl & - option (list InterpreterTarget.decl) & + list InterpreterTarget.decl & StaticAssertions.static_asserts & env) = @@ -132,7 +132,7 @@ let translate_module (pa: opt_prune_actions) (en:env) (mname:string) (fn:string) TranslateForInterpreter.translate_decls en.binding_env en.typesizes_env env decls in let tds = InterpreterTarget.translate_decls env' decls in - decls, Some tds, (env, env') + decls, tds, (env, env') in let en = { en with translate_env = tenv } in t_decls, @@ -140,18 +140,6 @@ let translate_module (pa: opt_prune_actions) (en:env) (mname:string) (fn:string) static_asserts, en -let has_output_types (t_decls:list Target.decl) : bool = - List.Tot.existsb (fun (d, _) -> Target.Output_type? d) t_decls - -let has_out_exprs (t_decls:list Target.decl) : bool = - List.Tot.existsb (fun (d, _) -> Target.Output_type_expr? d) t_decls - -let has_extern_types (t_decls:list Target.decl) : bool = - List.Tot.existsb (fun (d, _) -> Target.Extern_type? d) t_decls - -let has_extern_functions (t_decls:list Target.decl) : bool = - List.Tot.existsb (fun (d, _) -> Target.Extern_fn? d) t_decls - let emit_fstar_code_for_interpreter (en:env) (modul:string) (tds:list T.decl) @@ -164,7 +152,7 @@ let emit_fstar_code_for_interpreter (en:env) InterpreterTarget.print_decls en modul itds in - let has_external_types = has_output_types tds || has_extern_types tds in + let has_external_types = T.has_output_types tds || T.has_extern_types tds in if has_external_types then begin @@ -175,10 +163,7 @@ let emit_fstar_code_for_interpreter (en:env) FStar.IO.close_write_file external_types_fsti_file end; - let has_external_api = - has_out_exprs tds || - has_extern_types tds || // FIXME: I added this to fix discrepancy with GenMakefile, does this make sense? - has_extern_functions tds in + let has_external_api = T.has_external_api tds in if has_external_api then begin @@ -263,11 +248,10 @@ let emit_entrypoint (produce_ep_error: Target.opt_produce_everparse_error) FStar.IO.close_write_file h_file end; - let has_output_types = has_output_types t_decls in - let has_out_exprs = has_out_exprs t_decls in - let has_extern_types = has_extern_types t_decls in - let has_extern_fns = has_extern_functions t_decls in - + let has_output_types = T.has_output_types t_decls in + let has_out_exprs = T.has_output_type_exprs t_decls in + let has_extern_types = T.has_extern_types t_decls in + (* * If there are output types in the module * and emit_output_types_defs flag is set, @@ -366,19 +350,14 @@ let process_file_gen (emit_fstar:bool) (emit_output_types_defs:bool) (all_modules:list string) - : ML (env & option (list InterpreterTarget.decl)) = + : ML (env & list InterpreterTarget.decl) = - let t_decls, interpreter_decls_opt, static_asserts, en = + let t_decls, interpreter_decls, static_asserts, en = translate_module pa en modul fn in if emit_fstar then ( - ( - match interpreter_decls_opt with - | None -> failwith "Impossible: interpreter mode expects interperter target decls" - | Some tds -> - emit_fstar_code_for_interpreter en modul t_decls tds all_modules - ); + emit_fstar_code_for_interpreter en modul t_decls interpreter_decls all_modules; emit_entrypoint produce_ep_error en modul t_decls static_asserts emit_output_types_defs ) else IO.print_string (Printf.sprintf "Not emitting F* code for %s\n" fn); @@ -390,7 +369,7 @@ let process_file_gen binding_env = Binding.finish_module en.binding_env modul; translate_env = en.translate_env; - }, interpreter_decls_opt + }, interpreter_decls let process_file (en:env) @@ -462,11 +441,8 @@ let process_file_for_z3 (all_modules:list string) : ML (env & Z3TestGen.prog) = let (en, accu) = en_accu in - let (en, interpreter_decls_opt) = process_file_gen (Some Target.ProduceEverParseError) (Some PruneActions) en fn modul emit_fstar emit_output_types_defs all_modules in - let accu = match interpreter_decls_opt with - | None -> failwith "process_file_for_z3: no interpreter decls left" - | Some i -> Z3TestGen.produce_decls out accu i - in + let (en, interpreter_decls) = process_file_gen (Some Target.ProduceEverParseError) (Some PruneActions) en fn modul emit_fstar emit_output_types_defs all_modules in + let accu = Z3TestGen.produce_decls out accu interpreter_decls in (en, accu) let process_files_for_z3 diff --git a/src/3d/Makefile b/src/3d/Makefile index 12b6977df..421d985b5 100644 --- a/src/3d/Makefile +++ b/src/3d/Makefile @@ -39,7 +39,7 @@ Version.fst: env EVERPARSE_HOME=$(EVERPARSE_HOME) ./version.sh .depend: $(wildcard *.fst *.fsti) Version.fst - $(FSTAR) --odir ocaml/generated --dep full $(ROOT) --extract '* -Prims -FStar' > .depend + $(FSTAR) --odir ocaml/generated --dep full $(ROOT) --extract '* -Prims -FStar' --output_deps_to .depend include .depend diff --git a/src/3d/OS.fsti b/src/3d/OS.fsti index 3567826a0..646bbe9df 100644 --- a/src/3d/OS.fsti +++ b/src/3d/OS.fsti @@ -31,4 +31,4 @@ val write_witness_to_file: list int -> string -> FStar.All.ML unit (* Moved here to break dependency cycle *) -val int_of_string (x:string) : FStar.All.ML int +val int_of_string (x:string) : FStar.All.ML int \ No newline at end of file diff --git a/src/3d/Simplify.fst b/src/3d/Simplify.fst index 615926f5b..b84cc5cb6 100644 --- a/src/3d/Simplify.fst +++ b/src/3d/Simplify.fst @@ -191,6 +191,8 @@ let simplify_decl (env:T.env_t) (d:decl) : ML decl = let ret = simplify_typ env ret in let params = List.map (fun (t, i, q) -> simplify_typ env t, i, q) params in decl_with_v d (ExternFn f ret params) + + | ExternProbe _ -> d let simplify_prog benv senv (p:list decl) = diff --git a/src/3d/Target.fst b/src/3d/Target.fst index 344b0b624..3550800dc 100644 --- a/src/3d/Target.fst +++ b/src/3d/Target.fst @@ -19,6 +19,33 @@ open FStar.All module A = Ast open Binding +let lookup (s:subst) (i:A.ident) : option expr = + List.Tot.assoc i.v s + +let rec subst_expr (s:subst) (e:expr) +: expr += match fst e with + | Constant _ -> e + | Identifier i -> ( + match lookup s i with + | Some e' -> e' + | None -> e + ) + | App hd args -> ( + App hd (subst_exprs s args), snd e + ) + | Record tn fields -> ( + Record tn (subst_fields s fields), snd e + ) +and subst_exprs s es = + match es with + | [] -> [] + | e::es -> subst_expr s e :: subst_exprs s es +and subst_fields s fs = + match fs with + | [] -> [] + | (i, e)::fs -> (i, subst_expr s e)::subst_fields s fs + let rec expr_eq e1 e2 = match fst e1, fst e2 with | Constant c1, Constant c2 -> c1=c2 @@ -53,6 +80,26 @@ let rec parser_kind_eq k k' = && parser_kind_eq k2 k2' | _ -> false +let has_output_types (ds:list decl) : bool = + List.Tot.existsb (fun (d, _) -> Output_type? d) ds + +let has_output_type_exprs (ds:list decl) : bool = + List.Tot.existsb (fun (d, _) -> Output_type_expr? d) ds + +let has_extern_types (ds:list decl) : bool = + List.Tot.existsb (fun (d, _) -> Extern_type? d) ds + +let has_extern_functions (ds:list decl) : bool = + List.Tot.existsb (fun (d, _) -> Extern_fn? d) ds + +let has_extern_probes (ds:list decl) : bool = + List.Tot.existsb (fun (d, _) -> Extern_probe? d) ds + +let has_external_api (ds:list decl) : bool = + has_output_type_exprs ds + || has_extern_types ds + || has_extern_functions ds + || has_extern_probes ds // Some constants let default_attrs = { @@ -379,6 +426,7 @@ let rec print_typ (mname:string) (t:typ) : ML string = //(decreases t) = | T_with_action t _ | T_with_dep_action t _ | T_with_comment t _ -> print_typ mname t + | T_with_probe t _ _ _ -> Printf.sprintf "bpointer (%s)" (print_typ mname t) and print_indexes (mname:string) (is:list index) : ML (list string) = //(decreases is) = match is with @@ -416,68 +464,6 @@ let rec print_kind (mname:string) (k:parser_kind) : Tot string = | PK_string -> "parse_string_kind" -let rec print_parser (mname:string) (p:parser) : ML string = //(decreases p) = - match p.p_parser with - | Parse_return v -> - Printf.sprintf "(parse_ret %s)" (print_expr mname v) - | Parse_app hd args -> - Printf.sprintf "(%sparse_%s %s)" (maybe_mname_prefix mname hd) (print_ident hd) (String.concat " " (print_indexes mname args)) - | Parse_nlist e p -> - Printf.sprintf "(parse_nlist %s %s)" (print_expr mname e) (print_parser mname p) - | Parse_t_at_most e p -> - Printf.sprintf "(parse_t_at_most %s %s)" (print_expr mname e) (print_parser mname p) - | Parse_t_exact e p -> - Printf.sprintf "(parse_t_exact %s %s)" (print_expr mname e) (print_parser mname p) - | Parse_pair _ p1 p2 -> - Printf.sprintf "(%s `parse_pair` %s)" (print_parser mname p1) (print_parser mname p2) - | Parse_dep_pair _ p1 p2 - | Parse_dep_pair_with_action p1 _ p2 -> - Printf.sprintf "(%s `parse_dep_pair` %s)" - (print_parser mname p1) - (print_lam (print_parser mname) p2) - | Parse_dep_pair_with_refinement _ p1 e p2 - | Parse_dep_pair_with_refinement_and_action _ p1 e _ p2 -> - Printf.sprintf "((%s `parse_filter` %s) `parse_dep_pair` %s)" - (print_parser mname p1) - (print_expr_lam mname e) - (print_lam (print_parser mname) p2) - | Parse_map p1 e -> - Printf.sprintf "(%s `parse_map` %s)" - (print_parser mname p1) - (print_expr_lam mname e) - | Parse_refinement _ p1 e - | Parse_refinement_with_action _ p1 e _ -> - Printf.sprintf "(%s `parse_filter` %s)" - (print_parser mname p1) - (print_expr_lam mname e) - | Parse_weaken_left p1 k -> - Printf.sprintf "(parse_weaken_left %s %s)" (print_parser mname p1) (print_kind mname k) - | Parse_weaken_right p1 k -> - Printf.sprintf "(parse_weaken_right %s %s)" (print_parser mname p1) (print_kind mname k) - | Parse_if_else e p1 p2 -> - Printf.sprintf "(parse_ite %s (fun _ -> %s) (fun _ -> %s))" - (print_expr mname e) - (print_parser mname p1) - (print_parser mname p2) - | Parse_impos -> "(parse_impos())" - | Parse_with_dep_action _ p _ - | Parse_with_action _ p _ - | Parse_with_comment p _ -> print_parser mname p - | Parse_string elem zero -> - Printf.sprintf "(parse_string %s %s)" (print_parser mname elem) (print_expr mname zero) - -let rec print_reader (mname:string) (r:reader) : ML string = - match r with - | Read_u8 -> "read____UINT8" - | Read_u16 -> "read____UINT16" - | Read_u32 -> "read____UINT32" - | Read_app hd args -> - Printf.sprintf "(%sread_%s %s)" (maybe_mname_prefix mname hd) (print_ident hd) (String.concat " " (print_indexes mname args)) - | Read_filter r f -> - Printf.sprintf "(read_filter %s %s)" - (print_reader mname r) - (print_expr_lam mname f) - let rec print_action (mname:string) (a:action) : ML string = let print_atomic_action (a:atomic_action) : ML string @@ -500,7 +486,7 @@ let rec print_action (mname:string) (a:action) : ML string = | Action_assignment lhs rhs -> Printf.sprintf "(action_assignment %s %s)" (print_ident lhs) (print_expr mname rhs) | Action_call f args -> - Printf.sprintf "(mk_external_action (%s %s))" (print_ident f) (String.concat " " (List.map (print_expr mname) args)) + Printf.sprintf "(mk_extern_action (%s %s))" (print_ident f) (String.concat " " (List.map (print_expr mname) args)) in match a with | Atomic_action a -> @@ -524,164 +510,6 @@ let rec print_action (mname:string) (a:action) : ML string = Printf.sprintf "(action_act %s)" (print_action mname a) -let rec print_validator (mname:string) (v:validator) : ML string = //(decreases v) = - let is_unit_validator v = - let open A in - match v.v_validator with - | Validate_app ({v={name="unit"}}) [] -> true - | _ -> false - in - match v.v_validator with - | Validate_return -> - "validate_ret" - - | Validate_app hd args -> - Printf.sprintf "(validate_eta (%svalidate_%s %s))" - (maybe_mname_prefix mname hd) - (print_ident hd) - (String.concat " " (print_indexes mname args)) - - | Validate_nlist e p -> - Printf.sprintf "(validate_nlist %s %s)" - (print_expr mname e) - (print_validator mname p) - - | Validate_t_at_most e p -> - Printf.sprintf "(validate_t_at_most %s %s)" - (print_expr mname e) - (print_validator mname p) - - | Validate_t_exact e p -> - Printf.sprintf "(validate_t_exact %s %s)" - (print_expr mname e) - (print_validator mname p) - - | Validate_nlist_constant_size_without_actions e p -> - let n_is_const = match fst e with - | Constant (A.Int _ _) -> true - | _ -> false - in - Printf.sprintf "(validate_nlist_constant_size_without_actions %s %s %s)" - (if n_is_const then "true" else "false") - (print_expr mname e) - (print_validator mname p) - - | Validate_pair n1 p1 p2 -> - Printf.sprintf "(validate_pair \"%s\" %s %s)" - (print_maybe_qualified_ident mname n1) - (print_validator mname p1) - (print_validator mname p2) - - | Validate_dep_pair n1 p1 r p2 -> - Printf.sprintf "(validate_dep_pair \"%s\" %s %s %s)" - (print_ident n1) - (print_validator mname p1) - (print_reader mname r) - (print_lam (print_validator mname) p2) - - | Validate_dep_pair_with_refinement p1_is_constant_size_without_actions n1 p1 r e p2 -> - Printf.sprintf "(validate_dep_pair_with_refinement %s \"%s\" %s %s %s %s)" - (if p1_is_constant_size_without_actions then "true" else "false") - (print_maybe_qualified_ident mname n1) - (print_validator mname p1) - (print_reader mname r) - (print_expr_lam mname e) - (print_lam (print_validator mname) p2) - - | Validate_dep_pair_with_action p1 r a p2 -> - Printf.sprintf "(validate_dep_pair_with_action %s %s %s %s)" - (print_validator mname p1) - (print_reader mname r) - (print_lam (print_action mname) a) - (print_lam (print_validator mname) p2) - - | Validate_dep_pair_with_refinement_and_action p1_is_constant_size_without_actions n1 p1 r e a p2 -> - Printf.sprintf "(validate_dep_pair_with_refinement_and_action %s \"%s\" %s %s %s %s %s)" - (if p1_is_constant_size_without_actions then "true" else "false") - (print_maybe_qualified_ident mname n1) - (print_validator mname p1) - (print_reader mname r) - (print_expr_lam mname e) - (print_lam (print_action mname) a) - (print_lam (print_validator mname) p2) - - | Validate_map p1 e -> - Printf.sprintf "(%s `validate_map` %s)" - (print_validator mname p1) - (print_expr_lam mname e) - - | Validate_refinement n1 p1 r e -> - begin - if is_unit_validator p1 - then Printf.sprintf "(validate_unit_refinement %s \"checking precondition\")" - (print_expr_lam mname e) - else Printf.sprintf "(validate_filter \"%s\" %s %s %s - \"reading field value\" \"checking constraint\")" - (print_maybe_qualified_ident mname n1) - (print_validator mname p1) - (print_reader mname r) - (print_expr_lam mname e) - end - - | Validate_refinement_with_action n1 p1 r e a -> - Printf.sprintf "(validate_filter_with_action \"%s\" %s %s %s - \"reading field value\" \"checking constraint\" - %s)" - (print_maybe_qualified_ident mname n1) - (print_validator mname p1) - (print_reader mname r) - (print_expr_lam mname e) - (print_lam (print_action mname) a) - - | Validate_with_action name v a -> - Printf.sprintf "(validate_with_success_action \"%s\" %s %s)" - (print_maybe_qualified_ident mname name) - (print_validator mname v) - (print_action mname a) - - | Validate_with_dep_action n v r a -> - Printf.sprintf "(validate_with_dep_action \"%s\" %s %s %s)" - (print_maybe_qualified_ident mname n) - (print_validator mname v) - (print_reader mname r) - (print_lam (print_action mname) a) - - | Validate_weaken_left p1 k -> - Printf.sprintf "(validate_weaken_left %s _)" - (print_validator mname p1) - - | Validate_weaken_right p1 k -> - Printf.sprintf "(validate_weaken_right %s _)" - (print_validator mname p1) - - | Validate_if_else e v1 v2 -> - Printf.sprintf "(validate_ite %s (fun _ -> %s) (fun _ -> %s) (fun _ -> %s) (fun _ -> %s))" - (print_expr mname e) - (print_parser mname v1.v_parser) - (print_validator mname v1) - (print_parser mname v2.v_parser) - (print_validator mname v2) - - | Validate_impos -> - "(validate_impos())" - - | Validate_with_error_handler typename fieldname v -> - Printf.sprintf "(validate_with_error_handler \"%s\" \"%s\" %s)" - (print_maybe_qualified_ident mname typename) - fieldname - (print_validator mname v) - - | Validate_with_comment v c -> - let c = String.concat "\n" c in - Printf.sprintf "(validate_with_comment \"%s\" %s)" - c - (print_validator mname v) - - | Validate_string velem relem zero -> - Printf.sprintf "(validate_string %s %s %s)" - (print_validator mname velem) - (print_reader mname relem) - (print_expr mname zero) let print_typedef_name (mname:string) (tdn:typedef_name) : ML string = Printf.sprintf "%s %s" @@ -837,7 +665,9 @@ let print_decl_for_types (mname:string) (d:decl) : ML string = | Extern_type _ - | Extern_fn _ _ _ -> "" + | Extern_fn _ _ _ + + | Extern_probe _ -> "" /// Print a decl for M.fst /// @@ -852,185 +682,12 @@ let is_type_abbreviation (td:type_decl) : bool = | TD_abbrev _ -> true | TD_struct _ -> false -let print_decl_for_validators (mname:string) (d:decl) : ML string = - match fst d with - | Definition _ -> "" - - | Assumption _ -> - print_assumption mname d - - | Type_decl td -> - (if false //not td.decl_name.td_entrypoint - then "" - else if is_type_abbreviation td - then "" - else Printf.sprintf "noextract\ninline_for_extraction\nlet %s = %s.Types.%s (* from corresponding Types.fst *)\n\n" - (print_typedef_name mname td.decl_name) - mname - (print_typedef_typ td.decl_name)) - `strcat` - Printf.sprintf "noextract\ninline_for_extraction\nlet kind_%s : parser_kind %s %s = %s\n\n" - (print_ident td.decl_name.td_name) - (string_of_bool td.decl_parser.p_kind.pk_nz) - (A.print_weak_kind td.decl_parser.p_kind.pk_weak_kind) - (print_kind mname td.decl_parser.p_kind) - `strcat` - Printf.sprintf "noextract\nlet parse_%s : parser (kind_%s) (%s) = %s\n\n" - (print_typedef_name mname td.decl_name) - (print_ident td.decl_name.td_name) - (print_typedef_typ td.decl_name) - (print_parser mname td.decl_parser) - `strcat` - (let inv, fp = print_typedef_actions_inv_and_fp td in - Printf.sprintf "%slet validate_%s = validate_weaken_inv_loc _ _ %s <: Tot (validate_with_action_t (parse_%s) %s %s %b) by (weaken_tac())\n\n" - (print_attributes td.decl_name.td_entrypoint (snd d)) - (print_typedef_name mname td.decl_name) - (print_validator mname td.decl_validator) - (print_typedef_typ td.decl_name) - inv - fp - td.decl_validator.v_allow_reading) - `strcat` - (match td.decl_reader with - | None -> "" - | Some r -> - Printf.sprintf "%sinline_for_extraction\nlet read_%s : leaf_reader (parse_%s) = %s\n\n" - (if td.decl_name.td_entrypoint then "" else "noextract\n") - (print_typedef_name mname td.decl_name) - (print_typedef_typ td.decl_name) - (print_reader mname r)) - - | Output_type _ - | Output_type_expr _ _ - | Extern_type _ - | Extern_fn _ _ _ -> "" - -let print_type_decl_signature (mname:string) (d:decl{Type_decl? (fst d)}) : ML string = - match fst d with - | Type_decl td -> - if false //not td.decl_name.td_entrypoint - then "" - else begin - (if is_type_abbreviation td - then Printf.sprintf "noextract\ninline_for_extraction\ntype %s = %s.Types.%s\n\n" - (print_typedef_name mname td.decl_name) - mname - (print_typedef_typ td.decl_name) - else Printf.sprintf "noextract\ninline_for_extraction\nval %s : Type0\n\n" - (print_typedef_name mname td.decl_name)) - `strcat` - Printf.sprintf "noextract\ninline_for_extraction\nval kind_%s : parser_kind %s %s\n\n" - (print_ident td.decl_name.td_name) - (string_of_bool td.decl_parser.p_kind.pk_nz) - (A.print_weak_kind td.decl_parser.p_kind.pk_weak_kind) - `strcat` - Printf.sprintf "noextract\nval parse_%s : parser (kind_%s) (%s)\n\n" - (print_typedef_name mname td.decl_name) - (print_ident td.decl_name.td_name) - (print_typedef_typ td.decl_name) - `strcat` - (let inv, fp = print_typedef_actions_inv_and_fp td in - Printf.sprintf "val validate_%s : validate_with_action_t (parse_%s) %s %s %b\n\n" - (print_typedef_name mname td.decl_name) - (print_typedef_typ td.decl_name) - inv - fp - td.decl_validator.v_allow_reading) - `strcat` - (match td.decl_reader with - | None -> "" - | Some r -> - Printf.sprintf "%sinline_for_extraction\nval read_%s : leaf_reader (parse_%s)\n\n" - (if td.decl_name.td_entrypoint then "" else "noextract\n") - (print_typedef_name mname td.decl_name) - (print_typedef_typ td.decl_name)) - end - -let print_decl_signature (mname:string) (d:decl) : ML string = - match fst d with - | Assumption _ - | Definition _ -> "" - | Type_decl td -> - if (snd d).is_hoisted - then "" - else if not ((snd d).is_exported || td.decl_name.td_entrypoint) - then "" - else print_type_decl_signature mname d - | Output_type _ - | Output_type_expr _ _ - | Extern_type _ - | Extern_fn _ _ _ -> "" - -let has_output_types (ds:list decl) : bool = - List.Tot.existsb (fun (d, _) -> Output_type? d) ds - -let has_output_type_exprs (ds:list decl) : bool = - List.Tot.existsb (fun (d, _) -> Output_type_expr? d) ds - -let has_extern_types (ds:list decl) : bool = - List.Tot.existsb (fun (d, _) -> Extern_type? d) ds - -let has_extern_functions (ds:list decl) : bool = - List.Tot.existsb (fun (d, _) -> Extern_fn? d) ds let external_api_include (modul:string) (ds:list decl) : string = - if has_output_type_exprs ds || has_extern_types ds || has_extern_functions ds + if has_external_api ds then Printf.sprintf "open %s.ExternalAPI\n\n" modul else "" -let print_decls (modul: string) (ds:list decl) = - let decls = - Printf.sprintf - "module %s\n\ - open EverParse3d.Prelude\n\ - open EverParse3d.Actions.All\n\ - %s\ - \n\n\ - #set-options \"--using_facts_from '* FStar EverParse3d.Prelude -FStar.Tactics -FStar.Reflection -LowParse'\"\n\ - %s" - modul - (external_api_include modul ds) - (String.concat "\n////////////////////////////////////////////////////////////////////////////////\n" - (ds |> List.map (print_decl_for_validators modul) - |> List.filter (fun s -> s <> ""))) - in - decls - -let print_types_decls (modul:string) (ds:list decl) = - let decls = - Printf.sprintf - "module %s.Types\n\ - open EverParse3d.Prelude\n\ - open EverParse3d.Actions.All\n\n\ - %s\ - #set-options \"--fuel 0 --ifuel 0 --using_facts_from '* -FStar.Tactics -FStar.Reflection -LowParse'\"\n\n\ - %s" - modul - (external_api_include modul ds) - (String.concat "\n////////////////////////////////////////////////////////////////////////////////\n" - (ds |> List.map (print_decl_for_types modul) - |> List.filter (fun s -> s <> ""))) - in - decls - -let print_decls_signature (mname: string) (ds:list decl) = - let decls = - Printf.sprintf - "module %s\n\ - open EverParse3d.Prelude\n\ - open EverParse3d.Actions.All\n\ - %s\ - \n\n\ - %s" - mname - (external_api_include mname ds) - (String.concat "\n" (ds |> List.map (print_decl_signature mname) |> List.filter (fun s -> s <> ""))) - in - // let dummy = - // "let retain (x:result) : Tot (FStar.UInt64.t & bool) = field_id_of_result x, result_is_error x" - // in - decls // ^ "\n" ^ dummy - #push-options "--z3rlimit_factor 4" let pascal_case name : ML string = let chars = String.list_of_string name in @@ -1174,10 +831,10 @@ let print_c_entry }\n\t\ return TRUE;" (if is_input_stream_buffer then "" - else "EVERPARSE_INPUT_BUFFER input = EverParseMakeInputBuffer(base);\n\t") - name - params - modul + else "EVERPARSE_INPUT_BUFFER input = EverParseMakeInputBuffer(base);\n\t") + name + params + modul in let wrapped_call_stream name params = Printf.sprintf @@ -1238,10 +895,12 @@ let print_c_entry let wrapper_name = wrapper_name modul d.decl_name.td_name.A.v.A.name in let signature = if is_input_stream_buffer - then Printf.sprintf "BOOLEAN %s(%suint8_t *base, uint32_t len)" + then Printf.sprintf + "BOOLEAN %s(%suint8_t *base, uint32_t len)" wrapper_name - (print_params params) - else Printf.sprintf "uint64_t %s(%sEVERPARSE_INPUT_STREAM_BASE base)" + (print_params params) + else Printf.sprintf + "uint64_t %s(%sEVERPARSE_INPUT_STREAM_BASE base)" wrapper_name (print_params params) in @@ -1252,7 +911,8 @@ let print_c_entry then wrapped_call_buffer validator_name (print_arguments params) else wrapped_call_stream validator_name (print_arguments params) in - Printf.sprintf "%s {\n\t%s\n}" signature body + Printf.sprintf "%s {\n\t%s\n}" + signature body in signature ^";", impl @@ -1331,9 +991,12 @@ let print_c_entry let header = Printf.sprintf "%s%s" add_includes header in let error_callback_proto = if HashingOptions.InputStreamBuffer? input_stream_binding - then Printf.sprintf "void %sEverParseError(const char *StructName, const char *FieldName, const char *Reason)%s" - modul - (if produce_everparse_error = Some ProduceEverParseError then "{(void) StructName; (void) FieldName; (void) Reason;}" else ";") + then Printf.sprintf + "void %sEverParseError(const char *StructName, const char *FieldName, const char *Reason)%s" + modul + (if produce_everparse_error = Some ProduceEverParseError + then "{(void) StructName; (void) FieldName; (void) Reason;}" + else ";") else "" in let impl = @@ -1401,13 +1064,14 @@ let rec base_output_type (t:typ) : ML A.ident = | T_app id A.KindOutput [] -> id | T_pointer t -> base_output_type t | _ -> failwith "Target.base_output_type called with a non-output type" - +#push-options "--fuel 1" let rec print_output_type_val (tbl:set) (t:typ) : ML string = let open A in if is_output_type t then let s = print_output_type false t in if H.try_find tbl s <> None then "" else let _ = H.insert tbl s () in + assert (is_output_type t); match t with | T_app id KindOutput [] -> Printf.sprintf "\n\nval %s : Type0\n\n" s @@ -1415,18 +1079,7 @@ let rec print_output_type_val (tbl:set) (t:typ) : ML string = let bs = print_output_type_val tbl bt in bs ^ (Printf.sprintf "\n\ninline_for_extraction noextract type %s = bpointer %s\n\n" s (print_output_type false bt)) else "" - -// let print_output_type_c_typedef (tbl:set) (t:typ) : ML string = -// if is_output_type t -// then let s = pascal_case (print_output_type t) in -// match H.try_find tbl s with -// | Some _ -> "" -// | None -> -// H.insert tbl s (); -// Printf.sprintf "\n\ntypedef %s %s;\n\n" -// (print_as_c_type t) -// s -// else "" +#pop-options let rec print_out_expr' (oe:output_expr') : ML string = match oe with @@ -1463,7 +1116,7 @@ let print_out_expr_set_fstar (tbl:set) (mname:string) (oe:output_expr) : ML stri (Some?.v oe.oe_bitwidth) end in Printf.sprintf - "\n\nval %s (_:%s) (_:%s) : external_action output_loc\n\n" + "\n\nval %s (_:%s) (_:%s) : extern_action (NonTrivial output_loc)\n\n" fn_name fn_arg1_t fn_arg2_t @@ -1544,39 +1197,6 @@ let output_setter_name lhs = Printf.sprintf "set_%s" (out_fn_name lhs) let output_getter_name lhs = Printf.sprintf "get_%s" (out_fn_name lhs) let output_base_var lhs = base_id_of_output_expr lhs -let print_external_api_fstar (modul:string) (ds:decls) : ML string = - let tbl = H.create 10 in - let s = String.concat "" (ds |> List.map (fun d -> - match fst d with - | Output_type ot -> - let t = T_app ot.out_typ_names.typedef_abbrev A.KindOutput [] in - Printf.sprintf "%s%s" - (print_output_type_val tbl t) - (print_output_type_val tbl (T_pointer t)) - | Output_type_expr oe is_get -> - Printf.sprintf "%s" - // (print_output_type_val tbl oe.oe_bt) - // (print_output_type_val tbl oe.oe_t) - (if not is_get then print_out_expr_set_fstar tbl modul oe - else print_out_expr_get_fstar tbl modul oe) - | Extern_type i -> - Printf.sprintf "\n\nval %s : Type0\n\n" (print_ident i) - | Extern_fn f ret params -> - Printf.sprintf "\n\nval %s %s (_:unit) : Stack unit (fun _ -> True) (fun h0 _ h1 -> B.modifies output_loc h0 h1)\n\n" - (print_ident f) - (String.concat " " (params |> List.map (fun (i, t) -> Printf.sprintf "(%s:%s)" - (print_ident i) - (print_typ modul t)))) - | _ -> "")) in - Printf.sprintf - "module %s.ExternalAPI\n\n\ - open FStar.HyperStack.ST\n\ - open EverParse3d.Prelude\n\ - open EverParse3d.Actions.All\n\ - noextract val output_loc : eloc\n\n%s" - modul - s - let print_external_types_fstar_interpreter (modul:string) (ds:decls) : ML string = let tbl = H.create 10 in let s = String.concat "" (ds |> List.map (fun d -> @@ -1614,11 +1234,13 @@ let print_external_api_fstar_interpreter (modul:string) (ds:decls) : ML string = | Extern_type i -> Printf.sprintf "\n\nval %s : Type0\n\n" (print_ident i) | Extern_fn f ret params -> - Printf.sprintf "\n\nval %s %s : external_action output_loc\n" + Printf.sprintf "\n\nval %s %s : extern_action (NonTrivial output_loc)\n" (print_ident f) (String.concat " " (params |> List.map (fun (i, t) -> Printf.sprintf "(%s:%s)" (print_ident i) (print_typ modul t)))) + | Extern_probe f -> + Printf.sprintf "\n\nval %s : EverParse3d.CopyBuffer.probe_fn\n\n" (print_ident f) | _ -> "")) in let external_types_include = @@ -1630,6 +1252,7 @@ let print_external_api_fstar_interpreter (modul:string) (ds:decls) : ML string = "module %s.ExternalAPI\n\n\ open EverParse3d.Prelude\n\ open EverParse3d.Actions.All\n\ + open EverParse3d.Interpreter\n\ %s\n\ noextract val output_loc : eloc\n\n%s" modul diff --git a/src/3d/Target.fsti b/src/3d/Target.fsti index 3a0db0439..aa3b775bf 100644 --- a/src/3d/Target.fsti +++ b/src/3d/Target.fsti @@ -61,6 +61,8 @@ type expr' = and expr = expr' & A.range +let subst = list (A.ident' & expr) +val subst_expr (s:subst) (e:expr) : expr let mk_expr (e:expr') = e, A.dummy_range type lam a = (option A.ident) & a @@ -98,6 +100,7 @@ type typ = | T_with_action: typ -> action -> typ | T_with_dep_action: typ -> a:lam action -> typ | T_with_comment: typ -> A.comments -> typ + | T_with_probe: typ -> probe_fn:A.ident -> len:expr -> dest:A.ident -> typ (* An index is an F* type or an expression -- we reuse Ast expressions for this @@ -108,6 +111,13 @@ let field_typ = typ type param = A.ident & typ +let mk_subst (l:list param) (args:list expr) : ML (option subst) = + if List.Tot.length l <> List.Tot.length args + then None + else ( + Some (List.map2 #param (fun (i, t) e -> i.v, e) l args) + ) + noeq type struct_field = { sf_dependence: bool; @@ -179,7 +189,8 @@ type parser' = | Parse_impos : parser' | Parse_with_comment: p:parser -> c:A.comments -> parser' | Parse_string : p:parser -> zero:expr -> parser' - + | Parse_with_probe : p:parser -> probe:A.ident -> len:expr -> dest:A.ident -> parser' + and parser = { p_kind:parser_kind; p_typ:typ; @@ -196,150 +207,6 @@ type reader = | Read_filter : r:reader -> f:lam expr -> reader | Read_app : hd:A.ident -> args:list index -> reader -noeq -type validator' = - | Validate_return: - validator' - - | Validate_app: - hd:A.ident -> - args:list index -> - validator' - - | Validate_nlist: - n:expr -> - v:validator -> - validator' - - | Validate_nlist_constant_size_without_actions: - n:expr -> - v:validator -> - validator' - - | Validate_t_at_most: - n:expr -> - v:validator -> - validator' - - | Validate_t_exact: - n:expr -> - v:validator -> - validator' - - | Validate_pair: - n1:A.ident -> - v1:validator -> - v2:validator -> - validator' - - | Validate_dep_pair: - n1:A.ident -> - v:validator -> - r:reader -> - k:lam validator -> - validator' - - | Validate_dep_pair_with_refinement: - p1_is_constant_size_without_actions:bool -> - n1:A.ident -> - dfst:validator -> - r:reader -> - refinement:lam expr -> - dsnd:lam validator -> - validator' - - | Validate_dep_pair_with_action: - dfst:validator -> - r:reader -> - a:lam action -> - dsnd:lam validator -> - validator' - - | Validate_dep_pair_with_refinement_and_action: - p1_is_constant_size_without_actions:bool -> - n1:A.ident -> - dfst:validator -> - r:reader -> - refinement:lam expr -> - a:lam action -> - dsnd:lam validator -> - validator' - - | Validate_map: - p:validator -> - f:lam expr -> - validator' - - | Validate_refinement: - n:A.ident -> - v:validator -> - r:reader -> - f:lam expr -> - validator' - - | Validate_refinement_with_action: - n:A.ident -> - v:validator -> - r:reader -> - f:lam expr -> - a:lam action -> - validator' - - | Validate_with_dep_action: - name:A.ident -> - v:validator -> - r:reader -> - a:lam action -> - validator' - - | Validate_with_action: - name:A.ident -> - v:validator -> - a:action -> - validator' - - | Validate_weaken_left: - v:validator -> - k:parser_kind -> - validator' - - | Validate_weaken_right: - v:validator -> - k:parser_kind -> - validator' - - | Validate_if_else: - e:expr -> - validator -> - validator -> - validator' - - | Validate_impos: - validator' - - | Validate_with_error_handler: - typename:A.ident -> - fieldname:string -> - v:validator -> - validator' - - | Validate_with_comment: - v:validator -> - c:A.comments -> - validator' - - | Validate_string: - v:validator -> - r:reader -> - zero:expr -> - validator' - -and validator = { - v_allow_reading: bool; - v_parser:parser; - v_validator:validator' -} - //////////////////////////////////////////////////////////////////////////////// noeq @@ -347,8 +214,6 @@ type type_decl = { decl_name: typedef_name; decl_typ: typedef_body; decl_parser: parser; - decl_validator: validator; - decl_reader: option reader; decl_is_enum : bool } @@ -401,25 +266,27 @@ type decl' = | Extern_type : A.ident -> decl' | Extern_fn : A.ident -> typ -> list param -> decl' + | Extern_probe : A.ident -> decl' type decl = decl' * decl_attributes type decls = list decl - +val has_output_types (ds:list decl) : bool +val has_output_type_exprs (ds:list decl) : bool +val has_extern_types (ds:list decl) : bool +val has_extern_functions (ds:list decl) : bool +val has_extern_probes (ds:list decl) : bool +val has_external_api (ds:list decl) : bool val error_handler_decl : decl val maybe_mname_prefix (mname:string) (i:A.ident) : string val print_ident (i:A.ident) : string val print_maybe_qualified_ident (mname:string) (i:A.ident) : ML string val print_expr (mname:string) (e:expr) : ML string -val print_typ (mname:string) (t:typ) : ML string //(decreases t) +val print_typ (mname:string) (t:typ) : ML string val print_kind (mname:string) (k:parser_kind) : Tot string -val print_parser (mname:string) (p:parser) : ML string val print_action (mname:string) (a:action) : ML string val print_definition (mname:string) (d:decl { Definition? (fst d)} ) : ML string val print_assumption (mname:string) (d:decl { Assumption? (fst d) } ) : ML string -val print_decls (modul: string) (ds:list decl) : ML string -val print_types_decls (modul: string) (ds:list decl) : ML string -val print_decls_signature (modul: string) (ds:list decl) : ML string val wrapper_name (modul: string) (fn: string) : ML string val validator_name (modul: string) (fn: string) : ML string type produce_everparse_error = | ProduceEverParseError @@ -441,7 +308,6 @@ val output_base_var (lhs:output_expr) : ML A.ident * Used by Main *) -val print_external_api_fstar (modul:string) (ds:decls) : ML string val print_external_types_fstar_interpreter (modul:string) (ds:decls) : ML string val print_external_api_fstar_interpreter (modul:string) (ds:decls) : ML string val print_out_exprs_c (modul:string) (ds:decls) : ML string diff --git a/src/3d/TranslateForInterpreter.fst b/src/3d/TranslateForInterpreter.fst index f6a9acc31..a1e74411f 100644 --- a/src/3d/TranslateForInterpreter.fst +++ b/src/3d/TranslateForInterpreter.fst @@ -549,11 +549,17 @@ let rec parse_typ (env:global_env) | T.T_pointer _ -> failwith "No parsers for pointer types" -let pv ar p v = T.({ - v_allow_reading = ar; - v_parser = p; - v_validator = v -}) + | T.T_with_probe content_type probe len dest -> + let p = parse_typ env typename fieldname content_type in + let q = T.Parse_with_probe p probe len dest in + let u64_t, _ = translate_typ A.tuint64 in + let u64_parser = parse_typ env typename fieldname u64_t in + { p_kind = u64_parser.p_kind; + p_typ = t; + p_parser = q; + p_typename = typename; + p_fieldname = fieldname } + let rec read_typ (env:global_env) (t:T.typ) : ML (option T.reader) = let open T in @@ -705,6 +711,7 @@ let rec parser_is_constant_size_without_actions | T.Parse_with_action _ _ _ | T.Parse_if_else _ _ _ | T.Parse_string _ _ + | T.Parse_with_probe _ _ _ _ -> false | T.Parse_map p _ | T.Parse_refinement _ p _ @@ -721,148 +728,31 @@ let unknown_type_ident = } in with_range id dummy_range -let rec make_validator (env:global_env) (p:T.parser) : ML T.validator = - let open T in - let with_error_handler v = - pv v.v_allow_reading - v.v_parser - (Validate_with_error_handler p.p_typename p.p_fieldname v) - in - match p.p_parser with - | Parse_impos -> - with_error_handler - (pv true p Validate_impos) - - | Parse_app hd args -> - with_error_handler - (pv (has_reader env hd) p (Validate_app hd args)) - - | Parse_nlist n p -> - with_error_handler - (if parser_is_constant_size_without_actions env p - then pv false p (Validate_nlist_constant_size_without_actions n (make_validator env p)) - else pv false p (Validate_nlist n (make_validator env p))) - - | Parse_t_at_most n p -> - with_error_handler - (pv false p (Validate_t_at_most n (make_validator env p))) - - | Parse_t_exact n p -> - with_error_handler - (pv false p (Validate_t_exact n (make_validator env p))) - - | Parse_return e -> - pv true p Validate_return - - | Parse_pair n1 p1 p2 -> - pv false p (Validate_pair n1 (make_validator env p1) - (make_validator env p2)) - - | Parse_dep_pair n1 p1 k -> - pv false p (Validate_dep_pair - n1 - (make_validator env p1) - (make_reader env p1.p_typ) - (map_lam k (make_validator env))) - - | Parse_dep_pair_with_refinement n1 p1 e k -> - let p1_is_constant_size_without_actions = parser_is_constant_size_without_actions env p1 in - pv false p (Validate_dep_pair_with_refinement - p1_is_constant_size_without_actions - n1 - (make_validator env p1) - (make_reader env p1.p_typ) - e - (map_lam k (make_validator env))) - - | Parse_dep_pair_with_action p1 a k -> - pv false p (Validate_dep_pair_with_action - (make_validator env p1) - (make_reader env p1.p_typ) - a - (map_lam k (make_validator env))) - - | Parse_dep_pair_with_refinement_and_action n1 p1 e a k -> - let p1_is_constant_size_without_actions = parser_is_constant_size_without_actions env p1 in - pv false p (Validate_dep_pair_with_refinement_and_action - p1_is_constant_size_without_actions - n1 - (make_validator env p1) - (make_reader env p1.p_typ) - e - a - (map_lam k (make_validator env))) - - | Parse_map p1 f -> - pv false p (Validate_map (make_validator env p1) f) - - | Parse_refinement n1 p1 f -> - with_error_handler - (pv false p (Validate_refinement n1 - (make_validator env p1) - (make_reader env p1.p_typ) - f)) - - | Parse_refinement_with_action n1 p1 f a -> - with_error_handler - (pv false p (Validate_refinement_with_action n1 - (make_validator env p1) - (make_reader env p1.p_typ) - f - a)) - - | Parse_with_action n1 p a -> - with_error_handler - (pv false p (Validate_with_action n1 (make_validator env p) a)) - - | Parse_with_dep_action n1 p a -> - with_error_handler - (pv false p (Validate_with_dep_action n1 - (make_validator env p) - (make_reader env p.p_typ) - a)) - - | Parse_weaken_left p1 k -> - let v1 = make_validator env p1 in - pv v1.v_allow_reading p (Validate_weaken_left v1 k) - - | Parse_weaken_right p1 k -> - let v1 = make_validator env p1 in - pv v1.v_allow_reading p (Validate_weaken_right v1 k) - - | Parse_if_else e p1 p2 -> - pv false p (Validate_if_else e (make_validator env p1) (make_validator env p2)) - - | Parse_with_comment p c -> - let v = make_validator env p in - pv v.v_allow_reading p (Validate_with_comment v c) - - | Parse_string elem zero -> - with_error_handler - (pv false p (Validate_string (make_validator env elem) (make_reader env elem.p_typ) zero)) - -// x:t1; -// t2; -// t3; -// y:t4; -// t5; -// t6 - -// (x <-- parse_t1 ; -// (parse_t2 ;; -// parse_t3 ;; -// (y <-- parse_t4; -// ((parse_t5 ;; -// parse_t6) `map` (fun x56 -> y, x56)))) -// `map` (fun x_2_3_4_5_6 -> {x = x; y .... })) - let make_zero (r: range) (t: typ) : ML T.expr = let it = typ_as_integer_type t in (T.Constant (Int it 0), r) #push-options "--z3rlimit_factor 4" let translate_atomic_field (f:A.atomic_field) : ML (T.struct_field & T.decls) = - let sf = f.v in + let sf = f.v in + match f.v.field_probe with + | Some probe_call -> ( + match f.v.field_type.v, probe_call.probe_fn with + | Pointer t, Some probe_fn -> + let t, ds1 = translate_typ t in + let len = translate_expr probe_call.probe_length in + let dest = probe_call.probe_dest in + let sf_typ = T.T_with_probe t probe_fn len dest in + T.({ sf_dependence=sf.field_dependence; + sf_ident=sf.field_ident; + sf_typ=sf_typ }), + ds1 + + | _ -> + failwith "Impossible: probed fields must be pointers and the probe function must be resolved" + ) + + | _ -> let t, ds1 = translate_typ sf.field_type in let t = let mk_at_most t e : ML T.typ = @@ -1121,7 +1011,8 @@ let rec hoist_typ let d, t = hoist_typ fn genv env t in d, T_with_comment t c - | T_pointer _ -> + | T_pointer _ + | T_with_probe _ _ _ _ -> [], t let add_parser_kind_nz (genv:global_env) (id:A.ident) (nz:bool) (wk: weak_kind) = @@ -1132,21 +1023,6 @@ let add_parser_kind_nz (genv:global_env) (id:A.ident) (nz:bool) (wk: weak_kind) H.insert genv.parser_weak_kind id.v wk; H.insert genv.parser_kind_nz id.v nz -let maybe_add_reader (genv:global_env) - (decl_name:_) - (t:T.typ) - : ML (option T.reader) - = let open T in - let reader = read_typ genv t in - let _ = - if Some? reader - then begin - Options.debug_print_string (Printf.sprintf ">>>>>> Adding reader for %s with definition %s\n" (ident_to_string decl_name.td_name) (T.print_typ "" t)); //AR: TODO: needs a module name - add_reader genv decl_name.td_name - end - in - reader - let hoist_one_type_definition (should_inline:bool) (genv:global_env) (env:env_t) (orig_tdn:T.typedef_name) (prefix:string) (t:T.typ) @@ -1176,13 +1052,10 @@ let hoist_one_type_definition (should_inline:bool) let t_parser = parse_typ orig_tdn.td_name type_name body in add_parser_kind_nz genv tdn.td_name t_parser.p_kind.pk_nz t_parser.p_kind.pk_weak_kind; add_parser_kind_is_constant_size genv tdn.td_name (parser_is_constant_size_without_actions genv t_parser); - let reader = maybe_add_reader genv tdn body in let td = { decl_name = tdn; decl_typ = TD_abbrev body; decl_parser = t_parser; - decl_validator = make_validator genv t_parser; - decl_reader = reader; decl_is_enum = false } in let td = Type_decl td in @@ -1333,13 +1206,10 @@ let translate_decl (env:global_env) (d:A.decl) : ML (list T.decl) = let open T in add_parser_kind_nz env tdn.td_name p.p_kind.pk_nz p.p_kind.pk_weak_kind; add_parser_kind_is_constant_size env tdn.td_name (parser_is_constant_size_without_actions env p); - let reader = maybe_add_reader env tdn t in let td = { decl_name = tdn; decl_typ = TD_abbrev t; decl_parser = p; - decl_validator = make_validator env p; - decl_reader = reader; decl_is_enum = false } in ds1@ds2@[with_comments (Type_decl td) d.d_exported A.(d.d_decl.comments)] @@ -1354,13 +1224,10 @@ let translate_decl (env:global_env) (d:A.decl) : ML (list T.decl) = let open T in add_parser_kind_nz env tdn.td_name p.p_kind.pk_nz p.p_kind.pk_weak_kind; add_parser_kind_is_constant_size env tdn.td_name (parser_is_constant_size_without_actions env p); - let reader = maybe_add_reader env tdn refined_typ in let td = { decl_name = tdn; decl_typ = TD_abbrev refined_typ; decl_parser = p; - decl_validator = make_validator env p; - decl_reader = reader; decl_is_enum = true } in ds1@ds2@[with_comments (Type_decl td) d.d_exported A.(d.d_decl.comments)] @@ -1373,13 +1240,10 @@ let translate_decl (env:global_env) (d:A.decl) : ML (list T.decl) = add_parser_kind_nz env tdn.td_name p.p_kind.pk_nz p.p_kind.pk_weak_kind; add_parser_kind_is_constant_size env tdn.td_name (parser_is_constant_size_without_actions env p); let decl_typ = TD_abbrev p.p_typ in - let reader = maybe_add_reader env tdn p.p_typ in let td = { decl_name = tdn; decl_typ = decl_typ; decl_parser = p; - decl_validator = make_validator env p; - decl_reader = reader; decl_is_enum = false } in ds1@ds2 @ [with_comments (Type_decl td) d.d_exported A.(d.d_decl.comments)] @@ -1388,19 +1252,14 @@ let translate_decl (env:global_env) (d:A.decl) : ML (list T.decl) = let tdn, ds1 = translate_typedef_name tdn0 params in let dummy_ident = with_dummy_range (to_ident' "_") in let p, ds2 = parse_field env tdn.td_name (with_dummy_range (SwitchCaseField switch_case dummy_ident)) in - // let t, ds2 = translate_switch_case_type env tdn switch_case in - // let p = parse_typ env tdn0.typedef_name "" t in let open T in add_parser_kind_nz env tdn.td_name p.p_kind.pk_nz p.p_kind.pk_weak_kind; add_parser_kind_is_constant_size env tdn.td_name (parser_is_constant_size_without_actions env p); let t = p.p_typ in - let reader = maybe_add_reader env tdn t in let td = { decl_name = tdn; decl_typ = TD_abbrev t; decl_parser = p; - decl_validator = make_validator env p; - decl_reader = reader; decl_is_enum = false } in ds1 @ ds2 @ [with_comments (Type_decl td) d.d_exported A.(d.d_decl.comments)] @@ -1416,6 +1275,9 @@ let translate_decl (env:global_env) (d:A.decl) : ML (list T.decl) = params@[i, t],ds@ds_t) ([], ds) params in ds @ [with_comments (T.Extern_fn f ret params) false []] + | ExternProbe f -> + [with_comments (T.Extern_probe f) false []] + noeq type translate_env = { t_has_reader: H.t ident' bool; diff --git a/src/3d/TypeSizes.fst b/src/3d/TypeSizes.fst index 3b47dbaed..065de1778 100644 --- a/src/3d/TypeSizes.fst +++ b/src/3d/TypeSizes.fst @@ -93,7 +93,7 @@ let size_and_alignment_of_typ (env:env_t) (t:typ) : ML (size & alignment) = match t.v with | Type_app i _ _ -> size_and_alignment_of_typename env i - | Pointer _ -> Variable, Some 8 + | Pointer _ -> Fixed 8, Some 8 //pointers are 64 bit and aligned let size_of_typ (env:env_t) (t:typ) : ML size @@ -229,7 +229,8 @@ let padding_field (env:env_t) (diag_enclosing_type_name:ident (* for diagnostics field_array_opt=(if n = 1 then FieldScalar else FieldArrayQualified(n_expr, ByteArrayByteSize)); field_constraint=None; field_bitwidth=None; - field_action=None + field_action=None; + field_probe=None } in let af = with_dummy_range sf in let f = with_dummy_range (AtomicField af) in @@ -429,7 +430,8 @@ let decl_size_with_alignment (env:env_t) (d:decl) | OutputType _ | ExternType _ - | ExternFn _ _ _ -> d + | ExternFn _ _ _ + | ExternProbe _ -> d let size_of_decls (genv:B.global_env) (senv:size_env) (ds:list decl) = let env = diff --git a/src/3d/Z3TestGen.fst b/src/3d/Z3TestGen.fst index d3ff6f127..8e9abe0f1 100644 --- a/src/3d/Z3TestGen.fst +++ b/src/3d/Z3TestGen.fst @@ -909,6 +909,7 @@ let rec type_has_actions = function | I.T_refine_with_action _ _ _ _ | I.T_dep_pair_with_refinement_and_action _ _ _ _ _ | I.T_with_action _ _ _ + | I.T_probe_then_validate _ _ _ _ _ -> true | I.T_false _ | I.T_denoted _ _ @@ -1038,6 +1039,7 @@ let produce_not_type_decl (a: I.not_type_decl) (out: string -> ML unit) : ML uni | T.Output_type_expr _ _ | T.Extern_type _ | T.Extern_fn _ _ _ + | T.Extern_probe _ -> () type prog_def = { diff --git a/src/3d/ocaml/Batch.ml b/src/3d/ocaml/Batch.ml index 4d6f997ba..42a7e6dd6 100644 --- a/src/3d/ocaml/Batch.ml +++ b/src/3d/ocaml/Batch.ml @@ -352,7 +352,7 @@ let krml_args input_stream_binding emit_output_types_defs add_include skip_c_mak let krml_args = "-tmpdir" :: out_dir :: "-skip-compilation" :: - "-static-header" :: "LowParse.Low.Base,EverParse3d.Prelude.StaticHeader,EverParse3d.ErrorCode,EverParse3d.InputStream.\\*" :: + "-static-header" :: "LowParse.Low.Base,EverParse3d.Prelude.StaticHeader,EverParse3d.ErrorCode,EverParse3d.CopyBuffer,EverParse3d.InputStream.\\*" :: "-no-prefix" :: "LowParse.Slice" :: "-no-prefix" :: "LowParse.Low.BoundedInt" :: "-library" :: everparse_only_bundle :: @@ -397,7 +397,7 @@ let call_krml files_and_modules_cleanup out_dir krml_args = (* append the everparse and krmllib bundles to the list of arguments *) let krml_args = krml_args @ [ "-bundle" ; - Printf.sprintf "%s,%s[rename=Lib,rename-prefix]" fstar_krmllib_bundle everparse_only_bundle; + Printf.sprintf "%s[rename=Lib,rename-prefix]" fstar_krmllib_bundle; "-bundle" ; Printf.sprintf "%s[rename=EverParse,rename-prefix]" everparse_only_bundle; ] diff --git a/src/3d/ocaml/OS.ml b/src/3d/ocaml/OS.ml index 51b7b5dd6..934055148 100644 --- a/src/3d/ocaml/OS.ml +++ b/src/3d/ocaml/OS.ml @@ -130,4 +130,4 @@ let write_witness_to_file w filename = w ) -let int_of_string x = Z.of_string x +let int_of_string x = Z.of_string x \ No newline at end of file diff --git a/src/3d/ocaml/lexer.mll b/src/3d/ocaml/lexer.mll index 65c66b80a..dc924f606 100644 --- a/src/3d/ocaml/lexer.mll +++ b/src/3d/ocaml/lexer.mll @@ -64,7 +64,8 @@ let () = H.add keywords "export" EXPORT; H.add keywords "output" OUTPUT; H.add keywords "union" UNION; - H.add keywords "extern" EXTERN + H.add keywords "extern" EXTERN; + H.add keywords "probe" PROBE let unsigned_int_of_string s = int_of_string (String.sub s 0 (String.length s - 2)) diff --git a/src/3d/ocaml/parser.mly b/src/3d/ocaml/parser.mly index 89ec75d72..152ae8068 100644 --- a/src/3d/ocaml/parser.mly +++ b/src/3d/ocaml/parser.mly @@ -62,6 +62,8 @@ %token MODULE EXPORT OUTPUT UNION EXTERN %token ENTRYPOINT REFINING ALIGNED %token HASH_IF HASH_ELSE HASH_ENDIF HASH_ELIF +%token PROBE + (* LBRACE_ONERROR CHECK *) %start prog %start expr_top @@ -264,8 +266,26 @@ field_action: | LBRACE_CHECK a=action RBRACE { a, false } | LBRACE_ACT a=action RBRACE { with_range (Action_act a) $startpos(a), false } +with_probe: + | PROBE probe_fn_opt=option_of(i=IDENT { i }) + LPAREN length=IDENT EQ len=expr COMMA + destination=IDENT EQ dest=IDENT + RPAREN + { + if length.v.name <> "length" || length.v.modul_name <> None + then error "Expected 'length' as the first argument to 'with probe'" length.range; + if destination.v.name <> "destination" || destination.v.modul_name <> None + then error "Expected 'destination' as the second argument to 'with probe'" destination.range; + { probe_fn=probe_fn_opt; probe_length=len; probe_dest=dest } + } + atomic_field: - | t=typ fn=IDENT bopt=option_of(bitwidth) aopt=array_annot c=option_of(refinement) a=option_of(field_action) + | t=maybe_pointer_typ fn=IDENT + bopt=option_of(bitwidth) + aopt=array_annot + c=option_of(refinement) + a=option_of(field_action) + p=option_of(with_probe) { { field_dependence=false; @@ -274,7 +294,8 @@ atomic_field: field_array_opt=aopt; field_constraint=c; field_bitwidth=bopt; - field_action=a + field_action=a; + field_probe=p } } @@ -510,6 +531,9 @@ decl_no_range: | EXTERN ret=typ i=IDENT ps=parameters { ExternFn (i, ret, ps) } + | EXTERN PROBE i=IDENT + { ExternProbe i } + block_comment_opt: | { let _ = Ast.comments_buffer.flush () in diff --git a/src/3d/prelude/EverParse3d.Actions.All.fsti b/src/3d/prelude/EverParse3d.Actions.All.fsti index c5faf196d..bd8264969 100644 --- a/src/3d/prelude/EverParse3d.Actions.All.fsti +++ b/src/3d/prelude/EverParse3d.Actions.All.fsti @@ -9,48 +9,28 @@ val ___PUINT8: Type0 // these are never NULL noextract inline_for_extraction val action_field_ptr - (#nz:_) - (#wk: _) - (#k:P.parser_kind nz wk) - (#[@@@erasable] t:Type) - (#[@@@erasable] p:P.parser k t) (u:squash (EverParse3d.Actions.BackendFlag.backend_flag == BackendFlagBuffer)) - : action p true_inv eloc_none true ___PUINT8 + : action true_inv disjointness_trivial eloc_none true ___PUINT8 noextract inline_for_extraction val action_field_ptr_after - (#nz:_) - (#wk: _) - (#k:P.parser_kind nz wk) - (#[@@@erasable] t:Type) - (#[@@@erasable] p:P.parser k t) (u:squash (EverParse3d.Actions.BackendFlag.backend_flag == BackendFlagExtern)) (sz: FStar.UInt64.t) (write_to: bpointer ___PUINT8) - : action p (ptr_inv write_to) (ptr_loc write_to) false bool // if action returns true, writes some value to write_to. if false, do nothing + : action (ptr_inv write_to) disjointness_trivial (ptr_loc write_to) false bool // if action returns true, writes some value to write_to. if false, do nothing noextract inline_for_extraction val action_field_ptr_after_with_setter - (#nz:_) - (#wk: _) - (#k:P.parser_kind nz wk) - (#[@@@erasable] t:Type) - (#[@@@erasable] p:P.parser k t) (u:squash (EverParse3d.Actions.BackendFlag.backend_flag == BackendFlagExtern)) (sz: FStar.UInt64.t) (#output_loc: eloc) (write_to: (___PUINT8 -> Tot (external_action output_loc))) - : action p true_inv output_loc false bool // if action returns true, writes some value to write_to. if false, do nothing + : action true_inv disjointness_trivial output_loc false bool // if action returns true, writes some value to write_to. if false, do nothing noextract inline_for_extraction val action_field_pos_32 - (#nz:_) - (#wk: _) - (#k:P.parser_kind nz wk) - (#[@@@erasable] t:Type) - (#[@@@erasable] p:P.parser k t) (u:squash (EverParse3d.Actions.BackendFlag.backend_flag == BackendFlagBuffer)) - : action p true_inv eloc_none false FStar.UInt32.t + : action true_inv disjointness_trivial eloc_none false FStar.UInt32.t diff --git a/src/3d/prelude/EverParse3d.Actions.Base.fst b/src/3d/prelude/EverParse3d.Actions.Base.fst index 854ecd7e4..1965eaecc 100644 --- a/src/3d/prelude/EverParse3d.Actions.Base.fst +++ b/src/3d/prelude/EverParse3d.Actions.Base.fst @@ -8,62 +8,158 @@ module B = LowStar.Buffer module I = EverParse3d.InputStream.Base module HS = FStar.HyperStack module HST = FStar.HyperStack.ST - +module CP = EverParse3d.CopyBuffer +module AppCtxt = EverParse3d.AppCtxt module LPE = EverParse3d.ErrorCode open FStar.Tactics.Typeclasses - +open FStar.FunctionalExtensionality module B = LowStar.Buffer module U8 = FStar.UInt8 module P = EverParse3d.Prelude - -let hinv = HS.mem -> Tot Type0 +module F = FStar.FunctionalExtensionality +let hinv = HS.mem ^-> prop let liveness_inv = i:hinv { forall l h0 h1. {:pattern (i h1); (modifies l h0 h1)} i h0 /\ modifies l h0 h1 /\ address_liveness_insensitive_locs `loc_includes` l ==> i h1 } let mem_inv = liveness_inv -let slice_inv = loc -> mem_inv +let slice_inv = mem_inv let inv_implies (inv0 inv1:slice_inv) = - forall i h. - inv0 i h ==> inv1 i h -let true_inv : slice_inv = fun _ _ -> True -let conj_inv (i0 i1:slice_inv) : slice_inv = fun sl h -> i0 sl h /\ i1 sl h + forall h. + inv0 h ==> inv1 h +let true_inv : slice_inv = F.on HS.mem #prop (fun _ -> True) +let conj_inv (i0 i1:slice_inv) : slice_inv = F.on HS.mem #prop (fun h -> i0 h /\ i1 h) let eloc = (l: FStar.Ghost.erased B.loc { B.address_liveness_insensitive_locs `B.loc_includes` l }) let eloc_union (l1 l2:eloc) : Tot eloc = B.loc_union l1 l2 let eloc_none : eloc = B.loc_none let eloc_includes (l1 l2:eloc) = B.loc_includes l1 l2 /\ True - +let eloc_disjoint (l1 l2:eloc) = B.loc_disjoint l1 l2 /\ True let inv_implies_refl inv = () let inv_implies_true inv0 = () let inv_implies_conj inv0 inv1 inv2 h01 h02 = () +let conj_inv_true_left_unit i = + FStar.PredicateExtensionality.predicateExtensionality _ (conj_inv true_inv i) i +let conj_inv_true_right_unit i = + FStar.PredicateExtensionality.predicateExtensionality _ (conj_inv i true_inv) i let eloc_includes_none l = () let eloc_includes_union l0 l1 l2 h01 h02 = () let eloc_includes_refl l = () +let eloc_union_none_left_unit l = () +let eloc_union_none_right_unit l = () + +let disjointness_pre = prop +let disjointness_trivial = True +let disjoint l1 l2 = eloc_disjoint l1 l2 +let conj_disjointness p1 p2 = p1 /\ p2 +let imp_disjointness p1 p2 = p1 ==> p2 +let disjoint_none_r l = + FStar.PropositionalExtensionality.apply + (disjoint l eloc_none) + (disjointness_trivial) +let disjoint_none_l l = + FStar.PropositionalExtensionality.apply + (disjoint eloc_none l) + (disjointness_trivial) + +let conj_disjointness_trivial_left_unit (d:disjointness_pre) + = FStar.PropositionalExtensionality.apply (disjointness_trivial `conj_disjointness` d) d + +let conj_disjointness_trivial_right_unit (d:disjointness_pre) + = FStar.PropositionalExtensionality.apply (d `conj_disjointness` disjointness_trivial) d + +let imp_disjointness_refl (d:disjointness_pre) + = () + +let index_equations () + = introduce forall d. _ + with conj_inv_true_left_unit d; + introduce forall d. _ + with conj_inv_true_right_unit d; + introduce forall l. _ + with eloc_union_none_right_unit l; + introduce forall l. _ + with eloc_union_none_left_unit l; + introduce forall l. _ + with disjoint_none_r l; + introduce forall l. _ + with disjoint_none_l l; + introduce forall d. _ + with conj_disjointness_trivial_left_unit d; + introduce forall d. _ + with conj_disjointness_trivial_right_unit d; + introduce forall d. _ + with imp_disjointness_refl d; + introduce forall i. _ + with inv_implies_refl i; + introduce forall i. _ + with inv_implies_true i; + introduce forall i0 i1 i2. + (i0 `inv_implies` i1 /\ + i0 `inv_implies` i2) ==> + (i0 `inv_implies` (i1 `conj_inv` i2)) + with introduce _ ==> _ + with _ . inv_implies_conj i0 i1 i2 () (); + introduce forall l. _ + with eloc_includes_none l; + introduce forall l0 l1 l2. (l0 `eloc_includes` l1 /\ + l0 `eloc_includes` l2) ==> + (l0 `eloc_includes` (l1 `eloc_union` l2)) + with introduce _ ==> _ + with _ . eloc_includes_union l0 l1 l2 () (); + introduce forall l. _ + with eloc_includes_refl l let bpointer a = B.pointer a let ptr_loc #a (x:B.pointer a) : Tot eloc = B.loc_buffer x -let ptr_inv #a (x:B.pointer a) : slice_inv = fun (sl:_) h -> B.live h x - - -let app_ctxt = B.pointer U8.t -let app_loc (x:app_ctxt) (l:eloc) : eloc = B.loc_buffer x `loc_union` l +let ptr_inv #a (x:B.pointer a) : slice_inv = F.on HS.mem #prop (fun h -> B.live h x /\ True) +let app_ctxt = AppCtxt.app_ctxt +let app_loc (x:AppCtxt.app_ctxt) (l:eloc) : eloc = + AppCtxt.properties x; + AppCtxt.loc_of x `loc_union` l inline_for_extraction noextract let input_buffer_t = EverParse3d.InputStream.All.t +inline_for_extraction +let error_handler = + typename:string -> + fieldname:string -> + error_reason:string -> + error_code:U64.t -> + ctxt: app_ctxt -> + sl: input_buffer_t -> + pos: LPE.pos_t -> + Stack unit + (requires fun h -> + I.live sl h /\ + true_inv h /\ + B.live h ctxt /\ + loc_not_unused_in h `loc_includes` app_loc ctxt eloc_none /\ + address_liveness_insensitive_locs `loc_includes` app_loc ctxt eloc_none /\ + app_loc ctxt eloc_none `loc_disjoint` I.footprint sl /\ + U64.v pos <= Seq.length (I.get_read sl h) + ) + (ensures fun h0 _ h1 -> + let sl = Ghost.reveal sl in + modifies (app_loc ctxt eloc_none) h0 h1 /\ + B.live h1 ctxt /\ + true_inv h1) + let action - p inv l on_success a -= - (# [EverParse3d.Util.solve_from_ctx ()] I.extra_t #input_buffer_t) -> + inv disj l on_success a += (# [EverParse3d.Util.solve_from_ctx ()] I.extra_t #input_buffer_t) -> ctxt: app_ctxt -> + error_handler_fn : error_handler -> sl: input_buffer_t -> + len: I.tlen sl -> pos: LPE.pos_t -> posf: LPE.pos_t -> Stack a (requires fun h -> I.live sl h /\ - inv (I.footprint sl) h /\ + disj /\ + inv h /\ B.live h ctxt /\ loc_not_unused_in h `loc_includes` app_loc ctxt l /\ address_liveness_insensitive_locs `loc_includes` app_loc ctxt l /\ @@ -75,7 +171,7 @@ let action let sl = Ghost.reveal sl in modifies (app_loc ctxt l) h0 h1 /\ B.live h1 ctxt /\ - inv (I.footprint sl) h1) + inv h1) module LP = LowParse.Spec.Base module LPL = LowParse.Low.Base @@ -133,34 +229,17 @@ let valid = I.live sl h /\ Some? (LP.parse p (I.get_remaining sl h)) -inline_for_extraction -let error_handler = - typename:string -> - fieldname:string -> - error_reason:string -> - error_code:U64.t -> - ctxt: app_ctxt -> - sl: input_buffer_t -> - pos: LPE.pos_t -> - Stack unit - (requires fun h -> - I.live sl h /\ - true_inv (I.footprint sl) h /\ - B.live h ctxt /\ - loc_not_unused_in h `loc_includes` app_loc ctxt eloc_none /\ - address_liveness_insensitive_locs `loc_includes` app_loc ctxt eloc_none /\ - app_loc ctxt eloc_none `loc_disjoint` I.footprint sl /\ - U64.v pos <= Seq.length (I.get_read sl h) - ) - (ensures fun h0 _ h1 -> - let sl = Ghost.reveal sl in - modifies (app_loc ctxt eloc_none) h0 h1 /\ - B.live h1 ctxt /\ - true_inv (I.footprint sl) h1) - inline_for_extraction noextract -let validate_with_action_t' (#k:LP.parser_kind) (#t:Type) (p:LP.parser k t) (inv:slice_inv) (l:eloc) (allow_reading:bool) = - (# [EverParse3d.Util.solve_from_ctx ()] I.extra_t #input_buffer_t) -> +let validate_with_action_t' + (#k:LP.parser_kind) + (#t:Type) + (p:LP.parser k t) + (inv:slice_inv) + (disj:disjointness_pre) + (l:eloc) + (allow_reading:bool) +: Type += (# [EverParse3d.Util.solve_from_ctx ()] I.extra_t #input_buffer_t) -> (ctxt: app_ctxt) -> (error_handler_fn : error_handler) -> (sl: input_buffer_t) -> @@ -169,7 +248,8 @@ let validate_with_action_t' (#k:LP.parser_kind) (#t:Type) (p:LP.parser k t) (inv Stack U64.t (requires fun h -> I.live sl h /\ - inv (I.footprint sl) h /\ + disj /\ + inv h /\ B.live h ctxt /\ loc_not_unused_in h `loc_includes` app_loc ctxt l /\ address_liveness_insensitive_locs `loc_includes` app_loc ctxt l /\ @@ -179,7 +259,7 @@ let validate_with_action_t' (#k:LP.parser_kind) (#t:Type) (p:LP.parser k t) (inv (ensures fun h res h' -> I.live sl h' /\ modifies (app_loc ctxt l `loc_union` I.perm_footprint sl) h h' /\ - inv (I.footprint sl) h' /\ + inv h' /\ B.live h' ctxt /\ (((~ allow_reading) \/ LPE.is_error res) ==> U64.v (LPE.get_validator_error_pos res) == Seq.length (I.get_read sl h')) /\ begin let s = I.get_remaining sl h in @@ -197,7 +277,7 @@ let validate_with_action_t' (#k:LP.parser_kind) (#t:Type) (p:LP.parser k t) (inv end ) -let validate_with_action_t p inv l allow_reading = validate_with_action_t' p inv l allow_reading +let validate_with_action_t p inv disj l allow_reading = validate_with_action_t' p inv disj l allow_reading let validate_eta v = fun ctxt error_handler_fn sl pos -> v ctxt error_handler_fn sl pos @@ -205,9 +285,9 @@ let validate_eta v = let act_with_comment s res a = - fun ctxt sl pos posf -> + fun ctxt err sl len pos posf -> LPL.comment s; - a ctxt sl pos posf + a ctxt err sl len pos posf let leaf_reader #nz @@ -240,10 +320,19 @@ let leaf_reader inline_for_extraction noextract -let validate_with_success_action' (name: string) #nz #wk (#k1:parser_kind nz wk) #t1 (#p1:parser k1 t1) (#inv1:_) (#l1:eloc) - (v1:validate_with_action_t p1 inv1 l1 false) - (#inv2:_) (#l2:eloc) #b (a:action p1 inv2 l2 b bool) - : validate_with_action_t p1 (conj_inv inv1 inv2) (l1 `eloc_union` l2) false +let validate_with_success_action' + (name: string) + #nz #wk (#k1:parser_kind nz wk) + #t1 (#p1:parser k1 t1) + (#inv1:_) (#disj1:_) (#l1:eloc) + (v1:validate_with_action_t p1 inv1 disj1 l1 false) + (#inv2:_) (#disj2:_) (#l2:eloc) #b + (a:action inv2 disj2 l2 b bool) + : validate_with_action_t p1 + (conj_inv inv1 inv2) + (conj_disjointness disj1 disj2) + (l1 `eloc_union` l2) + false = fun ctxt error_handler_fn input input_length start_position -> [@inline_let] let pos0 = start_position in let h0 = HST.get () in @@ -254,7 +343,7 @@ let validate_with_success_action' (name: string) #nz #wk (#k1:parser_kind nz wk) if LPE.is_success pos1 then [@(rename_let ("action_success_" ^ name))] - let b = a ctxt input pos0 pos1 in + let b = a ctxt error_handler_fn input input_length pos0 pos1 in let h2 = HST.get () in modifies_address_liveness_insensitive_unused_in h1 h2; if not b @@ -266,8 +355,14 @@ let validate_with_success_action' (name: string) #nz #wk (#k1:parser_kind nz wk) inline_for_extraction noextract let validate_drop_true - (#k:LP.parser_kind) (#t:Type) (#p:LP.parser k t) (#inv:slice_inv) (#l:eloc) (v: validate_with_action_t' p inv l true) -: Tot (validate_with_action_t' p inv l false) + (#k:LP.parser_kind) + (#t:Type) + (#p:LP.parser k t) + (#inv:slice_inv) + (#disj:disjointness_pre) + (#l:eloc) + (v: validate_with_action_t' p inv disj l true) +: Tot (validate_with_action_t' p inv disj l false) = fun ctxt error_handler_fn input input_length start_position -> [@inline_let] let pos = start_position in let res = v ctxt error_handler_fn input input_length pos in @@ -277,8 +372,15 @@ let validate_drop_true inline_for_extraction noextract let validate_drop - (#k:LP.parser_kind) (#t:Type) (#p:LP.parser k t) (#inv:slice_inv) (#l:eloc) #allow_reading (v: validate_with_action_t' p inv l allow_reading) -: Tot (validate_with_action_t' p inv l false) + (#k:LP.parser_kind) + (#t:Type) + (#p:LP.parser k t) + (#inv:slice_inv) + (#disj:disjointness_pre) + (#l:eloc) + #allow_reading + (v: validate_with_action_t' p inv disj l allow_reading) +: Tot (validate_with_action_t' p inv disj l false) = if allow_reading then validate_drop_true v else v @@ -288,18 +390,19 @@ let validate_with_success_action = validate_with_success_action' name (validate_drop v1) a inline_for_extraction noextract -let validate_with_error_handler (typename:string) - (fieldname:string) - #nz - #wk - (#k1:parser_kind nz wk) - #t1 - (#p1:parser k1 t1) - (#inv1:_) - (#l1:eloc) - (#ar:_) - (v1:validate_with_action_t p1 inv1 l1 ar) - : validate_with_action_t p1 inv1 l1 ar +let validate_with_error_handler + (typename:string) + (fieldname:string) + #nz + #wk + (#k1:parser_kind nz wk) + #t1 + (#p1:parser k1 t1) + (#inv1 #disj1:_) + (#l1:eloc) + (#ar:_) + (v1:validate_with_action_t p1 inv1 disj1 l1 ar) + : validate_with_action_t p1 inv1 disj1 l1 ar = fun ctxt error_handler_fn input input_length start_position -> [@inline_let] let pos0 = start_position in let h0 = HST.get () in @@ -316,7 +419,7 @@ let validate_with_error_handler (typename:string) inline_for_extraction noextract let validate_ret - : validate_with_action_t (parse_ret ()) true_inv eloc_none true + : validate_with_action_t (parse_ret ()) true_inv disjointness_trivial eloc_none true = fun ctxt error_handler_fn input input_length start_position -> start_position @@ -328,10 +431,9 @@ inline_for_extraction noextract let validate_pair (name1: string) #nz1 (#k1:parser_kind nz1 WeakKindStrongPrefix) #t1 (#p1:parser k1 t1) - (#inv1:_) (#l1:eloc) (#ar1:_) (v1:validate_with_action_t p1 inv1 l1 ar1) + (#inv1 #disj1:_) (#l1:eloc) (#ar1:_) (v1:validate_with_action_t p1 inv1 disj1 l1 ar1) #nz2 #wk2 (#k2:parser_kind nz2 wk2) #t2 (#p2:parser k2 t2) - (#inv2:_) (#l2:eloc) (#ar2:_) (v2:validate_with_action_t p2 inv2 l2 ar2) - : validate_with_action_t (p1 `parse_pair` p2) (conj_inv inv1 inv2) (l1 `eloc_union` l2) false + (#inv2 #disj2:_) (#l2:eloc) (#ar2:_) (v2:validate_with_action_t p2 inv2 disj2 l2 ar2) = fun ctxt error_handler_fn input input_length start_position -> [@inline_let] let pos = start_position in let h = HST.get () in @@ -350,10 +452,9 @@ inline_for_extraction noextract let validate_dep_pair (name1: string) #nz1 (#k1:parser_kind nz1 _) #t1 (#p1:parser k1 t1) - #inv1 #l1 (v1:validate_with_action_t p1 inv1 l1 true) (r1: leaf_reader p1) + #inv1 #disj1 #l1 (v1:validate_with_action_t p1 inv1 disj1 l1 true) (r1: leaf_reader p1) #nz2 #wk2 (#k2:parser_kind nz2 wk2) (#t2:t1 -> Type) (#p2:(x:t1 -> parser k2 (t2 x))) - #inv2 #l2 #ar2 (v2:(x:t1 -> validate_with_action_t (p2 x) inv2 l2 ar2)) - : Tot (validate_with_action_t (p1 `parse_dep_pair` p2) (conj_inv inv1 inv2) (l1 `eloc_union` l2) false) + #inv2 #disj2 #l2 #ar2 (v2:(x:t1 -> validate_with_action_t (p2 x) inv2 disj2 l2 ar2)) = fun ctxt error_handler_fn input input_length start_position -> [@inline_let] let pos = start_position in let h = HST.get () in @@ -381,18 +482,20 @@ inline_for_extraction noextract let validate_dep_pair_with_refinement_and_action' (name1: string) (#nz1: _) (#k1:parser_kind nz1 _) (#t1: _) (#p1:parser k1 t1) - (#inv1: _) (#l1: _) (v1:validate_with_action_t p1 inv1 l1 true) (r1: leaf_reader p1) + (#inv1 #disj1 #l1: _) (v1:validate_with_action_t p1 inv1 disj1 l1 true) (r1: leaf_reader p1) (f: t1 -> bool) - (#inv1': _) (#l1': _) (#b: _) (a:t1 -> action p1 inv1' l1' b bool) - (#nz2: _) (#wk2: _) (#k2:parser_kind nz2 wk2) (#t2:refine _ f -> Type) (#p2:(x:refine _ f) -> parser k2 (t2 x)) - (#inv2: _) (#l2: _) (#ar2: _) (v2:(x:refine _ f -> validate_with_action_t (p2 x) inv2 l2 ar2)) - : Tot (validate_with_action_t - ((p1 `LPC.parse_filter` f) `(parse_dep_pair #nz1)` p2) - (conj_inv inv1 (conj_inv inv1' inv2)) - (l1 `eloc_union` (l1' `eloc_union` l2)) - false) - = - fun ctxt error_handler_fn input input_length startPosition -> + (#inv1' #disj1' #l1' #b: _) (a:t1 -> action inv1' disj1' l1' b bool) + (#nz2 #wk2: _) (#k2:parser_kind nz2 wk2) + (#t2:refine _ f -> Type) + (#p2:(x:refine _ f) -> parser k2 (t2 x)) + (#inv2 #disj2 #l2 #ar2: _) (v2:(x:refine _ f -> validate_with_action_t (p2 x) inv2 disj2 l2 ar2)) +: validate_with_action_t + ((p1 `LPC.parse_filter` f) `(parse_dep_pair #nz1)` p2) + (conj_inv inv1 (conj_inv inv1' inv2)) + (conj_disjointness disj1 (conj_disjointness disj1' disj2)) + (l1 `eloc_union` (l1' `eloc_union` l2)) + false += fun ctxt error_handler_fn input input_length startPosition -> let h0 = HST.get () in LPC.parse_dtuple2_eq' #_ #_ (p1 `LPC.parse_filter` f) #_ #t2 p2 (I.get_remaining input h0); LPC.parse_filter_eq p1 f (I.get_remaining input h0); @@ -418,7 +521,7 @@ let validate_dep_pair_with_refinement_and_action' res1 else begin modifies_address_liveness_insensitive_unused_in h1 h2; - if not (a field_value ctxt input startPosition res1) + if not (a field_value ctxt error_handler_fn input input_length startPosition res1) then LPE.set_validator_error_pos LPE.validator_error_action_failed res1 //action failed else begin let h15 = HST.get () in @@ -431,15 +534,18 @@ let validate_dep_pair_with_refinement_and_action' inline_for_extraction noextract let validate_dep_pair_with_refinement_and_action_total_zero_parser' (name1: string) - (#nz1: _) (#k1:parser_kind nz1 WeakKindStrongPrefix) (#t1: _) (#p1:parser k1 t1) (r1: leaf_reader p1) - (inv1: _) (l1: _) + (#nz1: _) (#k1:parser_kind nz1 WeakKindStrongPrefix) + (#t1: _) (#p1:parser k1 t1) (r1: leaf_reader p1) + (inv1 disj1 l1: _) (f: t1 -> bool) - (#inv1': _) (#l1': _) (#b: _) (a:t1 -> action p1 inv1' l1' b bool) - (#nz2: _) (#wk2: _) (#k2:parser_kind nz2 wk2) (#t2:refine _ f -> Type) (#p2:(x:refine _ f -> parser k2 (t2 x))) - (#inv2: _) (#l2: _) (#ar2: _) (v2:(x:refine _ f -> validate_with_action_t (p2 x) inv2 l2 ar2)) + (#inv1' #disj1' #l1' #b: _) (a:t1 -> action inv1' disj1' l1' b bool) + (#nz2 #wk2: _) (#k2:parser_kind nz2 wk2) + (#t2:refine _ f -> Type) (#p2:(x:refine _ f -> parser k2 (t2 x))) + (#inv2 #disj2 #l2 #ar2: _) (v2:(x:refine _ f -> validate_with_action_t (p2 x) inv2 disj2 l2 ar2)) : Pure (validate_with_action_t ((p1 `LPC.parse_filter` f) `(parse_dep_pair #nz1)` p2) (conj_inv inv1 (conj_inv inv1' inv2)) + (conj_disjointness disj1 (conj_disjointness disj1' disj2)) (l1 `eloc_union` (l1' `eloc_union` l2)) false) (requires ( @@ -466,7 +572,7 @@ let validate_dep_pair_with_refinement_and_action_total_zero_parser' res1 else let h2 = HST.get() in modifies_address_liveness_insensitive_unused_in h0 h2; - if not (a field_value ctxt input startPosition res1) + if not (a field_value ctxt error_handler_fn input input_length startPosition res1) then LPE.set_validator_error_pos LPE.validator_error_action_failed startPosition //action failed else begin let h15 = HST.get () in @@ -480,21 +586,18 @@ let validate_dep_pair_with_refinement_and_action (p1_is_constant_size_without_actions: bool) (name1: string) #nz1 (#k1:parser_kind nz1 _) #t1 (#p1:parser k1 t1) - #inv1 #l1 (v1:validate_with_action_t p1 inv1 l1 true) (r1: leaf_reader p1) + #inv1 #disj1 #l1 (v1:validate_with_action_t p1 inv1 disj1 l1 true) + (r1: leaf_reader p1) (f: t1 -> bool) - #inv1' #l1' #b (a:t1 -> action p1 inv1' l1' b bool) + #inv1' #disj1' #l1' #b (a:t1 -> action inv1' disj1' l1' b bool) #nz2 #wk2 (#k2:parser_kind nz2 wk2) (#t2:refine _ f -> Type) (#p2:(x:refine _ f -> parser k2 (t2 x))) - #inv2 #l2 #ar2 (v2:(x:refine _ f -> validate_with_action_t (p2 x) inv2 l2 ar2)) - : Tot (validate_with_action_t ((p1 `parse_filter` f) `parse_dep_pair` p2) - (conj_inv inv1 (conj_inv inv1' inv2)) - (l1 `eloc_union` (l1' `eloc_union` l2)) - false) + #inv2 #disj2 #l2 #ar2 (v2:(x:refine _ f -> validate_with_action_t (p2 x) inv2 disj2 l2 ar2)) = if p1_is_constant_size_without_actions `LP.bool_and` (k1.LP.parser_kind_high = Some 0) `LP.bool_and` (k1.LP.parser_kind_metadata = Some LP.ParserKindMetadataTotal) then - validate_dep_pair_with_refinement_and_action_total_zero_parser' name1 r1 inv1 l1 f a v2 + validate_dep_pair_with_refinement_and_action_total_zero_parser' name1 r1 inv1 disj1 l1 f a v2 else validate_dep_pair_with_refinement_and_action' name1 v1 r1 f a v2 @@ -502,15 +605,10 @@ let validate_dep_pair_with_refinement_and_action inline_for_extraction noextract let validate_dep_pair_with_action #nz1 (#k1:parser_kind nz1 _) #t1 (#p1:parser k1 t1) - #inv1 #l1 (v1:validate_with_action_t p1 inv1 l1 true) (r1: leaf_reader p1) - #inv1' #l1' #b (a:t1 -> action p1 inv1' l1' b bool) + #inv1 #disj1 #l1 (v1:validate_with_action_t p1 inv1 disj1 l1 true) (r1: leaf_reader p1) + #inv1' #disj1' #l1' #b (a:t1 -> action inv1' disj1' l1' b bool) #nz2 #wk2 (#k2:parser_kind nz2 wk2) (#t2:t1 -> Type) (#p2:(x:t1 -> parser k2 (t2 x))) - #inv2 #l2 #ar2 (v2:(x:t1 -> validate_with_action_t (p2 x) inv2 l2 ar2)) - : Tot (validate_with_action_t - (p1 `(parse_dep_pair #nz1)` p2) - (conj_inv inv1 (conj_inv inv1' inv2)) - (l1 `eloc_union` (l1' `eloc_union` l2)) - false) + #inv2 #disj2 #l2 #ar2 (v2:(x:t1 -> validate_with_action_t (p2 x) inv2 disj2 l2 ar2)) = fun ctxt error_handler_fn input input_length startPosition -> let h0 = HST.get () in LPC.parse_dtuple2_eq' #_ #_ p1 #_ #t2 p2 (I.get_remaining input h0); @@ -525,7 +623,7 @@ let validate_dep_pair_with_action let field_value = r1 input startPosition in let h2 = HST.get() in modifies_address_liveness_insensitive_unused_in h1 h2; - let action_result = a field_value ctxt input startPosition res in + let action_result = a field_value ctxt error_handler_fn input input_length startPosition res in let h3 = HST.get () in modifies_address_liveness_insensitive_unused_in h2 h3; if not action_result @@ -538,13 +636,14 @@ inline_for_extraction noextract let validate_dep_pair_with_refinement' (name1: string) #nz1 (#k1:parser_kind nz1 _) #t1 (#p1:parser k1 t1) - #inv1 #l1 (v1:validate_with_action_t p1 inv1 l1 true) (r1: leaf_reader p1) + #inv1 #disj1 #l1 (v1:validate_with_action_t p1 inv1 disj1 l1 true) (r1: leaf_reader p1) (f: t1 -> bool) #nz2 #wk2 (#k2:parser_kind nz2 wk2) (#t2:refine _ f -> Type) (#p2:(x:refine _ f -> parser k2 (t2 x))) - #inv2 #l2 #ar2 (v2:(x:refine _ f -> validate_with_action_t (p2 x) inv2 l2 ar2)) + #inv2 #disj2 #l2 #ar2 (v2:(x:refine _ f -> validate_with_action_t (p2 x) inv2 disj2 l2 ar2)) : Tot (validate_with_action_t ((p1 `LPC.parse_filter` f) `(parse_dep_pair #nz1)` p2) (conj_inv inv1 inv2) + (conj_disjointness disj1 disj2) (l1 `eloc_union` l2) false) = fun ctxt error_handler_fn input input_length startPosition -> @@ -584,13 +683,17 @@ inline_for_extraction noextract let validate_dep_pair_with_refinement_total_zero_parser' (name1: string) #nz1 (#k1:parser_kind nz1 _) #t1 (#p1:parser k1 t1) - (inv1: _) (l1: _) (r1: leaf_reader p1) + (inv1 disj1 l1: _) (r1: leaf_reader p1) (f: t1 -> bool) - #nz2 #wk2 (#k2:parser_kind nz2 wk2) (#t2:refine _ f -> Type) (#p2:(x:refine _ f -> parser k2 (t2 x))) - #inv2 #l2 #ar2 (v2:(x:refine _ f -> validate_with_action_t (p2 x) inv2 l2 ar2)) + #nz2 #wk2 (#k2:parser_kind nz2 wk2) + (#t2:refine _ f -> Type) + (#p2:(x:refine _ f -> parser k2 (t2 x))) + #inv2 #disj2 #l2 #ar2 + (v2:(x:refine _ f -> validate_with_action_t (p2 x) inv2 disj2 l2 ar2)) : Pure (validate_with_action_t ((p1 `LPC.parse_filter` f) `(parse_dep_pair #nz1)` p2) (conj_inv inv1 inv2) + (conj_disjointness disj1 disj2) (l1 `eloc_union` l2) false) (requires ( @@ -630,29 +733,29 @@ let validate_dep_pair_with_refinement (p1_is_constant_size_without_actions: bool) (name1: string) #nz1 (#k1:parser_kind nz1 _) #t1 (#p1:parser k1 t1) - #inv1 #l1 (v1:validate_with_action_t p1 inv1 l1 true) (r1: leaf_reader p1) + #inv1 #disj1 #l1 (v1:validate_with_action_t p1 inv1 disj1 l1 true) (r1: leaf_reader p1) (f: t1 -> bool) - #nz2 #wk2 (#k2:parser_kind nz2 wk2) (#t2:refine _ f -> Type) (#p2:(x:refine _ f -> parser k2 (t2 x))) - #inv2 #l2 #ar2 (v2:(x:refine _ f -> validate_with_action_t (p2 x) inv2 l2 ar2)) - : Tot (validate_with_action_t ((p1 `parse_filter` f) `parse_dep_pair` p2) - (conj_inv inv1 inv2) - (l1 `eloc_union` l2) - false) - = if - p1_is_constant_size_without_actions `LP.bool_and` - (k1.LP.parser_kind_high = Some 0) `LP.bool_and` - (k1.LP.parser_kind_metadata = Some LP.ParserKindMetadataTotal) - then - validate_dep_pair_with_refinement_total_zero_parser' name1 inv1 l1 r1 f v2 - else - validate_dep_pair_with_refinement' name1 v1 r1 f v2 + #nz2 #wk2 (#k2:parser_kind nz2 wk2) + (#t2:refine _ f -> Type) + (#p2:(x:refine _ f -> parser k2 (t2 x))) + #inv2 #disj2 #l2 #ar2 + (v2:(x:refine _ f -> validate_with_action_t (p2 x) inv2 disj2 l2 ar2)) += if + p1_is_constant_size_without_actions `LP.bool_and` + (k1.LP.parser_kind_high = Some 0) `LP.bool_and` + (k1.LP.parser_kind_metadata = Some LP.ParserKindMetadataTotal) + then + validate_dep_pair_with_refinement_total_zero_parser' name1 inv1 disj1 l1 r1 f v2 + else + validate_dep_pair_with_refinement' name1 v1 r1 f v2 inline_for_extraction noextract -let validate_filter (name: string) #nz (#k:parser_kind nz _) (#t:_) (#p:parser k t) - #inv #l (v:validate_with_action_t p inv l true) - (r:leaf_reader p) (f:t -> bool) (cr:string) (cf:string) - : Tot (validate_with_action_t #nz #WeakKindStrongPrefix (p `LPC.parse_filter` f) inv l false) - = fun ctxt error_handler_fn input input_length start_position -> +let validate_filter + (name: string) + #nz (#k:parser_kind nz _) (#t:_) (#p:parser k t) + #inv #disj #l (v:validate_with_action_t p inv disj l true) + (r:leaf_reader p) (f:t -> bool) (cr:string) (cf:string) += fun ctxt error_handler_fn input input_length start_position -> [@inline_let] let pos = start_position in let h = HST.get () in LPC.parse_filter_eq p f (I.get_remaining input h); @@ -674,12 +777,13 @@ let validate_filter (name: string) #nz (#k:parser_kind nz _) (#t:_) (#p:parser k inline_for_extraction noextract let validate_filter_with_action - (name: string) #nz (#k:parser_kind nz _) (#t:_) (#p:parser k t) - #inv #l (v:validate_with_action_t p inv l true) - (r:leaf_reader p) (f:t -> bool) (cr:string) (cf:string) - (#b:bool) #inva (#la:eloc) (a: t -> action #nz #WeakKindStrongPrefix #(filter_kind k) #_ (p `LPC.parse_filter` f) inva la b bool) - : Tot (validate_with_action_t #nz #WeakKindStrongPrefix (p `LPC.parse_filter` f) (conj_inv inv inva) (eloc_union l la) false) - = fun ctxt error_handler_fn input input_length start_position -> + (name: string) + #nz (#k:parser_kind nz _) (#t:_) (#p:parser k t) + #inv #disj #l (v:validate_with_action_t p inv disj l true) + (r:leaf_reader p) (f:t -> bool) (cr:string) (cf:string) + (#b:bool) #inva #disja (#la:eloc) + (a: t -> action inva disja la b bool) += fun ctxt error_handler_fn input input_length start_position -> [@inline_let] let pos0 = start_position in let h = HST.get () in LPC.parse_filter_eq p f (I.get_remaining input h); @@ -699,7 +803,7 @@ let validate_filter_with_action if ok then let h15 = HST.get () in let _ = modifies_address_liveness_insensitive_unused_in h h15 in - if a field_value ctxt input pos0 res + if a field_value ctxt error_handler_fn input input_length pos0 res then res else LPE.set_validator_error_pos LPE.validator_error_action_failed res else LPE.set_validator_error_pos LPE.validator_error_constraint_failed res @@ -707,12 +811,14 @@ let validate_filter_with_action inline_for_extraction noextract let validate_with_dep_action - (name: string) #nz (#k:parser_kind nz _) (#t:_) (#p:parser k t) - #inv #l (v:validate_with_action_t p inv l true) - (r:leaf_reader p) - (#b:bool) #inva (#la:eloc) (a: t -> action p inva la b bool) - : Tot (validate_with_action_t #nz p (conj_inv inv inva) (eloc_union l la) false) - = fun ctxt error_handler_fn input input_length start_position -> + (name: string) + #nz (#k:parser_kind nz _) (#t:_) (#p:parser k t) + #inv #disj #l + (v:validate_with_action_t p inv disj l true) + (r:leaf_reader p) + (#b:bool) #inva #disja (#la:eloc) + (a: t -> action inva disja la b bool) += fun ctxt error_handler_fn input input_length start_position -> [@inline_let] let pos0 = start_position in let h = HST.get () in [@(rename_let ("positionAfter" ^ name))] @@ -725,47 +831,47 @@ let validate_with_dep_action let field_value = r input pos0 in let h15 = HST.get () in let _ = modifies_address_liveness_insensitive_unused_in h h15 in - if a field_value ctxt input pos0 res + if a field_value ctxt error_handler_fn input input_length pos0 res then res else LPE.set_validator_error_pos LPE.validator_error_action_failed res end inline_for_extraction noextract -let validate_weaken #nz #wk (#k:parser_kind nz wk) #t (#p:parser k t) - #inv #l #ar (v:validate_with_action_t p inv l ar) - #nz' #wk' (k':parser_kind nz' wk'{k' `is_weaker_than` k}) - : Tot (validate_with_action_t (parse_weaken p k') inv l ar) - = fun ctxt error_handler_fn input input_length start_position -> +let validate_weaken + #nz #wk (#k:parser_kind nz wk) #t (#p:parser k t) + #inv #disj #l #ar (v:validate_with_action_t p inv disj l ar) + #nz' #wk' (k':parser_kind nz' wk'{k' `is_weaker_than` k}) +: validate_with_action_t (parse_weaken p k') inv disj l ar += fun ctxt error_handler_fn input input_length start_position -> v ctxt error_handler_fn input input_length start_position /// Parser: weakening kinds inline_for_extraction noextract -let validate_weaken_left (#nz:_) #wk (#k:parser_kind nz wk) (#t:_) (#p:parser k t) - (#inv:_) (#l:_) #ar (v:validate_with_action_t p inv l ar) - (#nz':_) #wk' (k':parser_kind nz' wk') - : validate_with_action_t (parse_weaken_left p k') inv l ar - = validate_weaken v (glb k' k) +let validate_weaken_left + #nz #wk (#k:parser_kind nz wk) (#t:_) (#p:parser k t) + #inv #disj #l #ar (v:validate_with_action_t p inv disj l ar) + #nz' #wk' (k':parser_kind nz' wk') += validate_weaken v (glb k' k) /// Parser: weakening kinds inline_for_extraction noextract -let validate_weaken_right (#nz:_) #wk (#k:parser_kind nz wk) (#t:_) (#p:parser k t) - (#inv:_) (#l:_) #ar (v:validate_with_action_t p inv l ar) - (#nz':_) #wk' (k':parser_kind nz' wk') - : validate_with_action_t (parse_weaken_right p k') inv l ar - = validate_weaken v (glb k k') +let validate_weaken_right + #nz #wk (#k:parser_kind nz wk) (#t:_) (#p:parser k t) + #inv #disj #l #ar (v:validate_with_action_t p inv disj l ar) + #nz' #wk' (k':parser_kind nz' wk') += validate_weaken v (glb k k') inline_for_extraction noextract let validate_impos () - : Tot (validate_with_action_t (parse_impos ()) true_inv eloc_none true) - = fun _ _ _ _ start_position -> LPE.set_validator_error_pos LPE.validator_error_impossible start_position += fun _ _ _ _ start_position -> LPE.set_validator_error_pos LPE.validator_error_impossible start_position noextract inline_for_extraction let validate_ite - e p1 v1 p2 v2 - = fun ctxt error_handler_fn input input_len start_position -> + e p1 v1 p2 v2 += fun ctxt error_handler_fn input input_len start_position -> if e then validate_drop (v1 ()) ctxt error_handler_fn input input_len start_position else validate_drop (v2 ()) ctxt error_handler_fn input input_len start_position @@ -774,22 +880,24 @@ module LPLL = LowParse.Spec.List unfold let validate_list_inv - (#k: LPL.parser_kind) - (#t: Type) - (p: LPL.parser k t) - (inv: slice_inv) - (l: eloc) - (g0 g1: Ghost.erased HS.mem) - (ctxt:app_ctxt) - (sl: input_buffer_t) - (bres: pointer U64.t) - (h: HS.mem) - (stop: bool) + (#k: LPL.parser_kind) + (#t: Type) + (p: LPL.parser k t) + (inv: slice_inv) + (disj: disjointness_pre) + (l: eloc) + (g0 g1: Ghost.erased HS.mem) + (ctxt:app_ctxt) + (sl: input_buffer_t) + (bres: pointer U64.t) + (h: HS.mem) + (stop: bool) : GTot Type0 = let h0 = Ghost.reveal g0 in let h1 = Ghost.reveal g1 in let res = Seq.index (as_seq h bres) 0 in - inv (I.footprint sl) h0 /\ + inv h0 /\ + disj /\ loc_not_unused_in h0 `loc_includes` app_loc ctxt l /\ app_loc ctxt l `loc_disjoint` I.footprint sl /\ app_loc ctxt l `loc_disjoint` loc_buffer bres /\ @@ -829,8 +937,8 @@ let validate_list_body (#k:LP.parser_kind) #t (#p:LP.parser k t) - #inv #l #ar - (v: validate_with_action_t' p inv l ar) + #inv #disj #l #ar + (v: validate_with_action_t' p inv disj l ar) (g0 g1: Ghost.erased HS.mem) (ctxt:app_ctxt) (error_handler_fn:error_handler) @@ -838,10 +946,10 @@ let validate_list_body (sl_len: I.tlen sl) (bres: pointer U64.t) : HST.Stack bool - (requires (fun h -> validate_list_inv p inv l g0 g1 ctxt sl bres h false)) + (requires (fun h -> validate_list_inv p inv disj l g0 g1 ctxt sl bres h false)) (ensures (fun h res h' -> - validate_list_inv p inv l g0 g1 ctxt sl bres h false /\ - validate_list_inv p inv l g0 g1 ctxt sl bres h' res + validate_list_inv p inv disj l g0 g1 ctxt sl bres h false /\ + validate_list_inv p inv disj l g0 g1 ctxt sl bres h' res )) = let h = HST.get () in @@ -864,8 +972,8 @@ let validate_list' (#k:LP.parser_kind) #t (#p:LP.parser k t) - #inv #l #ar - (v: validate_with_action_t' p inv l ar) + #inv #disj #l #ar + (v: validate_with_action_t' p inv disj l ar) (ctxt: app_ctxt) (error_handler_fn: error_handler) (sl: input_buffer_t) @@ -873,7 +981,8 @@ let validate_list' (pos: LPE.pos_t) : HST.Stack U64.t (requires (fun h -> - inv (I.footprint sl) h /\ + inv h /\ + disj /\ loc_not_unused_in h `loc_includes` app_loc ctxt l /\ app_loc ctxt l `loc_disjoint` I.footprint sl /\ address_liveness_insensitive_locs `loc_includes` app_loc ctxt l /\ @@ -883,7 +992,7 @@ let validate_list' )) (ensures (fun h res h' -> let s = I.get_remaining sl h in - inv (I.footprint sl) h' /\ + inv h' /\ B.live h' ctxt /\ I.live sl h' /\ begin @@ -895,7 +1004,8 @@ let validate_list' | None -> LPE.is_success res == false | Some (_, len) -> if LPE.is_success res - then I.get_remaining sl h' `Seq.equal` Seq.slice s len (Seq.length s) /\ U64.v res == Seq.length (I.get_read sl h') + then I.get_remaining sl h' `Seq.equal` Seq.slice s len (Seq.length s) /\ + U64.v res == Seq.length (I.get_read sl h') else LPE.get_validator_error_kind res == LPE.get_validator_error_kind LPE.validator_error_action_failed end /\ (LPE.is_success res == false ==> U64.v (LPE.get_validator_error_pos res) == Seq.length (I.get_read sl h')) /\ @@ -910,7 +1020,9 @@ let validate_list' let h1 = HST.get () in let g1 = Ghost.hide h1 in I.live_not_unused_in sl h0; - C.Loops.do_while (validate_list_inv p inv l g0 g1 ctxt sl result) (fun _ -> validate_list_body v g0 g1 ctxt error_handler_fn sl sl_len result); + C.Loops.do_while + (validate_list_inv p inv disj l g0 g1 ctxt sl result) + (fun _ -> validate_list_body v g0 g1 ctxt error_handler_fn sl sl_len result); let finalResult = index result 0ul in let h2 = HST.get () in HST.pop_frame (); @@ -925,9 +1037,9 @@ let validate_list (#k:LP.parser_kind) #t (#p:LP.parser k t) - #inv #l #ar - (v: validate_with_action_t' p inv l ar) -: Tot (validate_with_action_t' (LowParse.Spec.List.parse_list p) inv l false) + #inv #disj #l #ar + (v: validate_with_action_t' p inv disj l ar) +: validate_with_action_t' (LowParse.Spec.List.parse_list p) inv disj l false = fun ctxt error_handler_fn input input_length start_position -> validate_list' v ctxt error_handler_fn input input_length start_position @@ -939,34 +1051,34 @@ module LPLF = LowParse.Low.FLData noextract inline_for_extraction let validate_fldata_consumes_all - (n:U32.t) - (#k: LP.parser_kind) - #t - (#p: LP.parser k t) - #inv #l #ar - (v: validate_with_action_t' p inv l ar { k.LP.parser_kind_subkind == Some LP.ParserConsumesAll }) -: Tot (validate_with_action_t' (LowParse.Spec.FLData.parse_fldata p (U32.v n)) inv l false) + (n:U32.t) + (#k: LP.parser_kind) + #t + (#p: LP.parser k t) + #inv #disj #l #ar + (v: validate_with_action_t' p inv disj l ar { k.LP.parser_kind_subkind == Some LP.ParserConsumesAll }) +: validate_with_action_t' (LowParse.Spec.FLData.parse_fldata p (U32.v n)) inv disj l false = fun ctxt error_handler_fn input input_length start_position -> - [@inline_let] let pos = start_position in - let h = HST.get () in - LPLF.parse_fldata_consumes_all_correct p (U32.v n) (I.get_remaining input h); - let hasEnoughBytes = I.has input input_length pos (Cast.uint32_to_uint64 n) in - let h1 = HST.get () in - modifies_address_liveness_insensitive_unused_in h h1; - if not hasEnoughBytes - then LPE.set_validator_error_pos LPE.validator_error_not_enough_data pos - else begin - let truncatedInput = I.truncate input pos (Cast.uint32_to_uint64 n) in - let truncatedInputLength = I.truncate_len input pos (Cast.uint32_to_uint64 n) truncatedInput in - let h2 = HST.get () in - modifies_address_liveness_insensitive_unused_in h h2; - I.is_prefix_of_prop truncatedInput input h2; - assert (I.get_remaining truncatedInput h2 `Seq.equal` Seq.slice (I.get_remaining input h) 0 (U32.v n)); - let res = validate_drop v ctxt error_handler_fn truncatedInput truncatedInputLength pos in - let h3 = HST.get () in - I.is_prefix_of_prop truncatedInput input h3; - res - end + [@inline_let] let pos = start_position in + let h = HST.get () in + LPLF.parse_fldata_consumes_all_correct p (U32.v n) (I.get_remaining input h); + let hasEnoughBytes = I.has input input_length pos (Cast.uint32_to_uint64 n) in + let h1 = HST.get () in + modifies_address_liveness_insensitive_unused_in h h1; + if not hasEnoughBytes + then LPE.set_validator_error_pos LPE.validator_error_not_enough_data pos + else begin + let truncatedInput = I.truncate input pos (Cast.uint32_to_uint64 n) in + let truncatedInputLength = I.truncate_len input pos (Cast.uint32_to_uint64 n) truncatedInput in + let h2 = HST.get () in + modifies_address_liveness_insensitive_unused_in h h2; + I.is_prefix_of_prop truncatedInput input h2; + assert (I.get_remaining truncatedInput h2 `Seq.equal` Seq.slice (I.get_remaining input h) 0 (U32.v n)); + let res = validate_drop v ctxt error_handler_fn truncatedInput truncatedInputLength pos in + let h3 = HST.get () in + I.is_prefix_of_prop truncatedInput input h3; + res + end #pop-options @@ -976,43 +1088,43 @@ let validate_fldata_consumes_all noextract inline_for_extraction let validate_fldata - (n:U32.t) - (#k: LP.parser_kind) - #t - (#p: LP.parser k t) - #inv #l #ar - (v: validate_with_action_t' p inv l ar) -: Tot (validate_with_action_t' (LowParse.Spec.FLData.parse_fldata p (U32.v n)) inv l false) + (n:U32.t) + (#k: LP.parser_kind) + #t + (#p: LP.parser k t) + #inv #disj #l #ar + (v: validate_with_action_t' p inv disj l ar) +: validate_with_action_t' (LowParse.Spec.FLData.parse_fldata p (U32.v n)) inv disj l false = fun ctxt error_handler_fn input input_length start_position -> - [@inline_let] let pos = start_position in - let h = HST.get () in - let hasEnoughBytes = I.has input input_length pos (Cast.uint32_to_uint64 n) in - let h1 = HST.get () in - modifies_address_liveness_insensitive_unused_in h h1; - if not hasEnoughBytes - then LPE.set_validator_error_pos LPE.validator_error_not_enough_data pos - else begin - let truncatedInput = I.truncate input pos (Cast.uint32_to_uint64 n) in - let truncatedInputLength = I.truncate_len input pos (Cast.uint32_to_uint64 n) truncatedInput in - let h2 = HST.get () in - modifies_address_liveness_insensitive_unused_in h h2; - I.is_prefix_of_prop truncatedInput input h2; - assert (I.get_remaining truncatedInput h2 `Seq.equal` Seq.slice (I.get_remaining input h) 0 (U32.v n)); - let res = validate_drop v ctxt error_handler_fn truncatedInput truncatedInputLength pos in - let h3 = HST.get () in - modifies_address_liveness_insensitive_unused_in h h3; - I.is_prefix_of_prop truncatedInput input h3; - if LPE.is_error res - then res + [@inline_let] let pos = start_position in + let h = HST.get () in + let hasEnoughBytes = I.has input input_length pos (Cast.uint32_to_uint64 n) in + let h1 = HST.get () in + modifies_address_liveness_insensitive_unused_in h h1; + if not hasEnoughBytes + then LPE.set_validator_error_pos LPE.validator_error_not_enough_data pos else begin - let stillHasBytes = I.has truncatedInput truncatedInputLength res 1uL in - let h4 = HST.get () in - modifies_address_liveness_insensitive_unused_in h h4; - if stillHasBytes - then LPE.set_validator_error_pos LPE.validator_error_unexpected_padding res - else res + let truncatedInput = I.truncate input pos (Cast.uint32_to_uint64 n) in + let truncatedInputLength = I.truncate_len input pos (Cast.uint32_to_uint64 n) truncatedInput in + let h2 = HST.get () in + modifies_address_liveness_insensitive_unused_in h h2; + I.is_prefix_of_prop truncatedInput input h2; + assert (I.get_remaining truncatedInput h2 `Seq.equal` Seq.slice (I.get_remaining input h) 0 (U32.v n)); + let res = validate_drop v ctxt error_handler_fn truncatedInput truncatedInputLength pos in + let h3 = HST.get () in + modifies_address_liveness_insensitive_unused_in h h3; + I.is_prefix_of_prop truncatedInput input h3; + if LPE.is_error res + then res + else begin + let stillHasBytes = I.has truncatedInput truncatedInputLength res 1uL in + let h4 = HST.get () in + modifies_address_liveness_insensitive_unused_in h h4; + if stillHasBytes + then LPE.set_validator_error_pos LPE.validator_error_unexpected_padding res + else res + end end - end #pop-options @@ -1024,9 +1136,9 @@ let validate_nlist (#k:parser_kind true wk) #t (#p:parser k t) - #inv #l #ar - (v: validate_with_action_t p inv l ar) -: Tot (validate_with_action_t (parse_nlist n p) inv l false) + #inv #disj #l #ar + (v: validate_with_action_t p inv disj l ar) +: Tot (validate_with_action_t (parse_nlist n p) inv disj l false) = validate_weaken #false #WeakKindStrongPrefix #(LowParse.Spec.FLData.parse_fldata_kind (U32.v n) LowParse.Spec.List.parse_list_kind) #(list t) (validate_fldata_consumes_all n (validate_list v)) @@ -1044,8 +1156,8 @@ let validate_total_constant_size_no_read' k.LP.parser_kind_low == U64.v sz /\ k.LP.parser_kind_metadata == Some LP.ParserKindMetadataTotal }) - inv l -: Tot (validate_with_action_t' p inv l true) + inv disj l +: validate_with_action_t' p inv disj l true = fun ctxt error_handler_fn input input_length start_position -> [@inline_let] let pos = start_position in let h = HST.get () in @@ -1070,13 +1182,21 @@ let validate_total_constant_size_no_read k.LP.parser_kind_low == U64.v sz /\ k.LP.parser_kind_metadata == Some LP.ParserKindMetadataTotal }) - inv l -: Tot (validate_with_action_t p inv l true) -= validate_total_constant_size_no_read' p sz u inv l + inv disj l +: Tot (validate_with_action_t p inv disj l true) += validate_total_constant_size_no_read' p sz u inv disj l inline_for_extraction noextract -let validate_nlist_total_constant_size_mod_ok (n:U32.t) #wk (#k:parser_kind true wk) (#t: Type) (p:parser k t) inv l - : Pure (validate_with_action_t (parse_nlist n p) inv l true) +let validate_nlist_total_constant_size_mod_ok + (n:U32.t) + #wk + (#k:parser_kind true wk) + (#t: Type) + (p:parser k t) + inv + disj + l + : Pure (validate_with_action_t (parse_nlist n p) inv disj l true) (requires ( let open LP in k.parser_kind_subkind == Some ParserStrong /\ @@ -1090,11 +1210,20 @@ let validate_nlist_total_constant_size_mod_ok (n:U32.t) #wk (#k:parser_kind true let _ = parse_nlist_total_fixed_size_kind_correct n p in - validate_total_constant_size_no_read' (LP.strengthen (LP.total_constant_size_parser_kind (U32.v n)) (parse_nlist n p)) (Cast.uint32_to_uint64 n) () inv l + validate_total_constant_size_no_read' + (LP.strengthen (LP.total_constant_size_parser_kind (U32.v n)) (parse_nlist n p)) + (Cast.uint32_to_uint64 n) + () inv disj l inline_for_extraction noextract -let validate_nlist_constant_size_mod_ko (n:U32.t) (#wk: _) (#k:parser_kind true wk) #t (p:parser k t) inv l - : Pure (validate_with_action_t (parse_nlist n p) inv l true) +let validate_nlist_constant_size_mod_ko + (n:U32.t) + (#wk: _) + (#k:parser_kind true wk) + #t + (p:parser k t) + inv disj l + : Pure (validate_with_action_t (parse_nlist n p) inv disj l true) (requires ( let open LP in k.parser_kind_subkind == Some ParserStrong /\ @@ -1124,8 +1253,14 @@ let validate_nlist_constant_size_mod_ko (n:U32.t) (#wk: _) (#k:parser_kind true ) inline_for_extraction noextract -let validate_nlist_total_constant_size' (n:U32.t) #wk (#k:parser_kind true wk) #t (p:parser k t) inv l - : Pure (validate_with_action_t (parse_nlist n p) inv l true) +let validate_nlist_total_constant_size' + (n:U32.t) + #wk + (#k:parser_kind true wk) + #t + (p:parser k t) + inv disj l + : Pure (validate_with_action_t (parse_nlist n p) inv disj l true) (requires ( let open LP in k.parser_kind_subkind == Some ParserStrong /\ @@ -1136,12 +1271,19 @@ let validate_nlist_total_constant_size' (n:U32.t) #wk (#k:parser_kind true wk) # (ensures (fun _ -> True)) = fun ctxt error_handler_fn input start_position -> // n is not an integer constant, so we need to eta-expand and swap fun and if if n `U32.rem` U32.uint_to_t k.LP.parser_kind_low = 0ul - then validate_nlist_total_constant_size_mod_ok n p inv l ctxt error_handler_fn input start_position - else validate_nlist_constant_size_mod_ko n p inv l ctxt error_handler_fn input start_position + then validate_nlist_total_constant_size_mod_ok n p inv disj l ctxt error_handler_fn input start_position + else validate_nlist_constant_size_mod_ko n p inv disj l ctxt error_handler_fn input start_position inline_for_extraction noextract -let validate_nlist_total_constant_size (n_is_const: bool) (n:U32.t) #wk (#k:parser_kind true wk) (#t: Type) (p:parser k t) inv l -: Pure (validate_with_action_t (parse_nlist n p) inv l true) +let validate_nlist_total_constant_size + (n_is_const: bool) + (n:U32.t) + #wk + (#k:parser_kind true wk) + (#t: Type) + (p:parser k t) + inv disj l +: Pure (validate_with_action_t (parse_nlist n p) inv disj l true) (requires ( let open LP in k.parser_kind_subkind = Some ParserStrong /\ @@ -1158,26 +1300,26 @@ let validate_nlist_total_constant_size (n_is_const: bool) (n:U32.t) #wk (#k:pars then U32.v n % k.LP.parser_kind_low = 0 else false then - validate_nlist_total_constant_size_mod_ok n p inv l + validate_nlist_total_constant_size_mod_ok n p inv disj l else if if n_is_const then U32.v n % k.LP.parser_kind_low <> 0 else false then - validate_nlist_constant_size_mod_ko n p inv l + validate_nlist_constant_size_mod_ko n p inv disj l else - validate_nlist_total_constant_size' n p inv l + validate_nlist_total_constant_size' n p inv disj l noextract inline_for_extraction let validate_nlist_constant_size_without_actions - (n_is_const: bool) - (n:U32.t) - #wk - (#k:parser_kind true wk) - #t (#p:parser k t) #inv #l #ar - (v: validate_with_action_t p inv l ar) -: Tot (validate_with_action_t (parse_nlist n p) inv l false) + (n_is_const: bool) + (n:U32.t) + #wk + (#k:parser_kind true wk) + #t (#p:parser k t) #inv #disj #l #ar + (v: validate_with_action_t p inv disj l ar) +: Tot (validate_with_action_t (parse_nlist n p) inv disj l false) = if let open LP in @@ -1186,7 +1328,7 @@ let validate_nlist_constant_size_without_actions k.parser_kind_metadata = Some ParserKindMetadataTotal && k.parser_kind_low < 4294967296 then - validate_drop (validate_nlist_total_constant_size n_is_const n p inv l) + validate_drop (validate_nlist_total_constant_size n_is_const n p inv disj l) else validate_nlist n v @@ -1194,9 +1336,10 @@ let validate_nlist_constant_size_without_actions #restart-solver noextract inline_for_extraction -let validate_t_at_most (n:U32.t) #nz #wk (#k:parser_kind nz wk) (#t:_) (#p:parser k t) - (#inv:_) (#l:_) (#ar:_) (v:validate_with_action_t p inv l ar) - : Tot (validate_with_action_t (parse_t_at_most n p) inv l false) +let validate_t_at_most + (n:U32.t) #nz #wk (#k:parser_kind nz wk) (#t:_) (#p:parser k t) + #inv #disj #l #ar (v:validate_with_action_t p inv disj l ar) + : Tot (validate_with_action_t (parse_t_at_most n p) inv disj l false) = fun ctxt error_handler_fn input input_length start_position -> [@inline_let] let pos = start_position in let h = HST.get () in @@ -1233,10 +1376,12 @@ let validate_t_at_most (n:U32.t) #nz #wk (#k:parser_kind nz wk) (#t:_) (#p:parse #restart-solver noextract inline_for_extraction -let validate_t_exact (n:U32.t) #nz #wk (#k:parser_kind nz wk) (#t:_) (#p:parser k t) - (#inv:_) (#l:_) (#ar:_) (v:validate_with_action_t p inv l ar) - : Tot (validate_with_action_t (parse_t_exact n p) inv l false) - = fun ctxt error_handler_fn input input_length start_position -> +let validate_t_exact + (n:U32.t) #nz #wk (#k:parser_kind nz wk) (#t:_) (#p:parser k t) + #inv #disj #l #ar + (v:validate_with_action_t p inv disj l ar) +: validate_with_action_t (parse_t_exact n p) inv disj l false += fun ctxt error_handler_fn input input_length start_position -> [@inline_let] let pos = start_position in let h = HST.get () in let hasBytes = I.has input input_length pos (Cast.uint32_to_uint64 n) in @@ -1271,20 +1416,24 @@ let validate_t_exact (n:U32.t) #nz #wk (#k:parser_kind nz wk) (#t:_) (#p:parser #pop-options inline_for_extraction noextract -let validate_with_comment (c:string) - #nz #wk (#k:parser_kind nz wk) #t (#p:parser k t) - #inv #l #ar (v:validate_with_action_t p inv l ar) - : validate_with_action_t p inv l ar - = fun ctxt error_handler_fn input input_length start_position -> +let validate_with_comment + (c:string) + #nz #wk (#k:parser_kind nz wk) #t (#p:parser k t) + #inv #disj #l #ar (v:validate_with_action_t p inv disj l ar) +: validate_with_action_t p inv disj l ar += fun ctxt error_handler_fn input input_length start_position -> LowParse.Low.Base.comment c; v ctxt error_handler_fn input input_length start_position inline_for_extraction noextract -let validate_weaken_inv_loc #nz #wk (#k:parser_kind nz wk) #t (#p:parser k t) - #inv (#l:eloc) #ar - (inv':slice_inv{inv' `inv_implies` inv}) (l':eloc{l' `eloc_includes` l}) - (v:validate_with_action_t p inv l ar) - : Tot (validate_with_action_t p inv' l' ar) +let validate_weaken_inv_loc + #nz #wk (#k:parser_kind nz wk) #t (#p:parser k t) + #inv #disj (#l:eloc) #ar + (inv':slice_inv{inv' `inv_implies` inv}) + (disj':_{ disj' `imp_disjointness` disj}) + (l':eloc{l' `eloc_includes` l}) + (v:validate_with_action_t p inv disj l ar) + : Tot (validate_with_action_t p inv' disj' l' ar) = v @@ -1317,7 +1466,7 @@ let validate____UINT8 : validator parse____UINT8 = validate_with_comment "Checking that we have enough space for a UINT8, i.e., 1 byte" - (validate_total_constant_size_no_read parse____UINT8 1uL () _ _) + (validate_total_constant_size_no_read parse____UINT8 1uL () _ _ _) inline_for_extraction noextract let lift_reader @@ -1351,7 +1500,7 @@ let validate____UINT8BE : validator parse____UINT8BE = validate_with_comment "Checking that we have enough space for a UINT8BE, i.e., 1 byte" - (validate_total_constant_size_no_read parse____UINT8BE 1uL () _ _) + (validate_total_constant_size_no_read parse____UINT8BE 1uL () _ _ _) inline_for_extraction noextract let read____UINT8BE @@ -1363,7 +1512,7 @@ let validate____UINT16BE : validator parse____UINT16BE = validate_with_comment "Checking that we have enough space for a UINT16BE, i.e., 2 bytes" - (validate_total_constant_size_no_read parse____UINT16BE 2uL () _ _) + (validate_total_constant_size_no_read parse____UINT16BE 2uL () _ _ _) inline_for_extraction noextract let read____UINT16BE @@ -1375,7 +1524,7 @@ let validate____UINT32BE : validator parse____UINT32BE = validate_with_comment "Checking that we have enough space for a UINT32BE, i.e., 4 bytes" - (validate_total_constant_size_no_read parse____UINT32BE 4uL () _ _) + (validate_total_constant_size_no_read parse____UINT32BE 4uL () _ _ _) inline_for_extraction noextract let read____UINT32BE @@ -1387,7 +1536,7 @@ let validate____UINT64BE : validator parse____UINT64BE = validate_with_comment "Checking that we have enough space for a UINT64BE, i.e., 8 bytes" - (validate_total_constant_size_no_read parse____UINT64BE 8uL () _ _) + (validate_total_constant_size_no_read parse____UINT64BE 8uL () _ _ _) inline_for_extraction noextract let read____UINT64BE @@ -1399,7 +1548,7 @@ let validate____UINT16 : validator parse____UINT16 = validate_with_comment "Checking that we have enough space for a UINT16, i.e., 2 bytes" - (validate_total_constant_size_no_read parse____UINT16 2uL () _ _) + (validate_total_constant_size_no_read parse____UINT16 2uL () _ _ _) inline_for_extraction noextract let read____UINT16 @@ -1411,7 +1560,7 @@ let validate____UINT32 : validator parse____UINT32 = validate_with_comment "Checking that we have enough space for a UINT32, i.e., 4 bytes" - (validate_total_constant_size_no_read parse____UINT32 4uL () _ _) + (validate_total_constant_size_no_read parse____UINT32 4uL () _ _ _) inline_for_extraction noextract let read____UINT32 @@ -1423,7 +1572,7 @@ let validate____UINT64 : validator parse____UINT64 = validate_with_comment "Checking that we have enough space for a UINT64, i.e., 8 bytes" - (validate_total_constant_size_no_read parse____UINT64 8uL () _ _) + (validate_total_constant_size_no_read parse____UINT64 8uL () _ _ _) inline_for_extraction noextract let read____UINT64 @@ -1551,28 +1700,33 @@ let validate_list_up_to (r: leaf_reader p) (terminator: t) (prf: LUT.consumes_if_not_cond (cond_string_up_to terminator) p) -: Tot (validate_with_action_t #true #WeakKindStrongPrefix (LUT.parse_list_up_to (cond_string_up_to terminator) p prf) true_inv eloc_none false) -= - fun ctxt error_handler_fn sl sl_len pos -> - let h0 = HST.get () in - HST.push_frame (); - let h1 = HST.get () in - fresh_frame_modifies h0 h1; - let bres = B.alloca pos 1ul in - let h2 = HST.get () in - I.live_not_unused_in sl h0; - C.Loops.do_while - (validate_list_up_to_inv p terminator prf ctxt sl h2 bres) - (fun _ -> validate_list_up_to_body terminator prf v r ctxt error_handler_fn sl sl_len h2 bres) - ; - let result = B.index bres 0ul in - HST.pop_frame (); - result +: validate_with_action_t #true #WeakKindStrongPrefix + (LUT.parse_list_up_to (cond_string_up_to terminator) p prf) + true_inv disjointness_trivial eloc_none false += fun ctxt error_handler_fn sl sl_len pos -> + let h0 = HST.get () in + HST.push_frame (); + let h1 = HST.get () in + fresh_frame_modifies h0 h1; + let bres = B.alloca pos 1ul in + let h2 = HST.get () in + I.live_not_unused_in sl h0; + C.Loops.do_while + (validate_list_up_to_inv p terminator prf ctxt sl h2 bres) + (fun _ -> validate_list_up_to_body terminator prf v r ctxt error_handler_fn sl sl_len h2 bres) + ; + let result = B.index bres 0ul in + HST.pop_frame (); + result let validate_string - #k #t #p v r terminator -= - LP.parser_kind_prop_equiv k p; + (#k: parser_kind true WeakKindStrongPrefix) + (#t: eqtype) + (#[@@@erasable] p: parser k t) + (v: validator p) + (r: leaf_reader p) + (terminator: t) += LP.parser_kind_prop_equiv k p; validate_weaken (validate_list_up_to v r terminator (fun _ _ _ -> ())) _ let validate_all_bytes = fun _ _ input input_length start_position -> @@ -1587,73 +1741,61 @@ let validate_all_zeros = noextract inline_for_extraction let action_return - #nz #wk (#k:parser_kind nz wk) (#t:Type) (#p:parser k t) (#a:Type) (x:a) - : action p true_inv eloc_none false a - = fun _ _ _ _ -> x + = fun _ _ _ _ _ _ -> x noextract inline_for_extraction let action_bind (name: string) - #nz #wk (#k:parser_kind nz wk) (#t:Type) (#p:parser k t) - (#invf:slice_inv) (#lf:eloc) - #bf (#a:Type) (f: action p invf lf bf a) - (#invg:slice_inv) (#lg:eloc) #bg - (#b:Type) (g: (a -> action p invg lg bg b)) - : Tot (action p (conj_inv invf invg) (eloc_union lf lg) (bf || bg) b) - = fun ctxt input pos posf -> + (#invf:slice_inv) #disjf (#lf:eloc) + #bf (#a:Type) (f: action invf disjf lf bf a) + (#invg:slice_inv) #disjg (#lg:eloc) #bg + (#b:Type) (g: (a -> action invg disjg lg bg b)) += fun ctxt error_handler_fn input input_length pos posf -> let h0 = HST.get () in [@(rename_let ("" ^ name))] - let x = f ctxt input pos posf in + let x = f ctxt error_handler_fn input input_length pos posf in let h1 = HST.get () in modifies_address_liveness_insensitive_unused_in h0 h1; - g x ctxt input pos posf + g x ctxt error_handler_fn input input_length pos posf noextract inline_for_extraction let action_seq - #nz #wk (#k:parser_kind nz wk) (#t:Type) (#p:parser k t) - (#invf:slice_inv) (#lf:eloc) - #bf (#a:Type) (f: action p invf lf bf a) - (#invg:slice_inv) (#lg:eloc) #bg - (#b:Type) (g: action p invg lg bg b) - : Tot (action p (conj_inv invf invg) (eloc_union lf lg) (bf || bg) b) - = fun ctxt input pos posf -> + (#invf:slice_inv) #disjf (#lf:eloc) + #bf (#a:Type) (f: action invf disjf lf bf a) + (#invg:slice_inv) #disjg (#lg:eloc) #bg + (#b:Type) (g: action invg disjg lg bg b) += fun ctxt error_handler_fn input input_length pos posf -> let h0 = HST.get () in - let _ = f ctxt input pos posf in + let _ = f ctxt error_handler_fn input input_length pos posf in let h1 = HST.get () in modifies_address_liveness_insensitive_unused_in h0 h1; - g ctxt input pos posf + g ctxt error_handler_fn input input_length pos posf noextract inline_for_extraction let action_ite - #nz #wk (#k:parser_kind nz wk) (#t:Type) (#p:parser k t) - (#invf:slice_inv) (#lf:eloc) + (#invf:slice_inv) #disjf (#lf:eloc) (guard:bool) - #bf (#a:Type) (then_: squash guard -> action p invf lf bf a) - (#invg:slice_inv) (#lg:eloc) #bg - (else_: squash (not guard) -> action p invg lg bg a) - : action p (conj_inv invf invg) (eloc_union lf lg) (bf || bg) a - = fun ctxt input pos posf -> - if guard - then then_ () ctxt input pos posf - else else_ () ctxt input pos posf + #bf (#a:Type) (then_: squash guard -> action invf disjf lf bf a) + (#invg:slice_inv) #disjg (#lg:eloc) #bg + (else_: squash (not guard) -> action invg disjg lg bg a) += fun ctxt error_handler_fn input input_length pos posf -> + if guard + then then_ () ctxt error_handler_fn input input_length pos posf + else else_ () ctxt error_handler_fn input input_length pos posf noextract inline_for_extraction let action_abort - #nz #wk (#k:parser_kind nz wk) (#t:Type) (#p:parser k t) - : action p true_inv eloc_none false bool - = fun _ _ _ _ -> false += fun _ _ _ _ _ _ -> false noextract inline_for_extraction let action_field_pos_64 - #nz #wk (#k:parser_kind nz wk) (#t:Type) (#p:parser k t) (u:unit) - : action p true_inv eloc_none false U64.t - = fun _ _ pos _ -> pos += fun _ _ _ _ pos _ -> pos (* FIXME: this is now unsound in general (only valid for flat buffer) noextract @@ -1665,48 +1807,77 @@ let action_field_ptr let open LowParse.Slice in LPL.offset input (LPL.uint64_to_uint32 startPosition) *) +module T = FStar.Tactics +let ptr_inv_elim (x:B.pointer 'a) +: Lemma + (ensures forall h. ptr_inv x h ==> B.live h x) += introduce forall h. ptr_inv x h ==> B.live h x + with assert (ptr_inv x h ==> B.live h x) + by (T.norm [delta]) noextract inline_for_extraction let action_deref - #nz #wk (#k:parser_kind nz wk) (#t:Type) (#p:parser k t) (#a:_) (x:B.pointer a) - : action p (ptr_inv x) loc_none false a - = fun _ _ _ _ -> !*x += fun _ _ _ _ _ _ -> + ptr_inv_elim x; + !*x noextract inline_for_extraction let action_assignment - #nz #wk (#k:parser_kind nz wk) (#t:Type) (#p:parser k t) (#a:_) (x:B.pointer a) (v:a) - : action p (ptr_inv x) (ptr_loc x) false unit - = fun _ _ _ _ -> x *= v += fun _ _ _ _ _ _ -> + ptr_inv_elim x; + x *= v -(* FIXME: This is now unsound. noextract inline_for_extraction -let action_read_value - #nz (#k:parser_kind nz) (#t:Type) (#p:parser k t) - (r:leaf_reader p) - : action p true_inv eloc_none true t - = fun input startPosition endPosition -> - r input (LPL.uint64_to_uint32 startPosition) -*) - -noextract -inline_for_extraction -let action_weaken - #nz #wk (#k:parser_kind nz wk) (#t:Type) (#p:parser k t) - (#inv:slice_inv) (#l:eloc) (#b:_) (#a:_) (act:action p inv l b a) - (#inv':slice_inv{inv' `inv_implies` inv}) (#l':eloc{l' `eloc_includes` l}) - : action p inv' l' b a - = act +let action_weaken #inv #disj #l #b #a act #inv' #disj' #l' = act let external_action l = unit -> Stack unit (fun _ -> True) (fun h0 _ h1 -> B.modifies l h0 h1) noextract inline_for_extraction -let mk_external_action #_ #_ #_ #_ #_ #_ f = fun _ _ _ _ -> f () +let mk_external_action #_ f = fun _ _ _ _ _ _ -> f () + +let copy_buffer_inv (x:CP.copy_buffer_t) +: slice_inv += CP.properties x; + F.on HS.mem #prop (CP.inv x) +let copy_buffer_loc (x:CP.copy_buffer_t) +: eloc += CP.loc_of x + +inline_for_extraction +noextract +let probe_then_validate + (#nz:bool) + (#wk: _) + (#k:parser_kind nz wk) + (#t:Type) + (#p:parser k t) + (#inv:slice_inv) + (#disj:_) + (#l:eloc) + (#allow_reading:bool) + (v:validate_with_action_t p inv disj l allow_reading) + (src:U64.t) + (len:U64.t) + (dest:CP.copy_buffer_t) + (probe:CP.probe_fn) + = fun ctxt error_handler_fn input input_length pos posf -> + CP.properties dest; + let h0 = HST.get () in + let b = probe src len dest in + if b + then ( + let h1 = HST.get () in + modifies_address_liveness_insensitive_unused_in h0 h1; + let result = v ctxt error_handler_fn (CP.stream_of dest) (CP.stream_len dest) 0uL in + not (LPE.is_error result) + ) + else false #pop-options diff --git a/src/3d/prelude/EverParse3d.Actions.Base.fsti b/src/3d/prelude/EverParse3d.Actions.Base.fsti index ff07926c8..4c343e332 100644 --- a/src/3d/prelude/EverParse3d.Actions.Base.fsti +++ b/src/3d/prelude/EverParse3d.Actions.Base.fsti @@ -18,9 +18,7 @@ module Cast = FStar.Int.Cast open EverParse3d.Prelude module U32 = FStar.UInt32 module U64 = FStar.UInt64 - -// inline_for_extraction -// let ___PUINT8 = LPL.puint8 +module CP = EverParse3d.CopyBuffer inline_for_extraction noextract @@ -36,19 +34,100 @@ val eloc : Type0 val eloc_union (l1 l2: eloc) : Tot eloc val eloc_none : eloc val eloc_includes (l1 l2: eloc) : Tot prop - +val eloc_disjoint (l1 l2: eloc) : Tot prop val inv_implies_refl (inv: slice_inv) : Tot (squash (inv `inv_implies` inv)) val inv_implies_true (inv0:slice_inv) : Tot (squash (inv0 `inv_implies` true_inv)) val inv_implies_conj (inv0 inv1 inv2: slice_inv) (h01: squash (inv0 `inv_implies` inv1)) (h02: squash (inv0 `inv_implies` inv2)) : Tot (squash (inv0 `inv_implies` (inv1 `conj_inv` inv2))) +val conj_inv_true_left_unit (inv:slice_inv) : Tot (squash (true_inv `conj_inv` inv == inv)) + +val conj_inv_true_right_unit (inv:slice_inv) : Tot (squash (inv `conj_inv` true_inv == inv)) + val eloc_includes_none (l1:eloc) : Tot (squash (l1 `eloc_includes` eloc_none)) val eloc_includes_union (l0: eloc) (l1 l2: eloc) (h01: squash (l0 `eloc_includes` l1)) (h02: squash (l0 `eloc_includes` l2)) : Tot (squash (l0 `eloc_includes` (l1 `eloc_union` l2))) val eloc_includes_refl (l: eloc) : Tot (squash (l `eloc_includes` l)) +val eloc_union_none_left_unit (l:eloc) : Tot (squash (eloc_none `eloc_union` l == l)) + +val eloc_union_none_right_unit (l:eloc) : Tot (squash (l `eloc_union` eloc_none == l)) + +[@@erasable] +val disjointness_pre : Type u#1 +val disjointness_trivial : disjointness_pre +val disjoint (l1 l2:eloc) : disjointness_pre +val conj_disjointness (d0 d1:disjointness_pre) : disjointness_pre +val imp_disjointness (d1 d2:disjointness_pre) : prop +val disjoint_none_r (l:eloc) + : squash (disjoint l eloc_none == disjointness_trivial) +val disjoint_none_l (l:eloc) + : squash (disjoint eloc_none l == disjointness_trivial) +val conj_disjointness_trivial_left_unit (d:disjointness_pre) + : squash ((disjointness_trivial `conj_disjointness` d) == d) +val conj_disjointness_trivial_right_unit (d:disjointness_pre) + : squash ((d `conj_disjointness` disjointness_trivial) == d) +val imp_disjointness_refl (d:disjointness_pre) + : squash (imp_disjointness d d) + +val index_equations (_:unit) + : Lemma + (ensures ( + //true_inv left unit + (forall (d:slice_inv). + {:pattern (true_inv `conj_inv` d)} (true_inv `conj_inv` d) == d) /\ + //true_inv right unit + (forall (d:slice_inv). + {:pattern (d `conj_inv` true_inv)} (d `conj_inv` true_inv) == d) /\ + //eloc_none left unit + (forall (l:eloc). + {:pattern (l `eloc_union` eloc_none)} (l `eloc_union` eloc_none) == l) /\ + //eloc_none right unit + (forall (l:eloc). + {:pattern (eloc_none `eloc_union` l)} (eloc_none `eloc_union` l) == l) /\ + //disjoint eloc_none right trivial + (forall (l:eloc). + {:pattern (disjoint l eloc_none)} (disjoint l eloc_none) == disjointness_trivial) /\ + //disjoint eloc_none left trivial + (forall (l:eloc). + {:pattern (disjoint eloc_none l)} (disjoint eloc_none l) == disjointness_trivial) /\ + //disjointness_pre right unit + (forall (d:disjointness_pre). + {:pattern (conj_disjointness d disjointness_trivial)} (conj_disjointness d disjointness_trivial) == d) /\ + //disjointness_pre left unit + (forall (d:disjointness_pre). + {:pattern (conj_disjointness disjointness_trivial d)} (conj_disjointness disjointness_trivial d) == d) /\ + //imp_disjointness refl + (forall (d:disjointness_pre). + {:pattern (imp_disjointness d d)} imp_disjointness d d) /\ + //inv_implies refl + (forall (i:slice_inv). + {:pattern (inv_implies i i)} inv_implies i i) /\ + //inv_implies true_inv right trivial + (forall (i:slice_inv). + {:pattern (inv_implies i true_inv)} inv_implies i true_inv) /\ + //inv_implies_conj + (forall (i0 i1 i2:slice_inv). + {:pattern (i0 `inv_implies` (i1 `conj_inv` i2))} + (i0 `inv_implies` i1 /\ + i0 `inv_implies` i2) ==> + (i0 `inv_implies` (i1 `conj_inv` i2))) /\ + //eloc_includes_none + (forall (l:eloc). + {:pattern (l `eloc_includes` eloc_none)} l `eloc_includes` eloc_none) /\ + //eloc_includes_union + (forall (l0 l1 l2:eloc). + {:pattern (l0 `eloc_includes` (l1 `eloc_union` l2))} + (l0 `eloc_includes` l1 /\ + l0 `eloc_includes` l2) ==> + (l0 `eloc_includes` (l1 `eloc_union` l2))) /\ + //eloc_includes_refl + (forall (l:eloc). + {:pattern (l `eloc_includes` l)} (l `eloc_includes` l)) + )) + inline_for_extraction noextract val bpointer (a: Type0) : Tot Type0 @@ -58,13 +137,9 @@ val ptr_inv (#a: _) (x: bpointer a) : Tot slice_inv inline_for_extraction noextract val action - (#nz:bool) - (#wk: _) - (#k:parser_kind nz wk) - (#t:Type) - (p:parser k t) - (inv:slice_inv) - (l:eloc) + (liveness_inv:slice_inv) + (disj:disjointness_pre) + (modifies_l:eloc) (on_success:bool) (a:Type) : Type0 @@ -76,7 +151,8 @@ val validate_with_action_t (#k:parser_kind nz wk) (#t:Type) (p:parser k t) - (inv:slice_inv) + (liveness_inv:slice_inv) + (disj:disjointness_pre) (l:eloc) (allow_reading:bool) : Type0 @@ -89,25 +165,22 @@ val validate_eta (#[@@@erasable] t:Type) (#[@@@erasable] p:parser k t) (#[@@@erasable] inv:slice_inv) + (#[@@@erasable] disj:disjointness_pre) (#[@@@erasable] l:eloc) (#allow_reading:bool) - (v: validate_with_action_t p inv l allow_reading) -: Tot (validate_with_action_t p inv l allow_reading) + (v: validate_with_action_t p inv disj l allow_reading) +: Tot (validate_with_action_t p inv disj l allow_reading) inline_for_extraction noextract val act_with_comment (s: string) - (#nz:bool) - (#wk: _) - (#k:parser_kind nz wk) - (#[@@@erasable] t:Type) - (#[@@@erasable] p:parser k t) (#[@@@erasable] inv:slice_inv) + (#[@@@erasable] disj:disjointness_pre) (#[@@@erasable] l:eloc) (#b:_) (res:Type) - (a: action p inv l b res) -: Tot (action p inv l b res) + (a: action inv disj l b res) +: Tot (action inv disj l b res) inline_for_extraction noextract val leaf_reader @@ -126,14 +199,16 @@ val validate_with_success_action (#[@@@erasable] t1:Type) (#[@@@erasable] p1:parser k1 t1) (#[@@@erasable] inv1:slice_inv) + (#[@@@erasable] disj1:disjointness_pre) (#[@@@erasable] l1:eloc) (#allow_reading:bool) - (v1:validate_with_action_t p1 inv1 l1 allow_reading) + (v1:validate_with_action_t p1 inv1 disj1 l1 allow_reading) (#[@@@erasable] inv2:slice_inv) + (#[@@@erasable] disj2:disjointness_pre) (#[@@@erasable] l2:eloc) (#b:bool) - (a:action p1 inv2 l2 b bool) - : validate_with_action_t p1 (conj_inv inv1 inv2) (l1 `eloc_union` l2) false + (a:action inv2 disj2 l2 b bool) + : validate_with_action_t p1 (conj_inv inv1 inv2) (conj_disjointness disj1 disj2) (l1 `eloc_union` l2) false inline_for_extraction noextract @@ -146,14 +221,15 @@ val validate_with_error_handler (#[@@@erasable] t1: Type) (#[@@@erasable] p1:parser k1 t1) (#[@@@erasable] inv1:slice_inv) + (#[@@@erasable] disj:disjointness_pre) (#[@@@erasable] l1:eloc) (#ar:_) - (v1:validate_with_action_t p1 inv1 l1 ar) - : validate_with_action_t p1 inv1 l1 ar + (v1:validate_with_action_t p1 inv1 disj l1 ar) + : validate_with_action_t p1 inv1 disj l1 ar inline_for_extraction noextract val validate_ret - : validate_with_action_t (parse_ret ()) true_inv eloc_none true + : validate_with_action_t (parse_ret ()) true_inv disjointness_trivial eloc_none true inline_for_extraction noextract val validate_pair @@ -163,19 +239,26 @@ val validate_pair (#[@@@erasable] t1:Type) (#[@@@erasable] p1:parser k1 t1) (#[@@@erasable] inv1:slice_inv) + (#[@@@erasable] disj1:disjointness_pre) (#[@@@erasable] l1:eloc) (#allow_reading1:bool) - (v1:validate_with_action_t p1 inv1 l1 allow_reading1) + (v1:validate_with_action_t p1 inv1 disj1 l1 allow_reading1) (#nz2:_) (#wk2: _) (#k2:parser_kind nz2 wk2) (#[@@@erasable] t2:Type) (#[@@@erasable] p2:parser k2 t2) (#[@@@erasable] inv2:slice_inv) + (#[@@@erasable] disj2:disjointness_pre) (#[@@@erasable] l2:eloc) (#allow_reading2:bool) - (v2:validate_with_action_t p2 inv2 l2 allow_reading2) - : validate_with_action_t (p1 `parse_pair` p2) (conj_inv inv1 inv2) (l1 `eloc_union` l2) false + (v2:validate_with_action_t p2 inv2 disj2 l2 allow_reading2) + : validate_with_action_t + (p1 `parse_pair` p2) + (conj_inv inv1 inv2) + (conj_disjointness disj1 disj2) + (l1 `eloc_union` l2) + false inline_for_extraction noextract val validate_dep_pair @@ -185,8 +268,9 @@ val validate_dep_pair (#t1:Type) (#[@@@erasable] p1:parser k1 t1) (#[@@@erasable] inv1:slice_inv) + (#[@@@erasable] disj1:disjointness_pre) (#[@@@erasable] l1:eloc) - (v1:validate_with_action_t p1 inv1 l1 true) + (v1:validate_with_action_t p1 inv1 disj1 l1 true) (r1: leaf_reader p1) (#nz2:_) (#wk2: _) @@ -194,10 +278,16 @@ val validate_dep_pair (#[@@@erasable] t2:t1 -> Type) (#[@@@erasable] p2:(x:t1 -> parser k2 (t2 x))) (#[@@@erasable] inv2:slice_inv) + (#[@@@erasable] disj2:disjointness_pre) (#[@@@erasable] l2:eloc) (#allow_reading2:bool) - (v2:(x:t1 -> validate_with_action_t (p2 x) inv2 l2 allow_reading2)) - : validate_with_action_t (p1 `parse_dep_pair` p2) (conj_inv inv1 inv2) (l1 `eloc_union` l2) false + (v2:(x:t1 -> validate_with_action_t (p2 x) inv2 disj2 l2 allow_reading2)) + : validate_with_action_t + (p1 `parse_dep_pair` p2) + (conj_inv inv1 inv2) + (conj_disjointness disj1 disj2) + (l1 `eloc_union` l2) + false inline_for_extraction noextract val validate_dep_pair_with_refinement_and_action @@ -208,27 +298,32 @@ val validate_dep_pair_with_refinement_and_action (#t1:Type) (#[@@@erasable] p1:parser k1 t1) (#[@@@erasable] inv1:slice_inv) + (#[@@@erasable] disj1:disjointness_pre) (#[@@@erasable] l1:eloc) - (v1:validate_with_action_t p1 inv1 l1 true) + (v1:validate_with_action_t p1 inv1 disj1 l1 true) (r1: leaf_reader p1) (f: t1 -> bool) (#[@@@erasable] inv1':slice_inv) + (#[@@@erasable] disj1':disjointness_pre) (#[@@@erasable] l1':eloc) (#b:_) - (a:t1 -> action p1 inv1' l1' b bool) + (a:t1 -> action inv1' disj1' l1' b bool) (#nz2:_) (#wk2: _) (#k2:parser_kind nz2 wk2) (#[@@@erasable] t2:refine _ f -> Type) (#[@@@erasable] p2:(x:refine _ f -> parser k2 (t2 x))) (#[@@@erasable] inv2:slice_inv) + (#[@@@erasable] disj2:disjointness_pre) (#[@@@erasable] l2:eloc) (#allow_reading2:bool) - (v2:(x:refine _ f -> validate_with_action_t (p2 x) inv2 l2 allow_reading2)) - : validate_with_action_t ((p1 `parse_filter` f) `parse_dep_pair` p2) - (conj_inv inv1 (conj_inv inv1' inv2)) - (l1 `eloc_union` (l1' `eloc_union` l2)) - false + (v2:(x:refine _ f -> validate_with_action_t (p2 x) inv2 disj2 l2 allow_reading2)) + : validate_with_action_t + ((p1 `parse_filter` f) `parse_dep_pair` p2) + (conj_inv inv1 (conj_inv inv1' inv2)) + (conj_disjointness disj1 (conj_disjointness disj1' disj2)) + (l1 `eloc_union` (l1' `eloc_union` l2)) + false inline_for_extraction noextract val validate_dep_pair_with_action @@ -237,27 +332,31 @@ val validate_dep_pair_with_action (#t1:Type) (#[@@@erasable] p1:parser k1 t1) (#[@@@erasable] inv1:slice_inv) + (#[@@@erasable] disj1:disjointness_pre) (#[@@@erasable] l1:eloc) - (v1:validate_with_action_t p1 inv1 l1 true) + (v1:validate_with_action_t p1 inv1 disj1 l1 true) (r1: leaf_reader p1) (#[@@@erasable] inv1':slice_inv) + (#[@@@erasable] disj1':disjointness_pre) (#[@@@erasable] l1':eloc) (#b:_) - (a:t1 -> action p1 inv1' l1' b bool) + (a:t1 -> action inv1' disj1' l1' b bool) (#nz2:_) (#wk2: _) (#k2:parser_kind nz2 wk2) (#[@@@erasable] t2:t1 -> Type) (#[@@@erasable] p2:(x:t1 -> parser k2 (t2 x))) (#[@@@erasable] inv2:slice_inv) + (#[@@@erasable] disj2:disjointness_pre) (#[@@@erasable] l2:eloc) (#allow_reading2:_) - (v2:(x:t1 -> validate_with_action_t (p2 x) inv2 l2 allow_reading2)) + (v2:(x:t1 -> validate_with_action_t (p2 x) inv2 disj2 l2 allow_reading2)) : validate_with_action_t - (p1 `(parse_dep_pair #nz1)` p2) - (conj_inv inv1 (conj_inv inv1' inv2)) - (l1 `eloc_union` (l1' `eloc_union` l2)) - false + (p1 `(parse_dep_pair #nz1)` p2) + (conj_inv inv1 (conj_inv inv1' inv2)) + (conj_disjointness disj1 (conj_disjointness disj1' disj2)) + (l1 `eloc_union` (l1' `eloc_union` l2)) + false inline_for_extraction noextract val validate_dep_pair_with_refinement @@ -268,8 +367,9 @@ val validate_dep_pair_with_refinement (#t1:Type) (#[@@@erasable] p1:parser k1 t1) (#[@@@erasable] inv1:slice_inv) + (#[@@@erasable] disj1:disjointness_pre) (#[@@@erasable] l1:eloc) - (v1:validate_with_action_t p1 inv1 l1 true) + (v1:validate_with_action_t p1 inv1 disj1 l1 true) (r1: leaf_reader p1) (f: t1 -> bool) (#nz2:_) @@ -278,13 +378,16 @@ val validate_dep_pair_with_refinement (#[@@@erasable] t2:refine _ f -> Type) (#[@@@erasable] p2:(x:refine _ f -> parser k2 (t2 x))) (#[@@@erasable] inv2:slice_inv) + (#[@@@erasable] disj2:disjointness_pre) (#[@@@erasable] l2:eloc) (#allow_reading2:bool) - (v2:(x:refine _ f -> validate_with_action_t (p2 x) inv2 l2 allow_reading2)) - : validate_with_action_t ((p1 `parse_filter` f) `parse_dep_pair` p2) - (conj_inv inv1 inv2) - (l1 `eloc_union` l2) - false + (v2:(x:refine _ f -> validate_with_action_t (p2 x) inv2 disj2 l2 allow_reading2)) + : validate_with_action_t + ((p1 `parse_filter` f) `parse_dep_pair` p2) + (conj_inv inv1 inv2) + (conj_disjointness disj1 disj2) + (l1 `eloc_union` l2) + false inline_for_extraction noextract val validate_filter @@ -294,13 +397,14 @@ val validate_filter (#t:Type) (#[@@@erasable] p:parser k t) (#[@@@erasable] inv:slice_inv) + (#[@@@erasable] disj:disjointness_pre) (#[@@@erasable] l:eloc) - (v:validate_with_action_t p inv l true) + (v:validate_with_action_t p inv disj l true) (r:leaf_reader p) (f:t -> bool) (cr:string) (cf:string) - : validate_with_action_t (p `parse_filter` f) inv l false + : validate_with_action_t (p `parse_filter` f) inv disj l false inline_for_extraction noextract val validate_filter_with_action @@ -310,17 +414,24 @@ val validate_filter_with_action (#t:Type) (#[@@@erasable] p:parser k t) (#[@@@erasable] inv:slice_inv) + (#[@@@erasable] disj:disjointness_pre) (#[@@@erasable] l:eloc) - (v:validate_with_action_t p inv l true) + (v:validate_with_action_t p inv disj l true) (r:leaf_reader p) (f:t -> bool) (cr:string) (cf:string) (#b:bool) (#[@@@erasable] inva:slice_inv) + (#[@@@erasable] disja:disjointness_pre) (#[@@@erasable] la:eloc) - (a: t -> action (p `parse_filter` f) inva la b bool) - : validate_with_action_t #nz (p `parse_filter` f) (conj_inv inv inva) (eloc_union l la) false + (a: t -> action inva disja la b bool) + : validate_with_action_t #nz + (p `parse_filter` f) + (conj_inv inv inva) + (conj_disjointness disj disja) + (eloc_union l la) + false inline_for_extraction noextract val validate_with_dep_action @@ -330,14 +441,21 @@ val validate_with_dep_action (#t:Type) (#[@@@erasable] p:parser k t) (#[@@@erasable] inv:slice_inv) + (#[@@@erasable] disj:disjointness_pre) (#[@@@erasable] l:eloc) - (v:validate_with_action_t p inv l true) + (v:validate_with_action_t p inv disj l true) (r:leaf_reader p) (#b:bool) (#[@@@erasable] inva:slice_inv) + (#[@@@erasable] disja:disjointness_pre) (#[@@@erasable] la:eloc) - (a: t -> action p inva la b bool) - : validate_with_action_t #nz p (conj_inv inv inva) (eloc_union l la) false + (a: t -> action inva disja la b bool) + : validate_with_action_t #nz + p + (conj_inv inv inva) + (conj_disjointness disj disja) + (eloc_union l la) + false inline_for_extraction noextract val validate_weaken_left @@ -347,13 +465,14 @@ val validate_weaken_left (#[@@@erasable] t:Type) (#[@@@erasable] p:parser k t) (#[@@@erasable] inv:slice_inv) + (#[@@@erasable] disj:disjointness_pre) (#[@@@erasable] l:eloc) (#allow_reading:bool) - (v:validate_with_action_t p inv l allow_reading) + (v:validate_with_action_t p inv disj l allow_reading) (#nz':_) (#wk': _) (k':parser_kind nz' wk') - : validate_with_action_t (parse_weaken_left p k') inv l allow_reading + : validate_with_action_t (parse_weaken_left p k') inv disj l allow_reading inline_for_extraction noextract val validate_weaken_right @@ -363,18 +482,19 @@ val validate_weaken_right (#[@@@erasable] t:Type) (#[@@@erasable] p:parser k t) (#[@@@erasable] inv:slice_inv) + (#[@@@erasable] disj:disjointness_pre) (#[@@@erasable] l:eloc) (#allow_reading:bool) - (v:validate_with_action_t p inv l allow_reading) + (v:validate_with_action_t p inv disj l allow_reading) (#nz':_) (#wk': _) (k':parser_kind nz' wk') - : validate_with_action_t (parse_weaken_right p k') inv l allow_reading + : validate_with_action_t (parse_weaken_right p k') inv disj l allow_reading inline_for_extraction noextract val validate_impos (_:unit) - : validate_with_action_t (parse_impos ()) true_inv eloc_none true + : validate_with_action_t (parse_impos ()) true_inv disjointness_trivial eloc_none true noextract inline_for_extraction val validate_ite @@ -385,19 +505,23 @@ val validate_ite (#[@@@erasable] a:squash e -> Type) (#[@@@erasable] b:squash (not e) -> Type) (#[@@@erasable] inv1:slice_inv) + (#[@@@erasable] disj1:disjointness_pre) (#[@@@erasable] l1:eloc) (#ar1:_) (#[@@@erasable] inv2:slice_inv) + (#[@@@erasable] disj2:disjointness_pre) (#[@@@erasable] l2:eloc) (#ar2:_) ([@@@erasable] p1:squash e -> parser k (a())) - (v1:(squash e -> validate_with_action_t (p1()) inv1 l1 ar1)) + (v1:(squash e -> validate_with_action_t (p1()) inv1 disj1 l1 ar1)) ([@@@erasable] p2:squash (not e) -> parser k (b())) - (v2:(squash (not e) -> validate_with_action_t (p2()) inv2 l2 ar2)) - : validate_with_action_t (parse_ite e p1 p2) - (conj_inv inv1 inv2) - (l1 `eloc_union` l2) - false + (v2:(squash (not e) -> validate_with_action_t (p2()) inv2 disj2 l2 ar2)) + : validate_with_action_t + (parse_ite e p1 p2) + (conj_inv inv1 inv2) + (conj_disjointness disj1 disj2) + (l1 `eloc_union` l2) + false noextract inline_for_extraction val validate_nlist @@ -407,10 +531,11 @@ val validate_nlist (#[@@@erasable] t:Type) (#[@@@erasable] p:parser k t) (#[@@@erasable] inv:slice_inv) + (#[@@@erasable] disj:disjointness_pre) (#[@@@erasable] l:eloc) (#allow_reading:bool) - (v: validate_with_action_t p inv l allow_reading) -: validate_with_action_t (parse_nlist n p) inv l false + (v: validate_with_action_t p inv disj l allow_reading) +: validate_with_action_t (parse_nlist n p) inv disj l false noextract inline_for_extraction val validate_nlist_constant_size_without_actions @@ -421,10 +546,11 @@ val validate_nlist_constant_size_without_actions (#[@@@erasable] t:Type) (#[@@@erasable] p:parser k t) (#[@@@erasable] inv:slice_inv) + (#[@@@erasable] disj:disjointness_pre) (#[@@@erasable] l:eloc) (#allow_reading:bool) - (v: validate_with_action_t p inv l allow_reading) -: Tot (validate_with_action_t (parse_nlist n p) inv l false) + (v: validate_with_action_t p inv disj l allow_reading) +: Tot (validate_with_action_t (parse_nlist n p) inv disj l false) noextract inline_for_extraction val validate_t_at_most @@ -435,10 +561,11 @@ val validate_t_at_most (#[@@@erasable] t:Type) (#[@@@erasable] p:parser k t) (#[@@@erasable] inv:slice_inv) + (#[@@@erasable] disj:disjointness_pre) (#[@@@erasable] l:eloc) (#ar:_) - (v:validate_with_action_t p inv l ar) - : Tot (validate_with_action_t (parse_t_at_most n p) inv l false) + (v:validate_with_action_t p inv disj l ar) + : Tot (validate_with_action_t (parse_t_at_most n p) inv disj l false) noextract inline_for_extraction val validate_t_exact @@ -449,10 +576,11 @@ val validate_t_exact (#[@@@erasable] t:Type) (#[@@@erasable] p:parser k t) (#[@@@erasable] inv:slice_inv) + (#[@@@erasable] disj:disjointness_pre) (#[@@@erasable] l:eloc) (#ar:_) - (v:validate_with_action_t p inv l ar) - : Tot (validate_with_action_t (parse_t_exact n p) inv l false) + (v:validate_with_action_t p inv disj l ar) + : Tot (validate_with_action_t (parse_t_exact n p) inv disj l false) inline_for_extraction noextract val validate_with_comment @@ -463,10 +591,11 @@ val validate_with_comment (#[@@@erasable] t:Type) (#[@@@erasable] p:parser k t) (#[@@@erasable] inv:slice_inv) + (#[@@@erasable] disj:disjointness_pre) (#[@@@erasable] l:eloc) (#allow_reading:bool) - (v:validate_with_action_t p inv l allow_reading) - : validate_with_action_t p inv l allow_reading + (v:validate_with_action_t p inv disj l allow_reading) + : validate_with_action_t p inv disj l allow_reading inline_for_extraction noextract val validate_weaken_inv_loc @@ -476,12 +605,14 @@ val validate_weaken_inv_loc (#[@@@erasable] t:Type) (#[@@@erasable] p:parser k t) (#[@@@erasable] inv:slice_inv) + (#[@@@erasable] disj:disjointness_pre) (#[@@@erasable] l:eloc) (#allow_reading:bool) ([@@@erasable] inv':slice_inv{inv' `inv_implies` inv}) + ([@@@erasable] disj':disjointness_pre { disj' `imp_disjointness` disj }) ([@@@erasable] l':eloc{l' `eloc_includes` l}) - (v:validate_with_action_t p inv l allow_reading) - : Tot (validate_with_action_t p inv' l' allow_reading) + (v:validate_with_action_t p inv disj l allow_reading) + : Tot (validate_with_action_t p inv' disj' l' allow_reading) inline_for_extraction noextract val read_filter @@ -499,7 +630,7 @@ val read_impos inline_for_extraction let validator #nz #wk (#k:parser_kind nz wk) (#t:Type) (p:parser k t) - = validate_with_action_t p true_inv eloc_none true + = validate_with_action_t p true_inv disjointness_trivial eloc_none true inline_for_extraction noextract val validate____UINT8 @@ -585,152 +716,130 @@ val validate_string (v: validator p) (r: leaf_reader p) (terminator: t) - : Tot (validate_with_action_t (parse_string p terminator) true_inv eloc_none false) + : Tot (validate_with_action_t (parse_string p terminator) true_inv disjointness_trivial eloc_none false) inline_for_extraction noextract val validate_all_bytes - : validate_with_action_t parse_all_bytes true_inv eloc_none false // could be true + : validate_with_action_t parse_all_bytes true_inv disjointness_trivial eloc_none false // could be true inline_for_extraction noextract val validate_all_zeros - : validate_with_action_t parse_all_zeros true_inv eloc_none false + : validate_with_action_t parse_all_zeros true_inv disjointness_trivial eloc_none false //////////////////////////////////////////////////////////////////////////////// noextract inline_for_extraction val action_return - (#nz:_) - (#wk: _) - (#k:parser_kind nz wk) - (#[@@@erasable] t:Type) - (#[@@@erasable] p:parser k t) (#a:Type) (x:a) - : action p true_inv eloc_none false a + : action true_inv disjointness_trivial eloc_none false a noextract inline_for_extraction val action_bind (name: string) - (#nz:_) - (#wk: _) - (#k:parser_kind nz wk) - (#[@@@erasable] t:Type) - (#[@@@erasable] p:parser k t) (#[@@@erasable] invf:slice_inv) + (#[@@@erasable] disjf:disjointness_pre) (#[@@@erasable] lf:eloc) (#bf:_) (#a:Type) - (f: action p invf lf bf a) + (f: action invf disjf lf bf a) (#[@@@erasable] invg:slice_inv) + (#[@@@erasable] disjg:disjointness_pre) (#[@@@erasable] lg:eloc) (#bg:_) (#b:Type) - (g: (a -> action p invg lg bg b)) - : Tot (action p (conj_inv invf invg) (eloc_union lf lg) (bf || bg) b) + (g: (a -> action invg disjg lg bg b)) + : action + (conj_inv invf invg) + (conj_disjointness disjf disjg) + (eloc_union lf lg) + (bf || bg) + b noextract inline_for_extraction val action_seq - (#nz:_) - (#wk: _) - (#k:parser_kind nz wk) - (#[@@@erasable] t:Type) - (#[@@@erasable] p:parser k t) (#[@@@erasable] invf:slice_inv) + (#[@@@erasable] disjf:disjointness_pre) (#[@@@erasable] lf:eloc) (#bf:_) (#a:Type) - (f: action p invf lf bf a) + (f: action invf disjf lf bf a) (#[@@@erasable] invg:slice_inv) + (#[@@@erasable] disjg:disjointness_pre) (#[@@@erasable] lg:eloc) (#bg:_) (#b:Type) - (g: action p invg lg bg b) - : Tot (action p (conj_inv invf invg) (eloc_union lf lg) (bf || bg) b) + (g: action invg disjg lg bg b) + : action + (conj_inv invf invg) + (conj_disjointness disjf disjg) + (eloc_union lf lg) + (bf || bg) + b noextract inline_for_extraction val action_ite - (#nz:_) - (#wk: _) - (#k:parser_kind nz wk) - (#[@@@erasable] t:Type) - (#[@@@erasable] p:parser k t) (#[@@@erasable] invf:slice_inv) + (#[@@@erasable] disjf:disjointness_pre) (#[@@@erasable] lf:eloc) (guard:bool) (#bf:_) (#a:Type) - (then_: squash guard -> action p invf lf bf a) + (then_: squash guard -> action invf disjf lf bf a) (#[@@@erasable] invg:slice_inv) + (#[@@@erasable] disjg:disjointness_pre) (#[@@@erasable] lg:eloc) (#bg:_) - (else_: squash (not guard) -> action p invg lg bg a) - : action p (conj_inv invf invg) (eloc_union lf lg) (bf || bg) a + (else_: squash (not guard) -> action invg disjg lg bg a) + : action + (conj_inv invf invg) + (conj_disjointness disjf disjg) + (eloc_union lf lg) + (bf || bg) + a noextract inline_for_extraction -val action_abort - (#nz:_) - (#wk: _) - (#k:parser_kind nz wk) - (#[@@@erasable] t:Type) - (#[@@@erasable] p:parser k t) - : action p true_inv eloc_none false bool +val action_abort + : action true_inv disjointness_trivial eloc_none false bool noextract inline_for_extraction val action_field_pos_64 - (#nz:_) - (#wk: _) - (#k:parser_kind nz wk) - (#[@@@erasable] t:Type) - (#[@@@erasable] p:parser k t) - (u:unit) - : action p true_inv eloc_none false U64.t + : action true_inv disjointness_trivial eloc_none false U64.t noextract inline_for_extraction val action_deref - (#nz:_) - (#wk: _) - (#k:parser_kind nz wk) - (#[@@@erasable] t:Type) - (#[@@@erasable] p:parser k t) (#a:_) (x:bpointer a) - : action p (ptr_inv x) eloc_none false a + : action (ptr_inv x) disjointness_trivial eloc_none false a noextract inline_for_extraction val action_assignment - (#nz:_) - (#wk: _) - (#k:parser_kind nz wk) - (#[@@@erasable] t:Type) - (#[@@@erasable] p:parser k t) (#a:_) (x:bpointer a) (v:a) - : action p (ptr_inv x) (ptr_loc x) false unit + : action (ptr_inv x) disjointness_trivial (ptr_loc x) false unit noextract inline_for_extraction val action_weaken - (#nz:_) - (#wk: _) - (#k:parser_kind nz wk) - (#[@@@erasable] t:Type) - (#[@@@erasable] p:parser k t) (#[@@@erasable] inv:slice_inv) + (#[@@@erasable] disj:disjointness_pre) (#[@@@erasable] l:eloc) (#b:_) (#a:_) - (act:action p inv l b a) - (#[@@@erasable] inv':slice_inv{inv' `inv_implies` inv}) (#l':eloc{l' `eloc_includes` l}) - : action p inv' l' b a + (act:action inv disj l b a) + (#[@@@erasable] inv':slice_inv{inv' `inv_implies` inv}) + (#[@@@erasable] disj':disjointness_pre { disj' `imp_disjointness` disj }) + (#l':eloc{l' `eloc_includes` l}) + : action inv' disj' l' b a inline_for_extraction noextract @@ -739,9 +848,34 @@ val external_action (l: eloc) : Tot Type0 noextract inline_for_extraction val mk_external_action - (#nz:_) (#wk:_) (#k:parser_kind nz wk) (#t:Type) (#p:parser k t) (#l:eloc) ($f: external_action l) - : action p true_inv l false unit + : action true_inv disjointness_trivial l false unit + +val copy_buffer_inv (x:CP.copy_buffer_t) : slice_inv +val copy_buffer_loc (x:CP.copy_buffer_t) : eloc + +inline_for_extraction +noextract +val probe_then_validate + (#nz:bool) + (#wk: _) + (#k:parser_kind nz wk) + (#t:Type) + (#p:parser k t) + (#inv:slice_inv) + (#disj:disjointness_pre) + (#l:eloc) + (#allow_reading:bool) + (v:validate_with_action_t p inv disj l allow_reading) + (src:U64.t) + (len:U64.t) + (dest:CP.copy_buffer_t) + (probe:CP.probe_fn) + : action (conj_inv inv (copy_buffer_inv dest)) + (conj_disjointness disj (disjoint (copy_buffer_loc dest) l)) + (eloc_union l (copy_buffer_loc dest)) + true + bool // Some actions are valid only for specific backends (buffer, extern, etc.) diff --git a/src/3d/prelude/EverParse3d.AppCtxt.fsti b/src/3d/prelude/EverParse3d.AppCtxt.fsti new file mode 100644 index 000000000..7f8220233 --- /dev/null +++ b/src/3d/prelude/EverParse3d.AppCtxt.fsti @@ -0,0 +1,16 @@ +module EverParse3d.AppCtxt +module B = LowStar.Buffer +module HS = FStar.HyperStack +module U64 = FStar.UInt64 +module U8 = FStar.UInt8 +open LowStar.Buffer +open FStar.HyperStack.ST +val region : HS.rid +let app_ctxt = x:B.pointer U8.t { B.frameOf x == region } +let loc_of (x:app_ctxt) : GTot B.loc = B.loc_buffer x +let properties (x:app_ctxt) + : Lemma ( + B.loc_region_only true region `loc_includes` loc_of x /\ + B.address_liveness_insensitive_locs `B.loc_includes` loc_of x + ) + = () diff --git a/src/3d/prelude/EverParse3d.CopyBuffer.fsti b/src/3d/prelude/EverParse3d.CopyBuffer.fsti new file mode 100644 index 000000000..6123aa3c9 --- /dev/null +++ b/src/3d/prelude/EverParse3d.CopyBuffer.fsti @@ -0,0 +1,52 @@ +module EverParse3d.CopyBuffer +module AppCtxt = EverParse3d.AppCtxt +module I = EverParse3d.InputStream.All +module B = LowStar.Buffer +module HS = FStar.HyperStack +module U64 = FStar.UInt64 +open LowStar.Buffer +open FStar.HyperStack.ST +val region : HS.rid + +val copy_buffer_t : Type0 + +val stream_of : copy_buffer_t -> I.t +val stream_len (c:copy_buffer_t) : I.tlen (stream_of c) + + +let loc_of (x:copy_buffer_t) : GTot B.loc = + I.footprint (stream_of x) + +let inv (x:copy_buffer_t) (h:HS.mem) = I.live (stream_of x) h + +let liveness_preserved (x:copy_buffer_t) = + let sl = stream_of x in + forall l h0 h1. {:pattern (modifies l h0 h1)} + (I.live sl h0 /\ + B.modifies l h0 h1 /\ + address_liveness_insensitive_locs `loc_includes` l) ==> + I.live sl h1 + +val properties (x:copy_buffer_t) + : Lemma ( + liveness_preserved x /\ + B.loc_region_only true region `loc_includes` loc_of x /\ + region `HS.disjoint` AppCtxt.region + ) + + +let probe_fn = src:U64.t -> len:U64.t -> dest:copy_buffer_t -> + Stack bool + (fun h0 -> + I.live (stream_of dest) h0) + (fun h0 b h1 -> + let sl = stream_of dest in + I.live sl h1 /\ + (if b + then ( + Seq.length (I.get_read sl h1) == 0 /\ + modifies (I.footprint sl) h0 h1 + ) + else ( + h0 == h1 + ))) \ No newline at end of file diff --git a/src/3d/prelude/EverParse3d.Interpreter.fst b/src/3d/prelude/EverParse3d.Interpreter.fst index bb8fea570..bcd38ccd5 100644 --- a/src/3d/prelude/EverParse3d.Interpreter.fst +++ b/src/3d/prelude/EverParse3d.Interpreter.fst @@ -21,8 +21,12 @@ module U64 = FStar.UInt64 module A = EverParse3d.Actions.All module P = EverParse3d.Prelude module T = FStar.Tactics +module CP = EverParse3d.CopyBuffer open FStar.List.Tot +inline_for_extraction +noextract +let ___EVERPARSE_COPY_BUFFER_T = CP.copy_buffer_t (* This module defines a strongly typed abstract syntax for an intermediate representation of 3D programs. This is the type `typ`. @@ -167,7 +171,12 @@ let itype_as_leaf_reader (i:itype { allow_reader_of_itype i }) -- Notice that the type shows that it is related to the parser *) [@@specialize] let itype_as_validator (i:itype) - : A.validate_with_action_t (itype_as_parser i) A.true_inv A.eloc_none (allow_reader_of_itype i) + : A.validate_with_action_t + (itype_as_parser i) + A.true_inv + A.disjointness_trivial + A.eloc_none + (allow_reader_of_itype i) = match i with | UInt8 -> A.validate____UINT8 | UInt16 -> A.validate____UINT16 @@ -199,6 +208,66 @@ let leaf_reader #nz #wk (#k: P.parser_kind nz wk) #t (p:P.parser k t) (* Now, we can define the type of an environment *) module T = FStar.Tactics +[@@erasable] +noeq +type index (a:Type) = + | Trivial : index a + | NonTrivial : a -> index a + +[@@specialize] +let join_index (j:'a -> 'a -> 'a) (i0 i1:index 'a) +: index 'a += match i0 with + | Trivial -> i1 + | _ -> ( + match i1 with + | Trivial -> i0 + | NonTrivial i1 -> + let NonTrivial i0 = i0 in + NonTrivial (j i0 i1) + ) +[@@specialize] +let interp_index (triv:'a) (i:index 'a) +: GTot 'a += match i with + | Trivial -> triv + | NonTrivial i -> i + + +let inv_index = index A.slice_inv +[@@specialize] +let inv_none : inv_index = Trivial +[@@specialize] +let join_inv = join_index A.conj_inv +[@@specialize] +let interp_inv = interp_index A.true_inv + +let loc_index = index A.eloc +[@@specialize] +let loc_none : loc_index = Trivial +[@@specialize] +let join_loc = join_index A.eloc_union +[@@specialize] +let interp_loc = interp_index A.eloc_none + +let disj_index = index A.disjointness_pre +[@@specialize] +let disj_none : disj_index = Trivial +[@@specialize] +let join_disj = join_index A.conj_disjointness +[@@specialize] +let interp_disj = interp_index A.disjointness_trivial +[@@specialize] +let disjoint (e1 e2:loc_index) + : disj_index + = match e1, e2 with + | Trivial, _ + | _, Trivial -> disj_none + | NonTrivial e1, NonTrivial e2 -> NonTrivial (A.disjoint e1 e2) + + +(* A context is a list of bindings, where each binding is a pair of a + name and a denotation of the name. *) (* global_binding: Represents the lifting of a fully applied a shallow F* @@ -211,9 +280,11 @@ type global_binding = { parser_weak_kind: P.weak_kind; parser_kind: P.parser_kind parser_kind_nz parser_weak_kind; //Memory invariant of any actions it contains - inv:A.slice_inv; + inv:inv_index; + //Disjointness precondition + disj:disj_index; //Write footprint of any of its actions - loc:A.eloc; + loc:loc_index; //Its type denotation p_t : Type0; //Its parser denotation @@ -221,7 +292,12 @@ type global_binding = { //Whether the type can be read -- to avoid double fetches p_reader: option (leaf_reader p_p); //Its validate-with-action denotationa - p_v : A.validate_with_action_t p_p inv loc (Some? p_reader); + p_v : A.validate_with_action_t + p_p + (interp_inv inv) + (interp_disj disj) + (interp_loc loc) + (Some? p_reader); } let projector_names : list string = [ @@ -229,6 +305,7 @@ let projector_names : list string = [ `%Mkglobal_binding?.parser_weak_kind; `%Mkglobal_binding?.parser_kind; `%Mkglobal_binding?.inv; + `%Mkglobal_binding?.disj; `%Mkglobal_binding?.loc; `%Mkglobal_binding?.p_t; `%Mkglobal_binding?.p_p; @@ -240,6 +317,7 @@ let nz_of_binding = Mkglobal_binding?.parser_kind_nz let wk_of_binding = Mkglobal_binding?.parser_weak_kind let pk_of_binding = Mkglobal_binding?.parser_kind let inv_of_binding = Mkglobal_binding?.inv +let disj_of_bindng = Mkglobal_binding?.disj let loc_of_binding = Mkglobal_binding?.loc let type_of_binding = Mkglobal_binding?.p_t let parser_of_binding = Mkglobal_binding?.p_p @@ -258,28 +336,168 @@ let get_leaf_reader (r:reader_binding) : leaf_reader (parser_of_binding r) = Some?.v (leaf_reader_of_binding r) -(** Now we define the AST of 3D programs *) + +(* The main type of 3D types. Some points to note: + + - The indexing structure determines the types of the + parser/validator etc. of its denotation + + - All top-level names mentioned in a typ must be bound in the + context. + + - Constructs that bind local names are represented using F* + functions that abstract over denotations of the underlying types. + + - Some elements of the source programs are "pre-denoted". Notably, + every refinement formula is represented in this AST already as a + boolean function, rather than in some embedded language of + expressions. This is because expressions are not necessarily + well-formed by syntax alone---they may give rise to verification + conditions when using bounded arithmetic functions. So, it's the + obligation of the `typ` generator (i.e., the 3D frontend) to + produce boolean functions for those expressions that can be + verified natively by F* for type correctness. +*) + +noeq +type dtyp + : #nz:bool -> #wk:P.weak_kind -> + P.parser_kind nz wk -> + has_reader:bool -> + inv_index -> + disj_index -> + loc_index -> + Type = + | DT_IType: + i:itype -> + dtyp (parser_kind_of_itype i) + (allow_reader_of_itype i) + inv_none disj_none loc_none + + | DT_App: + (* We give explicit names to the indices rather than + projecting them as a small optimization for the reduction + machinery ... it's no longer clear that the speedup is significant *) + #nz:bool -> + #wk:P.weak_kind -> + pk:P.parser_kind nz wk -> + hr:bool -> + inv:inv_index -> + disj:disj_index -> + loc:loc_index -> + x:global_binding -> + _:squash (nz == nz_of_binding x /\ + wk == wk_of_binding x /\ + pk == pk_of_binding x /\ + hr == has_reader x /\ + inv == inv_of_binding x /\ + disj == disj_of_bindng x /\ + loc == loc_of_binding x) -> + dtyp #nz #wk pk hr inv disj loc + +[@@specialize] +let dtyp_as_type #nz #wk (#pk:P.parser_kind nz wk) #hr #i #disj #l + (d:dtyp pk hr i disj l) + : Type + = match d with + | DT_IType i -> + itype_as_type i + + | DT_App _ _ _ _ _ b _ -> + type_of_binding b + +let dtyp_as_eqtype_lemma #nz #wk (#pk:P.parser_kind nz wk) #i #disj #l + (d:dtyp pk true i disj l) + : Lemma + (ensures hasEq (dtyp_as_type d)) + [SMTPat (hasEq (dtyp_as_type d))] + = match d with + | DT_IType i -> + () + + | DT_App _ _ _ _ _ b _ -> + let (| _, _ |) = get_leaf_reader b in () + + +let dtyp_as_parser #nz #wk (#pk:P.parser_kind nz wk) #hr #i #disj #l + (d:dtyp pk hr i disj l) + : P.parser pk (dtyp_as_type d) + = match d returns Tot (P.parser pk (dtyp_as_type d)) with + | DT_IType i -> + itype_as_parser i + + | DT_App _ _ _ _ _ b _ -> + parser_of_binding b + +[@@specialize] +let dtyp_as_validator #nz #wk (#pk:P.parser_kind nz wk) + (#hr:_) + (#[@@@erasable] i:inv_index) + (#[@@@erasable] disj:disj_index) + (#[@@@erasable] l:loc_index) + (d:dtyp pk hr i disj l) + : A.validate_with_action_t #nz #wk #pk #(dtyp_as_type d) + (dtyp_as_parser d) + (interp_inv i) + (interp_disj disj) + (interp_loc l) + hr + = match d + returns + A.validate_with_action_t #nz #wk #pk #(dtyp_as_type d) + (dtyp_as_parser d) + (interp_inv i) + (interp_disj disj) + (interp_loc l) + hr + with + | DT_IType i -> + itype_as_validator i + + | DT_App _ _ _ _ _ b _ -> + // assert_norm (dtyp_as_type (DT_App_Alt ps b args) == (type_of_binding_alt (apply_arrow b args))); + // assert_norm (dtyp_as_parser (DT_App_Alt ps b args) == parser_of_binding_alt (apply_arrow b args)); + validator_of_binding b + + +[@@specialize] +let dtyp_as_leaf_reader #nz (#pk:P.parser_kind nz P.WeakKindStrongPrefix) + (#[@@@erasable] i:inv_index) + (#[@@@erasable] disj:disj_index) + (#[@@@erasable] l:loc_index) + (d:dtyp pk true i disj l) + : A.leaf_reader (dtyp_as_parser d) + = match d with + | DT_IType i -> + itype_as_leaf_reader i + + | DT_App _ _ _ _ _ b _ -> + let (| _, lr |) = get_leaf_reader b in + lr + +(** Actions *) let action_binding - (inv:A.slice_inv) - (l:A.eloc) + (inv:inv_index) + (l:loc_index) (on_success:bool) (a:Type) - : Type u#1 //in Universe 1 because it is polymorphic in t - = (#nz:bool) -> - (#wk:P.weak_kind) -> - (#k:P.parser_kind nz wk) -> - (#t:Type u#0) -> - (p:P.parser k t) -> - A.action p inv l on_success a + : Type u#0 + = A.action (interp_inv inv) A.disjointness_trivial (interp_loc l) on_success a + +inline_for_extraction +let extern_action (l:loc_index) = A.external_action (interp_loc l) + +inline_for_extraction +let mk_extern_action (#l:loc_index) ($f:extern_action l) + = A.mk_external_action f [@@specialize] let mk_action_binding - (#l:A.eloc) - ($f: A.external_action l) - : action_binding A.true_inv l false unit - = fun (#nz:_) (#wk:_) (#k:P.parser_kind nz wk) (#t:Type u#0) (p:P.parser k t) -> - A.mk_external_action f + (#l:loc_index) + ($f:extern_action l) + : action_binding inv_none l false unit + = mk_extern_action f (* The type of atomic actions. @@ -304,74 +522,90 @@ let mk_action_binding *) noeq type atomic_action - : A.slice_inv -> A.eloc -> bool -> Type0 -> Type u#1 = + : inv_index -> disj_index -> loc_index -> bool -> Type0 -> Type u#1 = | Action_return: #a:Type0 -> x:a -> - atomic_action A.true_inv A.eloc_none false a + atomic_action inv_none disj_none loc_none false a | Action_abort: - atomic_action A.true_inv A.eloc_none false bool + atomic_action inv_none disj_none loc_none false bool | Action_field_pos_64: - atomic_action A.true_inv A.eloc_none false U64.t + atomic_action inv_none disj_none loc_none false U64.t | Action_field_pos_32: squash (EverParse3d.Actions.BackendFlag.backend_flag == A.BackendFlagBuffer) -> - atomic_action A.true_inv A.eloc_none false U32.t + atomic_action inv_none disj_none loc_none false U32.t | Action_field_ptr: squash (EverParse3d.Actions.BackendFlag.backend_flag == A.BackendFlagBuffer) -> - atomic_action A.true_inv A.eloc_none true A.___PUINT8 + atomic_action inv_none disj_none loc_none true A.___PUINT8 | Action_field_ptr_after: squash (EverParse3d.Actions.BackendFlag.backend_flag == A.BackendFlagExtern) -> (sz: FStar.UInt64.t) -> write_to: A.bpointer A.___PUINT8 -> - atomic_action (A.ptr_inv write_to) (A.ptr_loc write_to) false bool + atomic_action (NonTrivial (A.ptr_inv write_to)) disj_none (NonTrivial (A.ptr_loc write_to)) false bool | Action_field_ptr_after_with_setter: squash (EverParse3d.Actions.BackendFlag.backend_flag == A.BackendFlagExtern) -> - (sz: FStar.UInt64.t) -> - (#out_loc: A.eloc) -> - write_to: (A.___PUINT8 -> Tot (A.external_action out_loc)) -> - atomic_action A.true_inv out_loc false bool + sz: FStar.UInt64.t -> + #out_loc:loc_index -> + write_to: (A.___PUINT8 -> Tot (extern_action out_loc)) -> + atomic_action inv_none disj_none out_loc false bool - | Action_deref: + | Action_deref: #a:Type0 -> x:A.bpointer a -> - atomic_action (A.ptr_inv x) A.eloc_none false a + atomic_action (NonTrivial (A.ptr_inv x)) disj_none loc_none false a | Action_assignment: #a:Type0 -> x:A.bpointer a -> rhs:a -> - atomic_action (A.ptr_inv x) (A.ptr_loc x) false unit + atomic_action (NonTrivial (A.ptr_inv x)) disj_none (NonTrivial (A.ptr_loc x)) false unit | Action_call: - #inv:A.slice_inv -> - #loc:A.eloc -> + #inv:inv_index -> + #loc:loc_index -> #b:bool -> #t:Type0 -> action_binding inv loc b t -> - atomic_action inv loc b t + atomic_action inv disj_none loc b t + + | Action_probe_then_validate: + #nz:bool -> + #wk:_ -> + #k:P.parser_kind nz wk -> + #has_reader:bool -> + #inv:inv_index -> + #disj:disj_index -> + #l:loc_index -> + dt:dtyp k has_reader inv disj l -> + src:U64.t -> + len:U64.t -> + dest:CP.copy_buffer_t -> + probe:CP.probe_fn -> + atomic_action (join_inv inv (NonTrivial (A.copy_buffer_inv dest))) + (join_disj disj (disjoint (NonTrivial (A.copy_buffer_loc dest)) l)) + (join_loc l (NonTrivial (A.copy_buffer_loc dest))) + true bool + (* Denotation of atomic_actions as A.action *) [@@specialize] let atomic_action_as_action - (#nz #wk:_) - (#pk:P.parser_kind nz wk) (#pt:Type) - (#i #l #b #t:_) - (p:P.parser pk pt) - (a:atomic_action i l b t) - : Tot (A.action p i l b t) + (#i #d #l #b #t:_) + (a:atomic_action i d l b t) + : Tot (A.action (interp_inv i) (interp_disj d) (interp_loc l) b t) = match a with | Action_return x -> A.action_return x | Action_abort -> A.action_abort | Action_field_pos_64 -> - A.action_field_pos_64 () + A.action_field_pos_64 | Action_field_pos_32 sq -> A.action_field_pos_32 sq | Action_field_ptr sq -> @@ -385,7 +619,11 @@ let atomic_action_as_action | Action_assignment x rhs -> A.action_assignment x rhs | Action_call c -> - c p + c + | Action_probe_then_validate #nz #wk #k #_hr #inv #l dt src len dest probe -> + A.index_equations(); + let v = dtyp_as_validator dt in + A.probe_then_validate v src len dest probe (* A sub-language of monadic actions. @@ -394,297 +632,147 @@ let atomic_action_as_action *) noeq type action - : A.slice_inv -> A.eloc -> bool -> Type0 -> Type u#1 = + : inv_index -> disj_index -> loc_index -> bool -> Type0 -> Type u#1 = | Atomic_action: - #i:_ -> #l:_ -> #b:_ -> #t:_ -> - atomic_action i l b t -> - action i l b t + #i:_ -> #d:_ -> #l:_ -> #b:_ -> #t:_ -> + atomic_action i d l b t -> + action i d l b t | Action_seq: - #i0:_ -> #l0:_ -> #b0:_ -> hd:atomic_action i0 l0 b0 unit -> - #i1:_ -> #l1:_ -> #b1:_ -> #t:_ -> tl:action i1 l1 b1 t -> - action (A.conj_inv i0 i1) (A.eloc_union l0 l1) (b0 || b1) t + #i0:_ -> #l0:_ -> #b0:_ -> hd:atomic_action i0 disj_none l0 b0 unit -> + #i1:_ -> #l1:_ -> #b1:_ -> #t:_ -> tl:action i1 disj_none l1 b1 t -> + action (join_inv i0 i1) disj_none (join_loc l0 l1) (b0 || b1) t | Action_ite : hd:bool -> - #i0:_ -> #l0:_ -> #b0:_ -> #t:_ -> then_:(_:squash hd -> action i0 l0 b0 t) -> - #i1:_ -> #l1:_ -> #b1:_ -> else_:(_:squash (not hd) -> action i1 l1 b1 t) -> - action (A.conj_inv i0 i1) (A.eloc_union l0 l1) (b0 || b1) t + #i0:_ -> #l0:_ -> #b0:_ -> #t:_ -> then_:(_:squash hd -> action i0 disj_none l0 b0 t) -> + #i1:_ -> #l1:_ -> #b1:_ -> else_:(_:squash (not hd) -> action i1 disj_none l1 b1 t) -> + action (join_inv i0 i1) disj_none (join_loc l0 l1) (b0 || b1) t | Action_let: - #i0:_ -> #l0:_ -> #b0:_ -> #t0:_ -> head:atomic_action i0 l0 b0 t0 -> - #i1:_ -> #l1:_ -> #b1:_ -> #t1:_ -> k:(t0 -> action i1 l1 b1 t1) -> - action (A.conj_inv i0 i1) (A.eloc_union l0 l1) (b0 || b1) t1 + #i0:_ -> #l0:_ -> #b0:_ -> #t0:_ -> head:atomic_action i0 disj_none l0 b0 t0 -> + #i1:_ -> #l1:_ -> #b1:_ -> #t1:_ -> k:(t0 -> action i1 disj_none l1 b1 t1) -> + action (join_inv i0 i1) disj_none (join_loc l0 l1) (b0 || b1) t1 | Action_act: - #i0:_ -> #l0:_ -> #b0:_ -> act:action i0 l0 b0 unit -> - action i0 l0 b0 bool - -let _inv_implies_refl (inv: A.slice_inv) : Lemma - (inv `A.inv_implies` inv) - [SMTPat (inv `A.inv_implies` inv)] -= A.inv_implies_refl inv - -let _inv_implies_true (inv0: A.slice_inv) : Lemma - (inv0 `A.inv_implies` A.true_inv) - [SMTPat (inv0 `A.inv_implies` A.true_inv)] -= A.inv_implies_true inv0 - -let _inv_implies_conj (inv0 inv1 inv2: A.slice_inv) : Lemma - (requires ( - inv0 `A.inv_implies` inv1 /\ - inv0 `A.inv_implies` inv2 - )) - (ensures ( - inv0 `A.inv_implies` (inv1 `A.conj_inv` inv2) - )) - [SMTPat (inv0 `A.inv_implies` (inv1 `A.conj_inv` inv2))] -= A.inv_implies_conj inv0 inv1 inv2 () () - -let _eloc_includes_none (l1:A.eloc) : Lemma - (l1 `A.eloc_includes` A.eloc_none) - [SMTPat (l1 `A.eloc_includes` A.eloc_none)] -= A.eloc_includes_none l1 - -let _eloc_includes_union (l0: A.eloc) (l1 l2: A.eloc) : Lemma - (requires ( - l0 `A.eloc_includes` l1 /\ - l0 `A.eloc_includes` l2 - )) - (ensures ( - l0 `A.eloc_includes` (l1 `A.eloc_union` l2) - )) - [SMTPat (l0 `A.eloc_includes` (l1 `A.eloc_union` l2))] -= A.eloc_includes_union l0 l1 l2 () () - -let _eloc_includes_refl (l: A.eloc) : Lemma - (l `A.eloc_includes` l) - [SMTPat (l `A.eloc_includes` l)] -= A.eloc_includes_refl l + #i0:_ -> #l0:_ -> #b0:_ -> act:action i0 disj_none l0 b0 unit -> + action i0 disj_none l0 b0 bool + (* Denotation of action as A.action *) [@@specialize] let rec action_as_action - (#nz #wk:_) - (#pk:P.parser_kind nz wk) (#pt:_) - (#i #l #b #t:_) - (p:P.parser pk pt) - (a:action i l b t) - : Tot (A.action p i l b t) + (#i #d #l #b #t:_) + (a:action i d l b t) + : Tot (A.action (interp_inv i) (interp_disj d) (interp_loc l) b t) (decreases a) - = match a with + = A.index_equations(); + match a with | Atomic_action a -> - atomic_action_as_action p a + atomic_action_as_action a | Action_seq hd tl -> - let a1 = atomic_action_as_action p hd in - let tl = action_as_action p tl in + let a1 = atomic_action_as_action hd in + let tl = action_as_action tl in A.action_seq a1 tl | Action_ite hd t e -> - let then_ (x:squash hd) = action_as_action p (t x) in - let else_ (x:squash (not hd)) = action_as_action p (e x) in + let then_ (x:squash hd) = action_as_action (t x) in + let else_ (x:squash (not hd)) = action_as_action (e x) in A.action_ite hd then_ else_ | Action_let hd k -> - let head = atomic_action_as_action p hd in - let k x = action_as_action p (k x) in + let head = atomic_action_as_action hd in + let k x = action_as_action (k x) in A.action_bind "hd" head k | Action_act #i0 #l0 #b0 a -> - A.action_weaken (A.action_seq (action_as_action p a) (A.action_return true)) #i0 #l0 + A.action_weaken (A.action_seq (action_as_action a) (A.action_return true)) + #(interp_inv i0) + #_ + #(interp_loc l0) (* Some AST nodes contain source comments that we propagate to the output *) let comments = string -(* The main type of 3D types. Some points to note: - - - The indexing structure determines the types of the - parser/validator etc. of its denotation - - - All top-level names mentioned in a typ must be bound in the - context. - - - Constructs that bind local names are represented using F* - functions that abstract over denotations of the underlying types. - - - Some elements of the source programs are "pre-denoted". Notably, - every refinement formula is represented in this AST already as a - boolean function, rather than in some embedded language of - expressions. This is because expressions are not necessarily - well-formed by syntax alone---they may give rise to verification - conditions when using bounded arithmetic functions. So, it's the - obligation of the `typ` generator (i.e., the 3D frontend) to - produce boolean functions for those expressions that can be - verified natively by F* for type correctness. -*) - -noeq -type dtyp - : #nz:bool -> #wk:P.weak_kind -> - P.parser_kind nz wk -> - has_reader:bool -> - A.slice_inv -> - A.eloc -> - Type = - | DT_IType: - i:itype -> - dtyp (parser_kind_of_itype i) - (allow_reader_of_itype i) - A.true_inv - A.eloc_none - - | DT_App: - (* We give explicit names to the indices rather than - projecting them as a small optimization for the reduction - machinery ... it's no longer clear that the speedup is significant *) - #nz:bool -> - #wk:P.weak_kind -> - pk:P.parser_kind nz wk -> - hr:bool -> - inv:A.slice_inv -> - loc:A.eloc -> - x:global_binding -> - _:squash (nz == nz_of_binding x /\ - wk == wk_of_binding x /\ - pk == pk_of_binding x /\ - hr == has_reader x /\ - inv == inv_of_binding x /\ - loc == loc_of_binding x) -> - dtyp #nz #wk pk hr inv loc - -[@@specialize] -let dtyp_as_type #nz #wk (#pk:P.parser_kind nz wk) #hr #i #l - (d:dtyp pk hr i l) - : Type - = match d with - | DT_IType i -> - itype_as_type i - - | DT_App _ _ _ _ b _ -> - type_of_binding b - -let dtyp_as_eqtype_lemma #nz #wk (#pk:P.parser_kind nz wk) #i #l - (d:dtyp pk true i l) - : Lemma - (ensures hasEq (dtyp_as_type d)) - [SMTPat (hasEq (dtyp_as_type d))] - = match d with - | DT_IType i -> - () - - | DT_App _ _ _ _ b _ -> - let (| _, _ |) = get_leaf_reader b in () - - -let dtyp_as_parser #nz #wk (#pk:P.parser_kind nz wk) #hr #i #l - (d:dtyp pk hr i l) - : P.parser pk (dtyp_as_type d) - = match d returns Tot (P.parser pk (dtyp_as_type d)) with - | DT_IType i -> - itype_as_parser i - - | DT_App _ _ _ _ b _ -> - parser_of_binding b - -[@@specialize] -let dtyp_as_validator #nz #wk (#pk:P.parser_kind nz wk) - (#hr:_) - (#[@@@erasable] i:A.slice_inv) - (#[@@@erasable] l:A.eloc) - (d:dtyp pk hr i l) - : A.validate_with_action_t #nz #wk #pk #(dtyp_as_type d) (dtyp_as_parser d) i l hr - = match d - returns A.validate_with_action_t #nz #wk #pk #(dtyp_as_type d) (dtyp_as_parser d) i l hr - with - | DT_IType i -> - itype_as_validator i - - | DT_App _ _ _ _ b _ -> - // assert_norm (dtyp_as_type (DT_App_Alt ps b args) == (type_of_binding_alt (apply_arrow b args))); - // assert_norm (dtyp_as_parser (DT_App_Alt ps b args) == parser_of_binding_alt (apply_arrow b args)); - validator_of_binding b - - -[@@specialize] -let dtyp_as_leaf_reader #nz (#pk:P.parser_kind nz P.WeakKindStrongPrefix) - (#[@@@erasable] i:A.slice_inv) - (#[@@@erasable] l:A.eloc) - (d:dtyp pk true i l) - : A.leaf_reader (dtyp_as_parser d) - = match d with - | DT_IType i -> - itype_as_leaf_reader i - - | DT_App _ _ _ _ b _ -> - let (| _, lr |) = get_leaf_reader b in - lr - [@@ no_auto_projectors] noeq type typ : #nz:bool -> #wk:P.weak_kind -> P.parser_kind nz wk -> - A.slice_inv -> - A.eloc -> + inv_index -> + disj_index -> + loc_index -> bool -> Type = | T_false: fieldname:string -> - typ P.impos_kind A.true_inv A.eloc_none true + typ P.impos_kind inv_none disj_none loc_none true | T_denoted : fieldname:string -> #nz:_ -> #wk:_ -> #pk:P.parser_kind nz wk -> - #has_reader:_ -> #i:_ -> #l:_ -> - td:dtyp pk has_reader i l -> - typ pk i l has_reader + #has_reader:_ -> #i:_ -> #disj:_ -> #l:_ -> + td:dtyp pk has_reader i disj l -> + typ pk i disj l has_reader | T_pair: first_fieldname:string -> #nz1:_ -> #pk1:P.parser_kind nz1 P.WeakKindStrongPrefix -> - #i1:_ -> #l1:_ -> #b1:_ -> + #i1:_ -> #d1:_ -> #l1:_ -> #b1:_ -> #nz2:_ -> #wk2:_ -> #pk2:P.parser_kind nz2 wk2 -> - #i2:_ -> #l2:_ -> #b2:_ -> - t1:typ pk1 i1 l1 b1 -> - t2:typ pk2 i2 l2 b2 -> - typ (P.and_then_kind pk1 pk2) (A.conj_inv i1 i2) (A.eloc_union l1 l2) false + #i2:_ -> #d2:_ -> #l2:_ -> #b2:_ -> + t1:typ pk1 i1 d1 l1 b1 -> + t2:typ pk2 i2 d2 l2 b2 -> + typ (P.and_then_kind pk1 pk2) + (join_inv i1 i2) + (join_disj d1 d2) + (join_loc l1 l2) + false | T_dep_pair: first_fieldname:string -> #nz1:_ -> #pk1:P.parser_kind nz1 P.WeakKindStrongPrefix -> - #i1:_ -> #l1:_ -> + #i1:_ -> #d1:_ -> #l1:_ -> #nz2:_ -> #wk2:_ -> #pk2:P.parser_kind nz2 wk2 -> - #i2:_ -> #l2:_ -> #b2:bool -> + #i2:_ -> #d2:_ -> #l2:_ -> #b2:bool -> //the first component is a pre-denoted type with a reader - t1:dtyp pk1 true i1 l1 -> + t1:dtyp pk1 true i1 d1 l1 -> //the second component is a function from denotations of t1 //that's why it's a small type, so that we can speak about its //denotation here - t2:(dtyp_as_type t1 -> typ pk2 i2 l2 b2) -> - typ (P.and_then_kind pk1 pk2) (A.conj_inv i1 i2) (A.eloc_union l1 l2) false + t2:(dtyp_as_type t1 -> typ pk2 i2 d2 l2 b2) -> + typ (P.and_then_kind pk1 pk2) + (join_inv i1 i2) + (join_disj d1 d2) + (join_loc l1 l2) + false | T_refine: fieldname:string -> #nz1:_ -> #pk1:P.parser_kind nz1 P.WeakKindStrongPrefix -> - #i1:_ -> #l1:_ -> + #i1:_ -> #d1:_ -> #l1:_ -> //the first component is a pre-denoted type with a reader - base:dtyp pk1 true i1 l1 -> + base:dtyp pk1 true i1 d1 l1 -> //the second component is a function from denotations of base //but notice that its codomain is bool, rather than expr //That's to ensure that the refinement is already well-typed refinement:(dtyp_as_type base -> bool) -> - typ (P.filter_kind pk1) i1 l1 false + typ (P.filter_kind pk1) i1 d1 l1 false | T_refine_with_action: fieldname:string -> #nz1:_ -> #pk1:P.parser_kind nz1 P.WeakKindStrongPrefix -> - #i1:_ -> #l1:_ -> - #i2:_ -> #l2:_ -> #b2:_ -> - base:dtyp pk1 true i1 l1 -> + #i1:_ -> #d1:_ -> #l1:_ -> + #i2:_ -> #d2:_ -> #l2:_ -> #b2:_ -> + base:dtyp pk1 true i1 d1 l1 -> refinement:(dtyp_as_type base -> bool) -> - act:(dtyp_as_type base -> action i2 l2 b2 bool) -> - typ (P.filter_kind pk1) (A.conj_inv i1 i2) (A.eloc_union l1 l2) false + act:(dtyp_as_type base -> action i2 d2 l2 b2 bool) -> + typ (P.filter_kind pk1) + (join_inv i1 i2) + (join_disj d1 d2) + (join_loc l1 l2) + false | T_dep_pair_with_refinement: //This construct serves two purposes @@ -694,32 +782,34 @@ type typ // to depend on the refinement of the first field first_fieldname:string -> #nz1:_ -> #pk1:P.parser_kind nz1 P.WeakKindStrongPrefix -> - #i1:_ -> #l1:_ -> + #i1:_ -> #d1:_ -> #l1:_ -> #nz2:_ -> #wk2:_ -> #pk2:P.parser_kind nz2 wk2 -> - #i2:_ -> #l2:_ -> #b2:_ -> + #i2:_ -> #d2:_ -> #l2:_ -> #b2:_ -> //the first component is a pre-denoted type with a reader - base:dtyp pk1 true i1 l1 -> + base:dtyp pk1 true i1 d1 l1 -> //the second component is a function from denotations of base refinement:(dtyp_as_type base -> bool) -> - k:(x:dtyp_as_type base { refinement x } -> typ pk2 i2 l2 b2) -> + k:(x:dtyp_as_type base { refinement x } -> typ pk2 i2 d2 l2 b2) -> typ (P.and_then_kind (P.filter_kind pk1) pk2) - (A.conj_inv i1 i2) - (A.eloc_union l1 l2) + (join_inv i1 i2) + (join_disj d1 d2) + (join_loc l1 l2) false | T_dep_pair_with_action: fieldname:string -> #nz1:_ -> #pk1:P.parser_kind nz1 P.WeakKindStrongPrefix -> - #i1:_ -> #l1:_ -> + #i1:_ -> #d1:_ -> #l1:_ -> #nz2:_ -> #wk2:_ -> #pk2:P.parser_kind nz2 wk2 -> - #i2:_ -> #l2:_ -> #b2:_ -> - #i3:_ -> #l3:_ -> #b3:_ -> - base:dtyp pk1 true i1 l1 -> - k:(x:dtyp_as_type base -> typ pk2 i2 l2 b2) -> - act:(dtyp_as_type base -> action i3 l3 b3 bool) -> + #i2:_ -> #d2:_ -> #l2:_ -> #b2:_ -> + #i3:_ -> #d3:_ -> #l3:_ -> #b3:_ -> + base:dtyp pk1 true i1 d1 l1 -> + k:(x:dtyp_as_type base -> typ pk2 i2 d2 l2 b2) -> + act:(dtyp_as_type base -> action i3 d3 l3 b3 bool) -> typ (P.and_then_kind pk1 pk2) - (A.conj_inv i1 (A.conj_inv i3 i2)) - (A.eloc_union l1 (A.eloc_union l3 l2)) + (join_inv i1 (join_inv i3 i2)) + (join_disj d1 (join_disj d3 d2)) + (join_loc l1 (join_loc l3 l2)) false | T_dep_pair_with_refinement_and_action: @@ -730,104 +820,142 @@ type typ // to depend on the refinement of the first field first_fieldname:string -> #nz1:_ -> #pk1:P.parser_kind nz1 P.WeakKindStrongPrefix -> - #i1:_ -> #l1:_ -> + #i1:_ -> #d1:_ -> #l1:_ -> #nz2:_ -> #wk2:_ -> #pk2:P.parser_kind nz2 wk2 -> - #i2:_ -> #l2:_ -> #b2:_ -> - #i3:_ -> #l3:_ -> #b3:_ -> + #i2:_ -> #d2:_ -> #l2:_ -> #b2:_ -> + #i3:_ -> #d3:_ -> #l3:_ -> #b3:_ -> //the first component is a pre-denoted type with a reader - base:dtyp pk1 true i1 l1 -> + base:dtyp pk1 true i1 d1 l1 -> //the second component is a function from denotations of base refinement:(dtyp_as_type base -> bool) -> - k:(x:dtyp_as_type base { refinement x } -> typ pk2 i2 l2 b2) -> - act:(dtyp_as_type base -> action i3 l3 b3 bool) -> + k:(x:dtyp_as_type base { refinement x } -> typ pk2 i2 d2 l2 b2) -> + act:(dtyp_as_type base -> action i3 d3 l3 b3 bool) -> typ (P.and_then_kind (P.filter_kind pk1) pk2) - (A.conj_inv i1 (A.conj_inv i3 i2)) - (A.eloc_union l1 (A.eloc_union l3 l2)) + (join_inv i1 (join_inv i3 i2)) + (join_disj d1 (join_disj d3 d2)) + (join_loc l1 (join_loc l3 l2)) false | T_if_else: #nz1:_ -> #wk1:_ -> #pk1:P.parser_kind nz1 wk1 -> - #l1:_ -> #i1:_ -> #b1:_ -> + #l1:_ -> #i1:_ -> #d1:_ -> #b1:_ -> #nz2:_ -> #wk2:_ -> #pk2:P.parser_kind nz2 wk2 -> - #l2:_ -> #i2:_ -> #b2:_ -> + #l2:_ -> #i2:_ -> #d2:_ -> #b2:_ -> b:bool -> //A bool, rather than an expression - t1:(squash b -> typ pk1 i1 l1 b1) -> - t2:(squash (not b) -> typ pk2 i2 l2 b2) -> - typ (P.glb pk1 pk2) (A.conj_inv i1 i2) (A.eloc_union l1 l2) false + t1:(squash b -> typ pk1 i1 d1 l1 b1) -> + t2:(squash (not b) -> typ pk2 i2 d2 l2 b2) -> + typ (P.glb pk1 pk2) + (join_inv i1 i2) + (join_disj d1 d2) + (join_loc l1 l2) false | T_cases: #nz1:_ -> #wk1:_ -> #pk1:P.parser_kind nz1 wk1 -> - #l1:_ -> #i1:_ -> #b1:_ -> + #l1:_ -> #i1:_ -> #d1:_ -> #b1:_ -> #nz2:_ -> #wk2:_ -> #pk2:P.parser_kind nz2 wk2 -> - #l2:_ -> #i2:_ -> #b2:_ -> + #l2:_ -> #i2:_ -> #d2:_ -> #b2:_ -> b:bool -> //A bool, rather than an expression - t1:typ pk1 i1 l1 b1 -> - t2:typ pk2 i2 l2 b2 -> - typ (P.glb pk1 pk2) (A.conj_inv i1 i2) (A.eloc_union l1 l2) false + t1:typ pk1 i1 d1 l1 b1 -> + t2:typ pk2 i2 d2 l2 b2 -> + typ (P.glb pk1 pk2) + (join_inv i1 i2) + (join_disj d1 d2) + (join_loc l1 l2) + false | T_with_action: fieldname:string -> #nz:_ -> #wk:_ -> #pk:P.parser_kind nz wk -> - #l1:_ -> #i1:_ -> #b1:_ -> - #l2:_ -> #i2:_ -> #b2:_ -> - base:typ pk i1 l1 b1 -> - act:action i2 l2 b2 bool -> - typ pk (A.conj_inv i1 i2) (A.eloc_union l1 l2) false + #l1:_ -> #i1:_ -> #d1:_ -> #b1:_ -> + #l2:_ -> #i2:_ -> #d2:_ -> #b2:_ -> + base:typ pk i1 d1 l1 b1 -> + act:action i2 d2 l2 b2 bool -> + typ pk (join_inv i1 i2) (join_disj d1 d2) (join_loc l1 l2) false | T_with_dep_action: fieldname:string -> #nz1:_ -> #pk1:P.parser_kind nz1 P.WeakKindStrongPrefix -> - #i1:_ -> #l1:_ -> - #i2:_ -> #l2:_ -> #b2:_ -> - head:dtyp pk1 true i1 l1 -> - act:(dtyp_as_type head -> action i2 l2 b2 bool) -> - typ pk1 (A.conj_inv i1 i2) (A.eloc_union l1 l2) false + #i1:_ -> #d1: _ -> #l1:_ -> + #i2:_ -> #d2:_ -> #l2:_ -> #b2:_ -> + head:dtyp pk1 true i1 d1 l1 -> + act:(dtyp_as_type head -> action i2 d2 l2 b2 bool) -> + typ pk1 (join_inv i1 i2) (join_disj d1 d2) (join_loc l1 l2) false | T_with_comment: fieldname:string -> #nz:_ -> #wk:_ -> #pk:P.parser_kind nz wk -> - #l:_ -> #i:_ -> #b:_ -> - t:typ pk i l b -> + #l:_ -> #i:_ -> #d:_ -> #b:_ -> + t:typ pk i d l b -> c:comments -> - typ pk i l b + typ pk i d l b | T_nlist: fieldname:string -> #wk:_ -> #pk:P.parser_kind true wk -> - #i:_ -> #l:_ -> #b:_ -> + #i:_ -> #l:_ -> #d:_ -> #b:_ -> n:U32.t -> - t:typ pk i l b -> - typ P.kind_nlist i l false + t:typ pk i d l b -> + typ P.kind_nlist i d l false | T_at_most: fieldname:string -> #nz:_ -> #wk:_ -> #pk:P.parser_kind nz wk -> - #i:_ -> #l:_ -> #b:_ -> + #i:_ -> #d:_ -> #l:_ -> #b:_ -> n:U32.t -> - t:typ pk i l b -> - typ P.kind_t_at_most i l false + t:typ pk i d l b -> + typ P.kind_t_at_most i d l false | T_exact: fieldname:string -> #nz:_ -> #wk:_ -> #pk:P.parser_kind nz wk -> - #i:_ -> #l:_ -> #b:_ -> + #i:_ -> #d:_ -> #l:_ -> #b:_ -> n:U32.t -> - t:typ pk i l b -> - typ P.kind_t_exact i l false + t:typ pk i d l b -> + typ P.kind_t_exact i d l false | T_string: fieldname:string -> #pk1:P.parser_kind true P.WeakKindStrongPrefix -> - element_type:dtyp pk1 true A.true_inv A.eloc_none -> + element_type:dtyp pk1 true inv_none disj_none loc_none -> terminator:dtyp_as_type element_type -> - typ P.parse_string_kind A.true_inv A.eloc_none false + typ P.parse_string_kind inv_none disj_none loc_none false + + +[@@specialize] +inline_for_extraction +let coerce (#[@@@erasable]a:Type) + (#[@@@erasable]b:Type) + ( [@@@erasable]pf:squash (a == b)) + (x:a) + : b + = x +[@@specialize] +let t_probe_then_validate + (fieldname:string) + (probe:CP.probe_fn) + (len:U64.t) + (dest:CP.copy_buffer_t) + (#nz #wk:_) (#pk:P.parser_kind nz wk) + (#has_reader #i #disj:_) + (#l:_) + (td:dtyp pk has_reader i disj l) + : typ (parser_kind_of_itype UInt64) + (join_inv i (NonTrivial (A.copy_buffer_inv dest))) + (join_disj disj (disjoint (NonTrivial (A.copy_buffer_loc dest)) l)) + (join_loc l (NonTrivial (A.copy_buffer_loc dest))) + false + = T_with_dep_action fieldname + (DT_IType UInt64) + (fun src -> + Atomic_action (Action_probe_then_validate td src len dest probe)) + (* Type denotation of `typ` *) let rec as_type #nz #wk (#pk:P.parser_kind nz wk) - #l #i #b - (t:typ pk l i b) + #l #i #d #b + (t:typ pk l i d b) : Tot Type0 (decreases t) = match t with @@ -881,11 +1009,12 @@ let rec as_type | T_string _ elt_t terminator -> P.cstring (dtyp_as_type elt_t) terminator + (* Parser denotation of `typ` *) let rec as_parser #nz #wk (#pk:P.parser_kind nz wk) - #l #i #b - (t:typ pk l i b) + #l #i #d #b + (t:typ pk l i d b) : Tot (P.parser pk (as_type t)) (decreases t) = match t returns Tot (P.parser pk (as_type t)) with @@ -967,9 +1096,10 @@ let rec as_parser [@@specialize] let rec as_reader #nz (#pk:P.parser_kind nz P.WeakKindStrongPrefix) - (#[@@@erasable] inv:A.slice_inv) - (#[@@@erasable] loc:A.eloc) - (t:typ pk inv loc true) + (#[@@@erasable] inv:inv_index) + (#[@@@erasable] d:disj_index) + (#[@@@erasable] loc:loc_index) + (t:typ pk inv d loc true) : leaf_reader (as_parser t) = match t with | T_denoted _n dt -> @@ -990,17 +1120,33 @@ let rec as_reader #nz (#pk:P.parser_kind nz P.WeakKindStrongPrefix) related by construction to the parser and type denotations *) +#push-options "--split_queries no --z3rlimit_factor 4 --z3cliopt 'smt.qi.eager_threshold=100'" +#restart-solver let rec as_validator (typename:string) #nz #wk (#pk:P.parser_kind nz wk) - (#[@@@erasable] inv:A.slice_inv) - (#[@@@erasable] loc:A.eloc) + (#[@@@erasable] inv:inv_index) + (#[@@@erasable] disj:disj_index) + (#[@@@erasable] loc:loc_index) #b - (t:typ pk inv loc b) - : Tot (A.validate_with_action_t #nz #wk #pk #(as_type t) (as_parser t) inv loc b) + (t:typ pk inv disj loc b) + : Tot (A.validate_with_action_t #nz #wk #pk #(as_type t) + (as_parser t) + (interp_inv inv) + (interp_disj disj) + (interp_loc loc) + b) (decreases t) - = match t - returns Tot (A.validate_with_action_t (as_parser t) inv loc b) + = A.index_equations(); + match t + returns Tot ( + A.validate_with_action_t #nz #wk #pk #(as_type t) + (as_parser t) + (interp_inv inv) + (interp_disj disj) + (interp_loc loc) + b + ) with | T_false fn -> A.validate_with_error_handler typename fn (A.validate_impos()) @@ -1016,12 +1162,12 @@ let rec as_validator A.validate_pair fn (as_validator typename t1) (as_validator typename t2) - + | T_dep_pair fn i t -> assert_norm (as_type (T_dep_pair fn i t) == x:dtyp_as_type i & as_type (t x)); assert_norm (as_parser (T_dep_pair fn i t) == P.parse_dep_pair (dtyp_as_parser i) (fun (x:dtyp_as_type i) -> as_parser (t x))); - A.validate_weaken_inv_loc inv loc + A.validate_weaken_inv_loc (interp_inv inv) _ (interp_loc loc) (A.validate_dep_pair fn (A.validate_with_error_handler typename fn (dtyp_as_validator i)) (dtyp_as_leaf_reader i) @@ -1045,7 +1191,7 @@ let rec as_validator (dtyp_as_validator t) (dtyp_as_leaf_reader t) f "reading field_value" "checking constraint" - (fun x -> action_as_action (as_parser (T_refine fn t f)) (a x))) + (fun x -> action_as_action (a x))) | T_dep_pair_with_refinement fn base refinement k -> assert_norm (as_type (T_dep_pair_with_refinement fn base refinement k) == @@ -1053,25 +1199,24 @@ let rec as_validator assert_norm (as_parser (T_dep_pair_with_refinement fn base refinement k) == P.((dtyp_as_parser base `parse_filter` refinement) `parse_dep_pair` (fun x -> as_parser (k x)))); A.validate_with_error_handler typename fn - (A.validate_weaken_inv_loc inv loc ( + (A.validate_weaken_inv_loc _ _ _ ( A.validate_dep_pair_with_refinement false fn (dtyp_as_validator base) (dtyp_as_leaf_reader base) refinement (fun x -> as_validator typename (k x)))) - | T_dep_pair_with_action fn base t act -> assert_norm (as_type (T_dep_pair_with_action fn base t act) == x:dtyp_as_type base & as_type (t x)); assert_norm (as_parser (T_dep_pair_with_action fn base t act) == P.(dtyp_as_parser base `parse_dep_pair` (fun x -> as_parser (t x)))); A.validate_with_error_handler typename fn - (A.validate_weaken_inv_loc inv loc ( + (A.validate_weaken_inv_loc _ _ _ ( A.validate_dep_pair_with_action (dtyp_as_validator base) (dtyp_as_leaf_reader base) - (fun x -> action_as_action (dtyp_as_parser base) (act x)) + (fun x -> action_as_action (act x)) (fun x -> as_validator typename (t x)))) | T_dep_pair_with_refinement_and_action fn base refinement k act -> @@ -1079,15 +1224,16 @@ let rec as_validator x:P.refine (dtyp_as_type base) refinement & as_type (k x)); assert_norm (as_parser (T_dep_pair_with_refinement_and_action fn base refinement k act) == P.((dtyp_as_parser base `parse_filter` refinement) `parse_dep_pair` (fun x -> as_parser (k x)))); - A.validate_weaken_inv_loc inv loc ( + A.validate_weaken_inv_loc _ _ _ ( A.validate_dep_pair_with_refinement_and_action false fn (A.validate_with_error_handler typename fn (dtyp_as_validator base)) (dtyp_as_leaf_reader base) refinement - (fun x -> action_as_action (dtyp_as_parser base) (act x)) + (fun x -> action_as_action (act x)) (fun x -> as_validator typename (k x))) + | T_if_else b t0 t1 -> assert_norm (as_type (T_if_else b t0 t1) == P.t_ite b (fun _ -> as_type (t0())) (fun _ -> as_type (t1 ()))); let p0 (_:squash b) = P.parse_weaken_right (as_parser (t0())) _ in @@ -1113,24 +1259,25 @@ let rec as_validator A.validate_weaken_left (as_validator typename t1) _ in A.validate_ite b p0 v0 p1 v1 - + | T_with_action fn t a -> assert_norm (as_type (T_with_action fn t a) == as_type t); assert_norm (as_parser (T_with_action fn t a) == as_parser t); A.validate_with_error_handler typename fn (A.validate_with_success_action fn (as_validator typename t) - (action_as_action (as_parser t) a)) + (action_as_action a)) | T_with_dep_action fn i a -> assert_norm (as_type (T_with_dep_action fn i a) == dtyp_as_type i); assert_norm (as_parser (T_with_dep_action fn i a) == dtyp_as_parser i); A.validate_with_error_handler typename fn - (A.validate_weaken_inv_loc inv loc ( + (A.validate_weaken_inv_loc _ _ _ ( A.validate_with_dep_action fn (dtyp_as_validator i) (dtyp_as_leaf_reader i) - (fun x -> action_as_action (dtyp_as_parser i) (a x)))) + (fun x -> action_as_action (a x)))) + | T_with_comment fn t c -> assert_norm (as_type (T_with_comment fn t c) == as_type t); @@ -1162,16 +1309,29 @@ let rec as_validator (A.validate_string (dtyp_as_validator elt_t) (dtyp_as_leaf_reader elt_t) terminator) - +#pop-options [@@noextract_to "krml"; specialize] inline_for_extraction noextract -let validator_of #allow_reading #nz #wk (#k:P.parser_kind nz wk) #i #l (t:typ k i l allow_reading) = - A.validate_with_action_t (as_parser t) i l allow_reading +let validator_of #allow_reading #nz #wk (#k:P.parser_kind nz wk) + (#[@@@erasable] i:inv_index) + (#[@@@erasable] d:disj_index) + (#[@@@erasable] l:loc_index) + (t:typ k i d l allow_reading) = + A.validate_with_action_t + (as_parser t) + (interp_inv i) + (interp_disj d) + (interp_loc l) + allow_reading [@@noextract_to "krml"; specialize] inline_for_extraction noextract -let dtyp_of #nz #wk (#k:P.parser_kind nz wk) #i #l #b (t:typ k i l b) = - dtyp k b i l +let dtyp_of #nz #wk (#k:P.parser_kind nz wk) + (#[@@@erasable] i:inv_index) + (#[@@@erasable] d:disj_index) + (#[@@@erasable] l:loc_index) + #b (t:typ k i d l b) = + dtyp k b i d l let specialization_steps = [nbe; @@ -1205,13 +1365,17 @@ let specialize_tac steps (_:unit) [@@specialize] let mk_global_binding #nz #wk (pk:P.parser_kind nz wk) - ([@@@erasable] inv:A.slice_inv) - ([@@@erasable] loc:A.eloc) + ([@@@erasable] inv:inv_index) + ([@@@erasable] disj:disj_index) + ([@@@erasable] loc:loc_index) ([@@@erasable] p_t : Type0) ([@@@erasable] p_p : P.parser pk p_t) (p_reader: option (leaf_reader p_p)) (b:bool) - (p_v : A.validate_with_action_t p_p inv loc b) + (p_v : A.validate_with_action_t p_p + (interp_inv inv) + (interp_disj disj) + (interp_loc loc) b) ([@@@erasable] pf:squash (b == Some? p_reader)) : global_binding = { @@ -1219,6 +1383,7 @@ let mk_global_binding #nz #wk parser_weak_kind = wk; parser_kind = pk; inv = inv; + disj; loc = loc; p_t = p_t; p_p = p_p; @@ -1226,55 +1391,56 @@ let mk_global_binding #nz #wk p_v = p_v } -[@@specialize] -inline_for_extraction -let coerce (#[@@@erasable]a:Type) - (#[@@@erasable]b:Type) - ( [@@@erasable]pf:squash (a == b)) - (x:a) - : b - = x - [@@specialize] let mk_dt_app #nz #wk (pk:P.parser_kind nz wk) (b:bool) - ([@@@erasable] inv:A.slice_inv) - ([@@@erasable] loc:A.eloc) + ([@@@erasable] inv:inv_index) + ([@@@erasable] disj:disj_index) + ([@@@erasable] loc:loc_index) (x:global_binding) ([@@@erasable] pf:squash (nz == nz_of_binding x /\ wk == wk_of_binding x /\ pk == pk_of_binding x /\ b == has_reader x /\ inv == inv_of_binding x /\ + disj == disj_of_bindng x /\ loc == loc_of_binding x)) - : dtyp #nz #wk pk b inv loc - = DT_App pk b inv loc x pf + : dtyp #nz #wk pk b inv disj loc + = DT_App pk b inv disj loc x pf [@@specialize] let mk_dtyp_app #nz #wk (pk:P.parser_kind nz wk) - ([@@@erasable] inv:A.slice_inv) - ([@@@erasable] loc:A.eloc) + ([@@@erasable] inv:inv_index) + ([@@@erasable] disj:disj_index) + ([@@@erasable] loc:loc_index) ([@@@erasable] p_t : Type0) ([@@@erasable] p_p : P.parser pk p_t) (p_reader: option (leaf_reader p_p)) (b:bool) - (p_v : A.validate_with_action_t p_p inv loc b) + (p_v : A.validate_with_action_t p_p + (interp_inv inv) + (interp_disj disj) + (interp_loc loc) + b) ([@@@erasable] pf:squash (b == Some? p_reader)) - : dtyp #nz #wk pk b inv loc + : dtyp #nz #wk pk b inv disj loc = let gb = { parser_kind_nz = nz; parser_weak_kind = wk; parser_kind = pk; inv = inv; + disj; loc = loc; p_t = p_t; p_p = p_p; p_reader = p_reader; p_v = p_v } in - DT_App pk b inv loc gb () + DT_App pk b inv disj loc gb () +//attribute to tag disjointness indexes of type definitions +let specialize_disjointness = () let coerce_validator steps : T.Tac unit = let open FStar.List.Tot in T.norm [delta_only (steps @ [`%parser_kind_of_itype; @@ -1286,7 +1452,9 @@ let coerce_validator steps : T.Tac unit = `%coerce; `%validator_of; `%dtyp_of; + `%join_disj; ]); + delta_attr [`%specialize_disjointness]; zeta; iota; primops]; diff --git a/src/3d/prelude/EverParse3dPrelude.fst.config.json b/src/3d/prelude/EverParse3dPrelude.fst.config.json new file mode 100644 index 000000000..f3dcb21e8 --- /dev/null +++ b/src/3d/prelude/EverParse3dPrelude.fst.config.json @@ -0,0 +1,15 @@ +{ + "fstar_exe": "fstar.exe", + "options": [ + "--max_fuel", "0", + "--max_ifuel", "2", + "--initial_ifuel", "2" + ], + "include_dirs": [ + "${EVERPARSE_HOME}/src/lowparse", + "${KRML_HOME}/krmllib", + "${KRML_HOME}/krmllib/obj", + "${EVERPARSE_HOME}/src/3d/prelude" + ] + } + \ No newline at end of file diff --git a/src/3d/prelude/buffer/EverParse3d.Actions.All.fst b/src/3d/prelude/buffer/EverParse3d.Actions.All.fst index fd04355c3..5d113d934 100644 --- a/src/3d/prelude/buffer/EverParse3d.Actions.All.fst +++ b/src/3d/prelude/buffer/EverParse3d.Actions.All.fst @@ -11,20 +11,20 @@ module P = EverParse3d.Prelude let ___PUINT8 = IB.puint8 let action_field_ptr - #nz #wk (#k:P.parser_kind nz wk) (#t:Type) (#p:P.parser k t) (u:unit) - = fun ctxt input startPosition _ -> + (u:unit) + = fun ctxt _err input _len startPosition _ -> let open LowParse.Slice in IB.offset input.EverParse3d.InputStream.Buffer.Aux.buf (LowParse.Low.ErrorCode.uint64_to_uint32 startPosition) input.EverParse3d.InputStream.Buffer.Aux.perm_of let action_field_ptr_after - #nz #wk (#k:P.parser_kind nz wk) (#t:Type) (#p:P.parser k t) n + n = false_elim () let action_field_ptr_after_with_setter _ = false_elim () let action_field_pos_32 - #nz #wk (#k:P.parser_kind nz wk) (#t:Type) (#p:P.parser k t) (u:unit) - = fun ctxt input startPosition _ -> + (u:unit) + = fun ctxt _err input _len startPosition _ -> [@inline_let] let res = LowParse.Low.ErrorCode.uint64_to_uint32 startPosition in assert (FStar.UInt32.v res == FStar.UInt64.v startPosition); // sanity-check: no modulo here diff --git a/src/3d/prelude/buffer/EverParse3dBuffer.fst.config.json b/src/3d/prelude/buffer/EverParse3dBuffer.fst.config.json new file mode 100644 index 000000000..f4489ba53 --- /dev/null +++ b/src/3d/prelude/buffer/EverParse3dBuffer.fst.config.json @@ -0,0 +1,17 @@ +{ + "fstar_exe": "fstar.exe", + "options": [ + "--max_fuel", "0", + "--max_ifuel", "2", + "--initial_ifuel", "2", + "--z3rlimit_factor", "8", + "--z3cliopt", "smt.qi.eager_threshold=100" + ], + "include_dirs": [ + "..", + "${EVERPARSE_HOME}/src/lowparse", + "${KRML_HOME}/krmllib", + "${KRML_HOME}/krmllib/obj" + ] + } + \ No newline at end of file diff --git a/src/3d/prelude/buffer/Makefile b/src/3d/prelude/buffer/Makefile index ca75f9cbc..70ebc073c 100644 --- a/src/3d/prelude/buffer/Makefile +++ b/src/3d/prelude/buffer/Makefile @@ -41,7 +41,7 @@ EverParse.h: EverParse.rsp -skip-compilation \ -skip-makefiles \ -bundle 'Prims,C.\*,FStar.\*,LowStar.\*[rename=SHOULDNOTBETHERE]' \ - -bundle 'EverParse3d.Prelude.StaticHeader+EverParse3d.ErrorCode+EverParse3d.InputStream.Buffer.Aux=LowParse.\*,EverParse3d.\*[rename=EverParse,rename-prefix]' \ + -bundle 'EverParse3d.Prelude.StaticHeader+EverParse3d.ErrorCode+EverParse3d.InputStream.Buffer.Aux+EverParse3d.CopyBuffer=LowParse.\*,EverParse3d.\*[rename=EverParse,rename-prefix]' \ -warn-error -9@4 \ -fnoreturn-else -fparentheses -fcurly-braces -fmicrosoft \ -header ../../noheader.txt \ diff --git a/src/3d/prelude/extern/EverParse3d.Actions.All.fst b/src/3d/prelude/extern/EverParse3d.Actions.All.fst index feffb2f97..10499f8f8 100644 --- a/src/3d/prelude/extern/EverParse3d.Actions.All.fst +++ b/src/3d/prelude/extern/EverParse3d.Actions.All.fst @@ -9,18 +9,19 @@ let ___PUINT8 = (b:LowStar.Buffer.buffer FStar.UInt8.t { ~ (LowStar.Buffer.g_is_ let action_field_ptr u = false_elim () let action_field_ptr_after _ n write_to = - fun ctxt input _ currentPosition -> + fun ctxt _err input _len _posBefore currentPosition -> let buf = EverParse3d.InputStream.Extern.peep input currentPosition n in let buf_not_null = not (LowStar.Buffer.is_null buf) in if buf_not_null then begin let open LowStar.BufferOps in + ptr_inv_elim write_to; write_to *= buf end; buf_not_null let action_field_ptr_after_with_setter _ n write_to = - fun ctxt input _ currentPosition -> + fun ctxt _err input _len _posBefore currentPosition -> let buf = EverParse3d.InputStream.Extern.peep input currentPosition n in let buf_not_null = not (LowStar.Buffer.is_null buf) in if buf_not_null diff --git a/src/3d/prelude/extern/EverParse3dExtern.fst.config.json b/src/3d/prelude/extern/EverParse3dExtern.fst.config.json new file mode 100644 index 000000000..f4489ba53 --- /dev/null +++ b/src/3d/prelude/extern/EverParse3dExtern.fst.config.json @@ -0,0 +1,17 @@ +{ + "fstar_exe": "fstar.exe", + "options": [ + "--max_fuel", "0", + "--max_ifuel", "2", + "--initial_ifuel", "2", + "--z3rlimit_factor", "8", + "--z3cliopt", "smt.qi.eager_threshold=100" + ], + "include_dirs": [ + "..", + "${EVERPARSE_HOME}/src/lowparse", + "${KRML_HOME}/krmllib", + "${KRML_HOME}/krmllib/obj" + ] + } + \ No newline at end of file diff --git a/src/3d/prelude/extern/Makefile b/src/3d/prelude/extern/Makefile index 76b019d8e..ccd1a096c 100644 --- a/src/3d/prelude/extern/Makefile +++ b/src/3d/prelude/extern/Makefile @@ -46,7 +46,7 @@ KRML_EXTERN = $(KRML_HOME)/krml \ -skip-compilation \ -skip-makefiles \ -bundle 'Prims,C.\*,FStar.\*,LowStar.\*[rename=SHOULDNOTBETHERE]' \ - -bundle 'EverParse3d.Prelude.StaticHeader+EverParse3d.ErrorCode+EverParse3d.InputStream.Extern.Base+EverParse3d.InputStream.Extern.Type=LowParse.\*,EverParse3d.\*[rename=EverParse,rename-prefix]' \ + -bundle 'EverParse3d.Prelude.StaticHeader+EverParse3d.ErrorCode+EverParse3d.InputStream.Extern.Base+EverParse3d.InputStream.Extern.Type+EverParse3d.CopyBuffer=LowParse.\*,EverParse3d.\*[rename=EverParse,rename-prefix]' \ -warn-error -9@4 \ -fnoreturn-else -fparentheses -fcurly-braces -fmicrosoft \ -header ../../noheader.txt \ diff --git a/src/3d/tests/FAILProbe.3d b/src/3d/tests/FAILProbe.3d new file mode 100644 index 000000000..c2916e6a3 --- /dev/null +++ b/src/3d/tests/FAILProbe.3d @@ -0,0 +1,20 @@ +extern probe ProbeAndCopy + +typedef struct _T { + UINT32 x { x >= 17 }; + UINT32 y { y >= x }; +} T; + +entrypoint +typedef struct _S(EVERPARSE_COPY_BUFFER_T dest) { + UINT8 tag; + T *t probe (length = 8, destination = dest); +} S; + + +//Nested probing of the same buffer; should fail +entrypoint +typedef struct _R(EVERPARSE_COPY_BUFFER_T dest) { + UINT8 tag; + S(dest) *s probe (length = 9, destination = dest); +} R; \ No newline at end of file diff --git a/src/3d/tests/Makefile b/src/3d/tests/Makefile index 29bcb2538..eedb448b3 100644 --- a/src/3d/tests/Makefile +++ b/src/3d/tests/Makefile @@ -26,10 +26,15 @@ positive_tests=$(filter-out $(wildcard FAIL*.3d) FieldDependence0.3d ActAndCheck positive_tests_nosuffix=$(basename $(positive_tests)) modules_or_wrappers=$(positive_tests_nosuffix) $(addsuffix Wrapper,$(positive_tests_nosuffix)) modules_static_assertions=TestFieldPtrStaticAssertions.c AlignStaticAssertions.c -clean_out_files=$(addsuffix .c,$(modules_or_wrappers)) $(modules_static_assertions) $(addsuffix .h,$(modules_or_wrappers)) +clean_out_files=\ + $(addsuffix .c,$(modules_or_wrappers)) \ + $(modules_static_assertions) \ + $(addsuffix .h,$(modules_or_wrappers))\ + Probe_ExternalAPI.h + OTHER_HEADERS=TestFieldPtrBase.h AlignC.h -all: batch-test batch-test-negative batch-cleanup-test inplace-hash-test modules tcpip extern output-types batch-interpret-test modules-interpret elf-test static funptr ifdefs +all: batch-test batch-test-negative batch-cleanup-test inplace-hash-test modules tcpip extern output-types batch-interpret-test modules-interpret elf-test static funptr ifdefs probe #AR: TODO: remove ELF.3d from here @@ -61,6 +66,10 @@ tcpip: output-types: +$(MAKE) -C output_types +.PHONY: probe +probe: + +$(MAKE) -C $@ + batch-test-negative: $(addsuffix .negtest,$(wildcard FAIL*.3d)) %.3d.negtest: %.3d @@ -86,6 +95,10 @@ elf-test: ELF.3d $(3D) --odir out.batch --batch ELF.3d g++ -o out.batch/elf-test -I out.batch $(addprefix out.batch/, ELF.c ELFWrapper.c) TestELF.cpp +%-test: %.3d + mkdir -p out.batch + $(3D) $(FLAGS3D) --odir out.batch --batch $^ + inplace-hash-test: mkdir -p out.inplace-hash $(3D) --odir out.inplace-hash --batch --no_copy_everparse_h Comments.3d diff --git a/src/3d/tests/Probe.3d b/src/3d/tests/Probe.3d new file mode 100644 index 000000000..a9f3c4834 --- /dev/null +++ b/src/3d/tests/Probe.3d @@ -0,0 +1,30 @@ +extern probe ProbeAndCopy + +typedef struct _T { + UINT32 x { x >= 17 }; + UINT32 y { y >= x }; +} T; + +entrypoint +typedef struct _S(EVERPARSE_COPY_BUFFER_T dest) { + UINT8 tag; + T *t probe (length = 8, destination = dest); +} S; + +entrypoint +typedef struct _U(EVERPARSE_COPY_BUFFER_T destS, EVERPARSE_COPY_BUFFER_T destT) { + UINT8 tag; + S(destT) *t probe (length = 9, destination = destS); +} U; + +//Use multiple probe functions if you like +extern probe ProbeAndCopyAlt + +//reuse copy buffer, sequentially +entrypoint +typedef struct _V(EVERPARSE_COPY_BUFFER_T destS, EVERPARSE_COPY_BUFFER_T destT) { + UINT8 tag; + S(destT) *s probe ProbeAndCopy(length = 9, destination = destS); + T *t probe ProbeAndCopyAlt(length = 8, destination = destT); + T *t2 probe ProbeAndCopy(length = 8, destination = destT); +} V; diff --git a/src/3d/tests/probe/.gitignore b/src/3d/tests/probe/.gitignore new file mode 100644 index 000000000..b672fdeaf --- /dev/null +++ b/src/3d/tests/probe/.gitignore @@ -0,0 +1 @@ +obj diff --git a/src/3d/tests/probe/GNUmakefile b/src/3d/tests/probe/GNUmakefile new file mode 100644 index 000000000..5e4c5f2a2 --- /dev/null +++ b/src/3d/tests/probe/GNUmakefile @@ -0,0 +1,108 @@ +# This Makefile is meant to be used with GNU Make. It builds EverParse +# validators and parsers corresponding to the data formats specified +# in src/*.3d files, as well as a test program to run them. + +# Default rule when `make` is run without argument. This rule MUST +# appear first, so we define it here and make it point to a `world` +# rule that will depend on variables defined in the +# EverParse-generated Makefile. +all: world + +######################################################## +# Variables needed by the EverParse-generated Makefile # +######################################################## + +# EVERPARSE_HOME: root of the EverParse tree (source tree or contents +# of the binary package.) +# EVERPARSE_HOME is necessary for the 3d executable. It needs to point to the +# root of the EverParse source tree. However, EVERPARSE_HOME is not needed if +# you run everparse.sh or everparse.cmd from the binary package. +EVERPARSE_HOME ?= $(realpath ../../../..) +export EVERPARSE_HOME + +# Path to either the 3d executable or the everparse.sh or +# everparse.cmd script from the EverParse binary package +EVERPARSE_EXE=$(EVERPARSE_HOME)/bin/3d.exe + +# Options passed to EverParse +EVERPARSE_OPTIONS= + +# Command to run EverParse +EVERPARSE_CMD=$(EVERPARSE_EXE) $(EVERPARSE_OPTIONS) + +# Output directory for .c/.h files as well as temporary files (.fst, +# .krml, etc.) +EVERPARSE_OUTPUT_DIR=obj + +# Input directory containing .3d (and auxiliary .3d.copyright.txt) +# files +EVERPARSE_INPUT_DIR=src + +# If a .3d file contains a `refining` clause, then the C compiler must +# be given the include path that contains the .h files pointed to by +# such clauses. +CFLAGS += -I src + +######################################### +# Generating and including the Makefile # +######################################### + +# Define the name and path of the generated Makefile. We cleverly +# decide to have it generated into the output directory along with all +# temporary files. +everparse_makefile=$(EVERPARSE_OUTPUT_DIR)/EverParse.Makefile + +# Create the output directory if it does not exist +$(EVERPARSE_OUTPUT_DIR): + mkdir -p $@ + +# Generate the Makefile if any .3d file is modified +$(everparse_makefile): $(wildcard src/*.3d) $(EVERPARSE_OUTPUT_DIR) + $(EVERPARSE_CMD) --makefile gmake --makefile_name $@ src/Probe.3d + +# Include the generated Makefile +include $(everparse_makefile) + +############################# +# Building the test program # +############################# + +# Collect all .o files to be built: add the .o files corresponding to +# the handwritten .c files, as well as those corresponding to the .c +# files generated by EverParse. +all_o_files=$(EVERPARSE_ALL_O_FILES) $(EVERPARSE_OUTPUT_DIR)/main.o + +# Compile the handwritten .c file. Since that file depends on .h files +# generated by EverParse, we need to include both the output directory +# and the EverParse library directory into the compiler's include +# path. +$(EVERPARSE_OUTPUT_DIR)/main.o: $(EVERPARSE_INPUT_DIR)/main.c $(EVERPARSE_OUTPUT_DIR)/ProbeWrapper.h + $(CC) $(CFLAGS) -I $(EVERPARSE_OUTPUT_DIR) -I $(EVERPARSE_HOME)/src/3d -I $(EVERPARSE_HOME)/src/3d/prelude/buffer -c -o $@ $< + +# Link the test program +$(EVERPARSE_OUTPUT_DIR)/test.exe: $(all_o_files) + $(CC) $(LDFLAGS) -o $@ $^ + +# Run the test program +test: $(EVERPARSE_OUTPUT_DIR)/test.exe + $< + +########### +# Cleanup # +########### + +# Since everything is output to the same directory, including the +# generated Makefile, it is enough to remove that directory. +clean: + rm -rf $(EVERPARSE_OUTPUT_DIR) + +####################################################### +# Specifying the `world` rule run by the default rule # +####################################################### + +# Specify the behavior of the default rule +world: test + +# Declare all phony rules. +# Cf. https://www.gnu.org/software/make/manual/html_node/Phony-Targets.html +.PHONY: all world test clean ci diff --git a/src/3d/tests/probe/README.md b/src/3d/tests/probe/README.md new file mode 100644 index 000000000..c6b95d8ef --- /dev/null +++ b/src/3d/tests/probe/README.md @@ -0,0 +1,45 @@ +This directory contains an example of EverParse/3d project with +support for non-contiguous parsing with probing functions. + +The `src/` subdirectory contains all the source files of this project, +all handwritten: + +* `Probe.3d` defines the data formats in the 3D language, and declares + the probing functions but does not define them. + +* `main.c` defines the probing functions, and the main test function + of the test program, which calls the validators for the data types + marked `entrypoint` in `Probe.3d`. In this test here, `main.c` also + defines some input data. + +All intermediate files, output files (`*.h`, `*.c`) as well as the +`test.exe` test executable, are slated to be generated into the `obj/` +subdirectory. + +The files `EverParse.h` and `EverParseEndianness.h` are static files +that are part of the EverParse binary package, in +`src/3d/prelude/buffer` and `src/3d` respectively. + +# Linux + +This directory contains a fully commented `GNUmakefile`, to be used +with GNU Make: `make` will generate all the F\* specifications and +Low\* implementations of validators, verify them, compile them to C, +and compile that generated C code along with a handwritten test into a +test executable, and finally run that test executable, `obj/test.exe` + +To build the project, run: + +make EVERPARSE_HOME=/path/to/everparse + +where /path/to/everparse is the full path to the EverParse binary +package directory. + +# Windows + +To build the project, run: + +build.cmd \path\to\everparse + +where \path\to\everparse is the full path to the EverParse binary +package directory. diff --git a/src/3d/tests/probe/build.cmd b/src/3d/tests/probe/build.cmd new file mode 100755 index 000000000..ef453726a --- /dev/null +++ b/src/3d/tests/probe/build.cmd @@ -0,0 +1,12 @@ +@echo off +if "%1" == "" goto error +if not exist obj mkdir obj +call %1\everparse.cmd --odir obj --makefile nmake src\Probe.3d +call nmake /f helper.NMakefile EVERPARSE_INPUT_DIR=src EVERPARSE_OUTPUT_DIR=obj EVERPARSE_HOME=%1 EVERPARSE_CMD=%1\everparse.cmd +goto end + +:error +echo Please provide the path to the EverParse binary package directory +set errorlevel=1 + +:end diff --git a/src/3d/tests/probe/helper.NMakefile b/src/3d/tests/probe/helper.NMakefile new file mode 100644 index 000000000..9a24749bb --- /dev/null +++ b/src/3d/tests/probe/helper.NMakefile @@ -0,0 +1,12 @@ +all: test + +include obj\EverParse.Makefile + +obj\main.obj: src\main.c + $(CC) $(CFLAGS) /I $(EVERPARSE_OUTPUT_DIR) /I $(EVERPARSE_HOME)/src/3d /I $(EVERPARSE_HOME)/src/3d/prelude/buffer /c /Fo: obj\main.obj src\main.c + +obj\test.exe: $(EVERPARSE_ALL_O_FILES) obj\main.obj + $(CC) $(LDFLAGS) /Fe: obj\test.exe $(EVERPARSE_ALL_O_FILES) obj\main.obj + +test: obj\test.exe + obj\test.exe diff --git a/src/3d/tests/probe/src/Probe.3d b/src/3d/tests/probe/src/Probe.3d new file mode 100644 index 000000000..66e0bed9f --- /dev/null +++ b/src/3d/tests/probe/src/Probe.3d @@ -0,0 +1,20 @@ +typedef struct _secondary(UINT64 bound) { + UINT16 x { x >= bound }; + UINT16 y { y >= x }; +} secondary; + +extern probe ProbeInPlace + +entrypoint +typedef struct _primaryInPlace(EVERPARSE_COPY_BUFFER_T dest) { + UINT64 bound; + secondary(bound) *payload probe ProbeInPlace (length = 4, destination = dest); +} primaryInPlace; + +extern probe ProbeAndCopy + +entrypoint +typedef struct _primaryAndCopy(EVERPARSE_COPY_BUFFER_T dest) { + UINT64 bound; + secondary(bound) *payload probe ProbeAndCopy (length = 4, destination = dest); +} primaryAndCopy; diff --git a/src/3d/tests/probe/src/main.c b/src/3d/tests/probe/src/main.c new file mode 100644 index 000000000..abfe359d1 --- /dev/null +++ b/src/3d/tests/probe/src/main.c @@ -0,0 +1,146 @@ +#include "ProbeWrapper.h" +#include +#include +#include +#include + +// ERROR HANDLING + +// `ProbeEverParseError` is declared in the generated +// ../obj/ProbeWrapper.c, but we have to define it by hand here. It is +// the callback function called if any validator for a type defined in +// Probe.3d fails. + +void ProbeEverParseError(char *StructName, char *FieldName, char *Reason) { + printf("Validation failed in Probe, struct %s, field %s. Reason: %s\n", StructName, FieldName, Reason); +} + +// THE INPUT BUFFERS + +// We assume a little-endian C ABI. + +// `secondary` will contain the input for the `secondary` type defined +// in Probe.3d. Depending on the probe function used (see below), it +// may be used either directly as an input buffer, or first copied +// into a separate temporary byte array. + +uint16_t secondary[2] = {1, 2}; + +// `primary` will be the input buffer for both `primaryInPlace` and +// `primaryAndCopy` validators, containing a pointer to `secondary` + +uint64_t primary[2] = {1, (uint64_t) (void*) secondary}; + +// THE COPY BUFFER TYPE AND OPERATIONS + +// The type of input buffers passed to the secondary validator. In +// EverParse.h, EVERPARSE_COPY_BUFFER_T is defined as void*, but in +// our example here, we will use `copy_buffer_t*` + +typedef struct { + uint8_t *buf; + uint64_t len; +} copy_buffer_t; + +// `EverParseStreamOf` is declared in EverParse.h, but we need to +// define it here. Given an input buffer, `EverParseStreamOf` is +// intended to return the input byte array that will be passed to the +// `secondary` validator. + +uint8_t * EverParseStreamOf(EVERPARSE_COPY_BUFFER_T x) { + return ((copy_buffer_t *) x)->buf; +} + +// `EverParseStreamLen` is declared in EverParse.h, but we need to +// define it here. Given an input buffer, `EverParseStreamLen` is +// intended to return the number of input bytes that the +// `secondary` validator is allowed to read. + +uint64_t EverParseStreamLen(EVERPARSE_COPY_BUFFER_T x) { + return ((copy_buffer_t *) x)->len; +} + +// THE PROBING FUNCTIONS + +// `ProbeAndCopy` is a probing function declared in Probe.3d and the +// generated ../obj/Probe_ExternalAPI.h, but we need to define it by +// hand here. We define it as checking whether the pointer read from +// the `primary` type matches the `secondary` array, with the +// corresponding sizes, and if so, performing a copy from the +// `secondary` array to the buffer stored in dst->buf that will be +// used as an input buffer to the validator for the `secondary` type +// defined in Probe.3d. + +BOOLEAN ProbeAndCopy(uint64_t src, uint64_t len, EVERPARSE_COPY_BUFFER_T dst) { + static_assert(sizeof(secondary) == 4); + copy_buffer_t *p = dst; + if (src == (uint64_t) secondary && len == sizeof(secondary) && p->len >= len) { + memcpy(p->buf, (uint8_t*) secondary, len); + return true; + } else { + printf("ProbeAndCopy failed\n"); + return false; + } +} + +// `ProbeInPlace` is a probing function declared in Probe.3d and the +// generated ../obj/Probe_ExternalAPI.h, but we need to define it by +// hand here. We define it as checking whether the pointer read from +// the `primary` type matches the `secondary` array, with the +// corresponding sizes, and if so, NOT performing a copy, but rather +// reusing the `secondary` array directly as an input buffer to the +// validator for the `secondary` type defined in Probe.3d. + +BOOLEAN ProbeInPlace(uint64_t src, uint64_t len, EVERPARSE_COPY_BUFFER_T dst) { + static_assert(sizeof(secondary) == 4); + if (src == (uint64_t) secondary && len == sizeof(secondary)) { + copy_buffer_t *p = dst; + p->buf = (uint8_t*) secondary; + p->len = len; + return true; + } else { + printf("ProbeAndCopy failed\n"); + return false; + } +} + +// THE MAIN TEST FUNCTION + +int main(void) { + + // In-place test: the ProbeInPlace probing function will populate + // the destination directly with the `secondary` array without a + // copy, so that the `secondary` validator will directly use the + // `secondary` array as an input + copy_buffer_t destInPlace = (copy_buffer_t) { + .buf = NULL, + .len = 0 + }; + static_assert(sizeof(primary) == 16); + if (ProbeCheckPrimaryInPlace((EVERPARSE_COPY_BUFFER_T) &destInPlace, (uint8_t*) primary, sizeof(primary))) { + printf("Validation succeeded with PrimaryInPlace\n"); + } else { + printf("Validation failed with PrimaryInPlace\n"); + return 1; + } + + // Test with copy: the ProbeAndCopy probing function will copy the + // `secondary` array to the temporary `destAndCopyBuf` array below, + // which will then be used by the `secondary` validator. The size of + // the copy buffer must be greater or equal to the size used in the + // `probe` declaration in Probe.3d. + uint8_t destAndCopyBuf[8]; + static_assert (sizeof(destAndCopyBuf) == 8); + copy_buffer_t destAndCopy = (copy_buffer_t) { + .buf = destAndCopyBuf, + .len = sizeof(destAndCopyBuf) + }; + if (ProbeCheckPrimaryAndCopy((EVERPARSE_COPY_BUFFER_T) &destAndCopy, (uint8_t*) primary, sizeof(primary))) { + printf("Validation succeeded with PrimaryAndCopy\n"); + } else { + printf("Validation failed with PrimaryAndCopy\n"); + return 1; + } + + return 0; +}