From b1c607c800bdd3a81d3047ae5495841f45ab0773 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Thu, 18 Jul 2024 15:23:48 +0200 Subject: [PATCH 01/51] add custom annotations in ast and parser --- src/ast/annot.ml | 39 ++++++++++++++++++++ src/ast/annot.mli | 17 +++++++++ src/ast/binary_to_text.ml | 3 +- src/ast/text.ml | 2 ++ src/dune | 1 + src/parser/test.wat | 3 ++ src/parser/text_lexer.ml | 74 ++++++++++++++++++++++++++++++++++++++ src/parser/text_parser.mly | 3 +- src/script/spectest.ml | 1 + test/fuzz/gen.ml | 3 +- 10 files changed, 143 insertions(+), 3 deletions(-) create mode 100644 src/ast/annot.ml create mode 100644 src/ast/annot.mli create mode 100644 src/parser/test.wat diff --git a/src/ast/annot.ml b/src/ast/annot.ml new file mode 100644 index 000000000..3aca4c550 --- /dev/null +++ b/src/ast/annot.ml @@ -0,0 +1,39 @@ +type annot = + { annotid : string + ; items : item list + } + +and item = + | Atom of string + | String of string + | Id of string + | Int of string + | Float of string + | Parens of item list + | Annot of annot + +module NameMap = Map.Make (struct + type t = string + + let compare = compare +end) + +let annot_recorder : annot list NameMap.t ref = ref NameMap.empty + +let find_nil key map = Option.value (NameMap.find_opt key map) ~default:[] + +let record_annot annot = + let old = find_nil annot.annotid !annot_recorder in + annot_recorder := NameMap.add annot.annotid (annot :: old) !annot_recorder + +let get_annots ?name () = + let annots = + match name with + | Some name -> find_nil name !annot_recorder + | None -> + List.concat_map + (fun (_, annots) -> annots) + (NameMap.to_list !annot_recorder) + in + annot_recorder := NameMap.empty; + annots diff --git a/src/ast/annot.mli b/src/ast/annot.mli new file mode 100644 index 000000000..e1dff533a --- /dev/null +++ b/src/ast/annot.mli @@ -0,0 +1,17 @@ +type annot = + { annotid : string + ; items : item list + } + +and item = + | Atom of string + | String of string + | Id of string + | Int of string + | Float of string + | Parens of item list + | Annot of annot + +val record_annot : annot -> unit + +val get_annots : ?name:string -> unit -> annot list diff --git a/src/ast/binary_to_text.ml b/src/ast/binary_to_text.ml index 7380c9ee5..e696ce579 100644 --- a/src/ast/binary_to_text.ml +++ b/src/ast/binary_to_text.ml @@ -249,5 +249,6 @@ let modul fields in let fields = imported @ locals in + let annots = [] in - { Text.id; fields } + { Text.id; fields; annots } diff --git a/src/ast/text.ml b/src/ast/text.ml index 847d33d75..7507d6bc9 100644 --- a/src/ast/text.ml +++ b/src/ast/text.ml @@ -4,6 +4,7 @@ open Fmt open Types +open Annot let symbolic v = Text v @@ -95,6 +96,7 @@ let pp_module_field fmt = function type modul = { id : string option ; fields : module_field list + ; annots : annot list } let pp_modul fmt (m : modul) = diff --git a/src/dune b/src/dune index 78977e55e..dbf489a8b 100644 --- a/src/dune +++ b/src/dune @@ -3,6 +3,7 @@ (library (public_name owi) (modules + annot assigned binary binary_encoder diff --git a/src/parser/test.wat b/src/parser/test.wat new file mode 100644 index 000000000..886dcee41 --- /dev/null +++ b/src/parser/test.wat @@ -0,0 +1,3 @@ +(module + (@a df dcd feevsd 1 , c;vdaead 2dcecwef .) +) diff --git a/src/parser/text_lexer.ml b/src/parser/text_lexer.ml index f39ee52a5..5fe64f8d5 100644 --- a/src/parser/text_lexer.ml +++ b/src/parser/text_lexer.ml @@ -120,6 +120,9 @@ let bad_id = [%sedlex.regexp? id, Plus name] let bad_num = [%sedlex.regexp? num, Plus id] +let annot_atom = + [%sedlex.regexp? Plus (id_char | name) | ',' | ';' | '[' | ']' | '{' | '}'] + let keywords = let tbl = Hashtbl.create 512 in Array.iter @@ -433,12 +436,31 @@ let rec token buf = let operator = Utf8.lexeme buf in try Hashtbl.find keywords operator with Not_found -> unknown_operator buf end + (* comment *) | ";;" -> single_comment buf; token buf | "(;" -> comment buf; token buf + (* custom annotation *) + | "(@", name -> + let annotid = Utf8.lexeme buf in + let annotid = String.sub annotid 3 (String.length annotid - 4) in + let annotid = mk_string buf annotid in + if annotid = "" then Log.err "empty annotation id" + else + let items = annot buf in + Annot.(record_annot { annotid; items }); + token buf + | "(@", Plus id_char -> + let annotid = Utf8.lexeme buf in + let annotid = String.sub annotid 2 (String.length annotid - 2) in + let annotid = mk_string buf annotid in + let items = annot buf in + Annot.(record_annot { annotid; items }); + token buf + | "(@" -> Log.err "empty annotation id" (* 1 *) | "(" -> LPAR | ")" -> RPAR @@ -475,4 +497,56 @@ and single_comment buf = | any -> single_comment buf | _ -> assert false +and annot buf = + match%sedlex buf with + | Plus any_blank -> annot buf + (* comment *) + | ";;" -> + single_comment buf; + annot buf + | "(;" -> + comment buf; + annot buf + (* custom annotation *) + | "(@", name -> + let annotid = Utf8.lexeme buf in + let annotid = String.sub annotid 3 (String.length annotid - 4) in + let annotid = mk_string buf annotid in + if annotid = "" then Log.err "empty annotation id" + else + let items = annot buf in + Annot.Annot { annotid; items } :: annot buf + | "(@", Plus id_char -> + let annotid = Utf8.lexeme buf in + let annotid = String.sub annotid 2 (String.length annotid - 2) in + let annotid = mk_string buf annotid in + let items = annot buf in + Annot.Annot { annotid; items } :: annot buf + (* 1 *) + | "(" -> + let items = annot buf in + Annot.Parens items :: annot buf + | ")" -> [] + (* other *) + | int -> + let i = Utf8.lexeme buf in + Annot.Int i :: annot buf + | float -> + let f = Utf8.lexeme buf in + Annot.Float f :: annot buf + | id -> + let id = Utf8.lexeme buf in + let id = String.sub id 1 (String.length id - 1) in + Annot.Id id :: annot buf + | name -> + let name = Utf8.lexeme buf in + let name = String.sub name 1 (String.length name - 2) in + let name = mk_string buf name in + Annot.String name :: annot buf + | eof -> Log.err "eof in annotation" + | annot_atom -> + let annot_atom = Utf8.lexeme buf in + Annot.Atom annot_atom :: annot buf + | _ -> unexpected_character buf + let lexer buf = Sedlexing.with_tokenizer token buf diff --git a/src/parser/text_parser.mly b/src/parser/text_parser.mly index 9fad2eec4..3eee4643e 100644 --- a/src/parser/text_parser.mly +++ b/src/parser/text_parser.mly @@ -992,7 +992,8 @@ let inline_module_inner == | fields = list(par(module_field)); { let fields = List.flatten fields in let id = None in - { id; fields } + let annots = Annot.get_annots () in + { id; fields; annots } } let inline_module := diff --git a/src/script/spectest.ml b/src/script/spectest.ml index 7ea0e8264..4a5efbc19 100644 --- a/src/script/spectest.ml +++ b/src/script/spectest.ml @@ -207,4 +207,5 @@ let m = ; desc = Export_global (Some (Text "global_f64")) } ] + ; annots = [] } diff --git a/test/fuzz/gen.ml b/test/fuzz/gen.ml index 89d72e1ca..46262ea6f 100644 --- a/test/fuzz/gen.ml +++ b/test/fuzz/gen.ml @@ -345,4 +345,5 @@ let modul conf = let id = Some "m" in let* env = const Env.empty in let+ fields = fields (env conf) in - { id; fields } + let annots = [] in + { id; fields; annots } From 0aa2bfbe796f730a3718120e5f84e0f0b286b5ab Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Thu, 18 Jul 2024 15:38:09 +0200 Subject: [PATCH 02/51] add test for custom annotations --- test/script/annotations.t | 1 + 1 file changed, 1 insertion(+) create mode 100644 test/script/annotations.t diff --git a/test/script/annotations.t b/test/script/annotations.t new file mode 100644 index 000000000..16105f883 --- /dev/null +++ b/test/script/annotations.t @@ -0,0 +1 @@ + $ owi script --no-exhaustion reference/proposals/annotations/annotations.wast From 18bcfe19ccd4ae83e9ac156426e2a1dfe27a52dc Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Fri, 19 Jul 2024 10:56:31 +0200 Subject: [PATCH 03/51] remove misplaced test file --- src/parser/test.wat | 3 --- 1 file changed, 3 deletions(-) delete mode 100644 src/parser/test.wat diff --git a/src/parser/test.wat b/src/parser/test.wat deleted file mode 100644 index 886dcee41..000000000 --- a/src/parser/test.wat +++ /dev/null @@ -1,3 +0,0 @@ -(module - (@a df dcd feevsd 1 , c;vdaead 2dcecwef .) -) From f75e388527b9de25d7180151b88b8c4b36b26e54 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Fri, 19 Jul 2024 10:57:41 +0200 Subject: [PATCH 04/51] simplify code --- src/ast/annot.ml | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/ast/annot.ml b/src/ast/annot.ml index 3aca4c550..879c0e4f9 100644 --- a/src/ast/annot.ml +++ b/src/ast/annot.ml @@ -12,11 +12,7 @@ and item = | Parens of item list | Annot of annot -module NameMap = Map.Make (struct - type t = string - - let compare = compare -end) +module NameMap = Map.Make (String) let annot_recorder : annot list NameMap.t ref = ref NameMap.empty From 2e137e73413fbcd8045814ec0719fbb28cd44cb9 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Fri, 19 Jul 2024 11:04:44 +0200 Subject: [PATCH 05/51] use string equality test instead of polymorphic one --- src/parser/text_lexer.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parser/text_lexer.ml b/src/parser/text_lexer.ml index 5fe64f8d5..6a2923feb 100644 --- a/src/parser/text_lexer.ml +++ b/src/parser/text_lexer.ml @@ -448,7 +448,7 @@ let rec token buf = let annotid = Utf8.lexeme buf in let annotid = String.sub annotid 3 (String.length annotid - 4) in let annotid = mk_string buf annotid in - if annotid = "" then Log.err "empty annotation id" + if String.equal "" annotid then Log.err "empty annotation id" else let items = annot buf in Annot.(record_annot { annotid; items }); @@ -512,7 +512,7 @@ and annot buf = let annotid = Utf8.lexeme buf in let annotid = String.sub annotid 3 (String.length annotid - 4) in let annotid = mk_string buf annotid in - if annotid = "" then Log.err "empty annotation id" + if String.equal "" annotid then Log.err "empty annotation id" else let items = annot buf in Annot.Annot { annotid; items } :: annot buf From 7fabad71afe92a78d5e5b9ec0b5110f5f04fc281 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Fri, 19 Jul 2024 13:21:58 +0200 Subject: [PATCH 06/51] add pretty-printer of annotations --- src/ast/annot.ml | 20 ++++++++++++++++++++ src/ast/annot.mli | 2 ++ src/ast/text.ml | 4 +++- 3 files changed, 25 insertions(+), 1 deletion(-) diff --git a/src/ast/annot.ml b/src/ast/annot.ml index 879c0e4f9..376234f00 100644 --- a/src/ast/annot.ml +++ b/src/ast/annot.ml @@ -1,3 +1,5 @@ +open Format + type annot = { annotid : string ; items : item list @@ -14,6 +16,24 @@ and item = module NameMap = Map.Make (String) +(* TODO: find a better way to format annotations, possibly by + - recording extra format information when parsing + - defining rules specific to each sort of annotations *) + +let rec pp_annot fmt annot = + pp fmt "(annot %a@\n @[%a@]@\n)" pp_string annot.annotid + (pp_list ~pp_sep:pp_space pp_item) + annot.items + +and pp_item fmt = function + | Atom atom -> pp_string fmt atom + | String str -> pp_string fmt str + | Id id -> Types.pp_id fmt id + | Int i -> pp_string fmt i + | Float f -> pp_string fmt f + | Parens items -> pp_list ~pp_sep:pp_space pp_item fmt items + | Annot annot -> pp_annot fmt annot + let annot_recorder : annot list NameMap.t ref = ref NameMap.empty let find_nil key map = Option.value (NameMap.find_opt key map) ~default:[] diff --git a/src/ast/annot.mli b/src/ast/annot.mli index e1dff533a..18feaf437 100644 --- a/src/ast/annot.mli +++ b/src/ast/annot.mli @@ -12,6 +12,8 @@ and item = | Parens of item list | Annot of annot +val pp_annot : Format.formatter -> annot -> unit + val record_annot : annot -> unit val get_annots : ?name:string -> unit -> annot list diff --git a/src/ast/text.ml b/src/ast/text.ml index 7507d6bc9..34400adb8 100644 --- a/src/ast/text.ml +++ b/src/ast/text.ml @@ -100,7 +100,9 @@ type modul = } let pp_modul fmt (m : modul) = - pf fmt "(module%a@\n @[%a@]@\n)" pp_id_opt m.id + pp fmt "%a(module%a@\n @[%a@]@\n)" + (list ~sep:pp_newline pp_annot) + m.annots pp_id_opt m.id (list ~sep:pp_newline pp_module_field) m.fields From 9732b1d00c79ab1f7c9ed9bafe66ab96f399154a Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Tue, 23 Jul 2024 11:59:14 +0200 Subject: [PATCH 07/51] Adopt to Prelude --- src/ast/annot.ml | 17 ++++++++--------- src/ast/annot.mli | 4 +++- src/ast/text.ml | 2 +- 3 files changed, 12 insertions(+), 11 deletions(-) diff --git a/src/ast/annot.ml b/src/ast/annot.ml index 376234f00..0922f44c4 100644 --- a/src/ast/annot.ml +++ b/src/ast/annot.ml @@ -1,4 +1,4 @@ -open Format +open Fmt type annot = { annotid : string @@ -21,17 +21,16 @@ module NameMap = Map.Make (String) - defining rules specific to each sort of annotations *) let rec pp_annot fmt annot = - pp fmt "(annot %a@\n @[%a@]@\n)" pp_string annot.annotid - (pp_list ~pp_sep:pp_space pp_item) - annot.items + pf fmt "(annot %a@\n @[%a@]@\n)" Fmt.string annot.annotid + (list ~sep:sp pp_item) annot.items and pp_item fmt = function - | Atom atom -> pp_string fmt atom - | String str -> pp_string fmt str + | Atom atom -> Fmt.string fmt atom + | String str -> Fmt.string fmt str | Id id -> Types.pp_id fmt id - | Int i -> pp_string fmt i - | Float f -> pp_string fmt f - | Parens items -> pp_list ~pp_sep:pp_space pp_item fmt items + | Int i -> Fmt.string fmt i + | Float f -> Fmt.string fmt f + | Parens items -> list ~sep:sp pp_item fmt items | Annot annot -> pp_annot fmt annot let annot_recorder : annot list NameMap.t ref = ref NameMap.empty diff --git a/src/ast/annot.mli b/src/ast/annot.mli index 18feaf437..6aef721cf 100644 --- a/src/ast/annot.mli +++ b/src/ast/annot.mli @@ -1,3 +1,5 @@ +open Fmt + type annot = { annotid : string ; items : item list @@ -12,7 +14,7 @@ and item = | Parens of item list | Annot of annot -val pp_annot : Format.formatter -> annot -> unit +val pp_annot : formatter -> annot -> unit val record_annot : annot -> unit diff --git a/src/ast/text.ml b/src/ast/text.ml index 34400adb8..e550f9008 100644 --- a/src/ast/text.ml +++ b/src/ast/text.ml @@ -100,7 +100,7 @@ type modul = } let pp_modul fmt (m : modul) = - pp fmt "%a(module%a@\n @[%a@]@\n)" + pf fmt "%a(module%a@\n @[%a@]@\n)" (list ~sep:pp_newline pp_annot) m.annots pp_id_opt m.id (list ~sep:pp_newline pp_module_field) From dcecb0be3b67ab9560fa4d9e5aac7ad73426c75a Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Tue, 23 Jul 2024 13:18:50 +0200 Subject: [PATCH 08/51] delete Fmt qualified name --- src/ast/annot.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/ast/annot.ml b/src/ast/annot.ml index 0922f44c4..0f8ec73c8 100644 --- a/src/ast/annot.ml +++ b/src/ast/annot.ml @@ -21,15 +21,15 @@ module NameMap = Map.Make (String) - defining rules specific to each sort of annotations *) let rec pp_annot fmt annot = - pf fmt "(annot %a@\n @[%a@]@\n)" Fmt.string annot.annotid - (list ~sep:sp pp_item) annot.items + pf fmt "(@%a@\n @[%a@]@\n)" string annot.annotid (list ~sep:sp pp_item) + annot.items and pp_item fmt = function - | Atom atom -> Fmt.string fmt atom - | String str -> Fmt.string fmt str + | Atom atom -> string fmt atom + | String str -> string fmt str | Id id -> Types.pp_id fmt id - | Int i -> Fmt.string fmt i - | Float f -> Fmt.string fmt f + | Int i -> string fmt i + | Float f -> string fmt f | Parens items -> list ~sep:sp pp_item fmt items | Annot annot -> pp_annot fmt annot From f1c96d9bb0651826b5cbbef1db8a2d88b6efd816 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Fri, 26 Jul 2024 18:34:06 +0200 Subject: [PATCH 09/51] use hashmap to reord annotations --- src/ast/annot.ml | 23 +++++------------------ 1 file changed, 5 insertions(+), 18 deletions(-) diff --git a/src/ast/annot.ml b/src/ast/annot.ml index 0f8ec73c8..83b2eaabf 100644 --- a/src/ast/annot.ml +++ b/src/ast/annot.ml @@ -14,8 +14,6 @@ and item = | Parens of item list | Annot of annot -module NameMap = Map.Make (String) - (* TODO: find a better way to format annotations, possibly by - recording extra format information when parsing - defining rules specific to each sort of annotations *) @@ -33,22 +31,11 @@ and pp_item fmt = function | Parens items -> list ~sep:sp pp_item fmt items | Annot annot -> pp_annot fmt annot -let annot_recorder : annot list NameMap.t ref = ref NameMap.empty - -let find_nil key map = Option.value (NameMap.find_opt key map) ~default:[] +let annot_recorder : (string, annot) Hashtbl.t = Hashtbl.create 17 -let record_annot annot = - let old = find_nil annot.annotid !annot_recorder in - annot_recorder := NameMap.add annot.annotid (annot :: old) !annot_recorder +let record_annot annot = Hashtbl.add annot_recorder annot.annotid annot let get_annots ?name () = - let annots = - match name with - | Some name -> find_nil name !annot_recorder - | None -> - List.concat_map - (fun (_, annots) -> annots) - (NameMap.to_list !annot_recorder) - in - annot_recorder := NameMap.empty; - annots + match name with + | Some name -> Hashtbl.find_all annot_recorder name + | None -> Hashtbl.fold (fun _ annot acc -> annot :: acc) annot_recorder [] From 8fa8722886c668f3b177e047b6f9204d579236ec Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Sat, 27 Jul 2024 10:37:22 +0200 Subject: [PATCH 10/51] use s-expression to store annotations --- src/ast/annot.ml | 28 +++------------------- src/ast/annot.mli | 11 +-------- src/data_structures/sexp.ml | 11 +++++++++ src/data_structures/sexp.mli | 7 ++++++ src/dune | 1 + src/parser/text_lexer.ml | 46 ++++++------------------------------ src/parser/text_parser.mly | 1 + 7 files changed, 31 insertions(+), 74 deletions(-) create mode 100644 src/data_structures/sexp.ml create mode 100644 src/data_structures/sexp.mli diff --git a/src/ast/annot.ml b/src/ast/annot.ml index 83b2eaabf..9b4ea49b4 100644 --- a/src/ast/annot.ml +++ b/src/ast/annot.ml @@ -2,35 +2,13 @@ open Fmt type annot = { annotid : string - ; items : item list + ; items : Sexp.t } -and item = - | Atom of string - | String of string - | Id of string - | Int of string - | Float of string - | Parens of item list - | Annot of annot - -(* TODO: find a better way to format annotations, possibly by - - recording extra format information when parsing - - defining rules specific to each sort of annotations *) - -let rec pp_annot fmt annot = - pf fmt "(@%a@\n @[%a@]@\n)" string annot.annotid (list ~sep:sp pp_item) +let pp_annot fmt annot = + pf fmt "(@%a@\n @[%a@]@\n)" string annot.annotid Sexp.pp_sexp annot.items -and pp_item fmt = function - | Atom atom -> string fmt atom - | String str -> string fmt str - | Id id -> Types.pp_id fmt id - | Int i -> string fmt i - | Float f -> string fmt f - | Parens items -> list ~sep:sp pp_item fmt items - | Annot annot -> pp_annot fmt annot - let annot_recorder : (string, annot) Hashtbl.t = Hashtbl.create 17 let record_annot annot = Hashtbl.add annot_recorder annot.annotid annot diff --git a/src/ast/annot.mli b/src/ast/annot.mli index 6aef721cf..708582c7c 100644 --- a/src/ast/annot.mli +++ b/src/ast/annot.mli @@ -2,18 +2,9 @@ open Fmt type annot = { annotid : string - ; items : item list + ; items : Sexp.t } -and item = - | Atom of string - | String of string - | Id of string - | Int of string - | Float of string - | Parens of item list - | Annot of annot - val pp_annot : formatter -> annot -> unit val record_annot : annot -> unit diff --git a/src/data_structures/sexp.ml b/src/data_structures/sexp.ml new file mode 100644 index 000000000..457f24a39 --- /dev/null +++ b/src/data_structures/sexp.ml @@ -0,0 +1,11 @@ +open Fmt + +type t = + | Atom of string + | List of t list + +let rec pp_sexp fmt = function + | Atom str -> pf fmt "%s" str + | List [] -> pf fmt "()" + | List (_ as l) -> + pf fmt "@[(%a)@]" (list ~sep:(fun fmt () -> pf fmt "@ ") pp_sexp) l diff --git a/src/data_structures/sexp.mli b/src/data_structures/sexp.mli new file mode 100644 index 000000000..a50a04f9e --- /dev/null +++ b/src/data_structures/sexp.mli @@ -0,0 +1,7 @@ +open Fmt + +type t = + | Atom of string + | List of t list + +val pp_sexp : formatter -> t -> unit diff --git a/src/dune b/src/dune index dbf489a8b..515cee0f7 100644 --- a/src/dune +++ b/src/dune @@ -59,6 +59,7 @@ rewrite runtime script + sexp solver symbolic symbolic_choice diff --git a/src/parser/text_lexer.ml b/src/parser/text_lexer.ml index 6a2923feb..6dc78d983 100644 --- a/src/parser/text_lexer.ml +++ b/src/parser/text_lexer.ml @@ -121,7 +121,8 @@ let bad_id = [%sedlex.regexp? id, Plus name] let bad_num = [%sedlex.regexp? num, Plus id] let annot_atom = - [%sedlex.regexp? Plus (id_char | name) | ',' | ';' | '[' | ']' | '{' | '}'] + [%sedlex.regexp? + num | Plus (id_char | name) | ',' | ';' | '[' | ']' | '{' | '}'] let keywords = let tbl = Hashtbl.create 512 in @@ -450,14 +451,14 @@ let rec token buf = let annotid = mk_string buf annotid in if String.equal "" annotid then Log.err "empty annotation id" else - let items = annot buf in + let items = Sexp.List (annot buf) in Annot.(record_annot { annotid; items }); token buf | "(@", Plus id_char -> let annotid = Utf8.lexeme buf in let annotid = String.sub annotid 2 (String.length annotid - 2) in let annotid = mk_string buf annotid in - let items = annot buf in + let items = Sexp.List (annot buf) in Annot.(record_annot { annotid; items }); token buf | "(@" -> Log.err "empty annotation id" @@ -500,53 +501,20 @@ and single_comment buf = and annot buf = match%sedlex buf with | Plus any_blank -> annot buf - (* comment *) | ";;" -> single_comment buf; annot buf | "(;" -> comment buf; annot buf - (* custom annotation *) - | "(@", name -> - let annotid = Utf8.lexeme buf in - let annotid = String.sub annotid 3 (String.length annotid - 4) in - let annotid = mk_string buf annotid in - if String.equal "" annotid then Log.err "empty annotation id" - else - let items = annot buf in - Annot.Annot { annotid; items } :: annot buf - | "(@", Plus id_char -> - let annotid = Utf8.lexeme buf in - let annotid = String.sub annotid 2 (String.length annotid - 2) in - let annotid = mk_string buf annotid in - let items = annot buf in - Annot.Annot { annotid; items } :: annot buf - (* 1 *) | "(" -> let items = annot buf in - Annot.Parens items :: annot buf + Sexp.List items :: annot buf | ")" -> [] - (* other *) - | int -> - let i = Utf8.lexeme buf in - Annot.Int i :: annot buf - | float -> - let f = Utf8.lexeme buf in - Annot.Float f :: annot buf - | id -> - let id = Utf8.lexeme buf in - let id = String.sub id 1 (String.length id - 1) in - Annot.Id id :: annot buf - | name -> - let name = Utf8.lexeme buf in - let name = String.sub name 1 (String.length name - 2) in - let name = mk_string buf name in - Annot.String name :: annot buf - | eof -> Log.err "eof in annotation" | annot_atom -> let annot_atom = Utf8.lexeme buf in - Annot.Atom annot_atom :: annot buf + Sexp.Atom annot_atom :: annot buf + | eof -> Log.err "eof in annotation" | _ -> unexpected_character buf let lexer buf = Sedlexing.with_tokenizer token buf diff --git a/src/parser/text_parser.mly b/src/parser/text_parser.mly index 3eee4643e..29645ea08 100644 --- a/src/parser/text_parser.mly +++ b/src/parser/text_parser.mly @@ -993,6 +993,7 @@ let inline_module_inner == let fields = List.flatten fields in let id = None in let annots = Annot.get_annots () in + let () = Fmt.pr "%a" (Fmt.list ~sep:(fun _ _ -> Fmt.pr "@\n ") Annot.pp_annot) annots in { id; fields; annots } } From 2c6b5e67f848463d2dc95fc9cb4368df6a598ff8 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Mon, 29 Jul 2024 12:23:35 +0200 Subject: [PATCH 11/51] add function contract annotations --- src/{ast => annot}/annot.ml | 4 ++-- src/annot/annot.mli | 12 +++++++++++ src/annot/function_contract.ml | 36 +++++++++++++++++++++++++++++++++ src/annot/function_contract.mli | 9 +++++++++ src/ast/annot.mli | 12 ----------- src/ast/text.ml | 5 ++--- src/bin/owi.ml | 3 +++ src/dune | 1 + src/utils/result.ml | 3 +++ src/utils/result.mli | 3 +++ 10 files changed, 71 insertions(+), 17 deletions(-) rename src/{ast => annot}/annot.ml (83%) create mode 100644 src/annot/annot.mli create mode 100644 src/annot/function_contract.ml create mode 100644 src/annot/function_contract.mli delete mode 100644 src/ast/annot.mli diff --git a/src/ast/annot.ml b/src/annot/annot.ml similarity index 83% rename from src/ast/annot.ml rename to src/annot/annot.ml index 9b4ea49b4..24cdb944f 100644 --- a/src/ast/annot.ml +++ b/src/annot/annot.ml @@ -1,6 +1,6 @@ open Fmt -type annot = +type t = { annotid : string ; items : Sexp.t } @@ -9,7 +9,7 @@ let pp_annot fmt annot = pf fmt "(@%a@\n @[%a@]@\n)" string annot.annotid Sexp.pp_sexp annot.items -let annot_recorder : (string, annot) Hashtbl.t = Hashtbl.create 17 +let annot_recorder : (string, t) Hashtbl.t = Hashtbl.create 17 let record_annot annot = Hashtbl.add annot_recorder annot.annotid annot diff --git a/src/annot/annot.mli b/src/annot/annot.mli new file mode 100644 index 000000000..b55a4a2fd --- /dev/null +++ b/src/annot/annot.mli @@ -0,0 +1,12 @@ +open Fmt + +type t = + { annotid : string + ; items : Sexp.t + } + +val pp_annot : formatter -> t -> unit + +val record_annot : t -> unit + +val get_annots : ?name:string -> unit -> t list diff --git a/src/annot/function_contract.ml b/src/annot/function_contract.ml new file mode 100644 index 000000000..c7715bdb4 --- /dev/null +++ b/src/annot/function_contract.ml @@ -0,0 +1,36 @@ +open Syntax +open Sexp + +let name = "custom" + +type prop = string + +type t = + { func : string + ; preconditions : prop list + ; postconditions : prop list + } + +let parse_prop _ = "" + +let parse_func = function + | List (Atom func :: items) -> Ok (func, items) + | _ -> Error `Unknown_annotation_object + +let parse_clause (preconditions, postconditions) = function + | List (Atom clauseid :: rest) -> ( + match clauseid with + | "requires" -> Ok (parse_prop rest :: preconditions, postconditions) + | "ensures" -> Ok (preconditions, parse_prop rest :: postconditions) + | _ -> Error `Unknown_annotation_clause ) + | _ -> Error `Unknown_annotation_clause + +let parse_clauses = list_fold_left parse_clause ([], []) + +let parse Annot.{ annotid; items } = + if not (String.equal annotid name) then + Error (`Annotation_id_incorrect annotid) + else + let* func, items' = parse_func items in + let* preconditions, postconditions = parse_clauses items' in + Ok { func; preconditions; postconditions } diff --git a/src/annot/function_contract.mli b/src/annot/function_contract.mli new file mode 100644 index 000000000..44e5c8af8 --- /dev/null +++ b/src/annot/function_contract.mli @@ -0,0 +1,9 @@ +type prop = string + +type t = + { func : string + ; preconditions : prop list + ; postconditions : prop list + } + +val parse : Annot.t -> t Result.t diff --git a/src/ast/annot.mli b/src/ast/annot.mli deleted file mode 100644 index 708582c7c..000000000 --- a/src/ast/annot.mli +++ /dev/null @@ -1,12 +0,0 @@ -open Fmt - -type annot = - { annotid : string - ; items : Sexp.t - } - -val pp_annot : formatter -> annot -> unit - -val record_annot : annot -> unit - -val get_annots : ?name:string -> unit -> annot list diff --git a/src/ast/text.ml b/src/ast/text.ml index e550f9008..041bcba49 100644 --- a/src/ast/text.ml +++ b/src/ast/text.ml @@ -4,7 +4,6 @@ open Fmt open Types -open Annot let symbolic v = Text v @@ -96,12 +95,12 @@ let pp_module_field fmt = function type modul = { id : string option ; fields : module_field list - ; annots : annot list + ; annots : Annot.t list } let pp_modul fmt (m : modul) = pf fmt "%a(module%a@\n @[%a@]@\n)" - (list ~sep:pp_newline pp_annot) + (list ~sep:pp_newline Annot.pp_annot) m.annots pp_id_opt m.id (list ~sep:pp_newline pp_module_field) m.fields diff --git a/src/bin/owi.ml b/src/bin/owi.ml index 078bfa254..5cdfce742 100644 --- a/src/bin/owi.ml +++ b/src/bin/owi.ml @@ -368,6 +368,9 @@ let exit_code = | `Unknown_type _id -> 52 | `Unsupported_file_extension _ext -> 53 | `Failed_with_but_expected (_got, _expected) -> 54 + | `Annotation_id_incorrect _annotid -> 55 + | `Unknown_annotation_clause -> 56 + | `Unknown_annotation_object -> 57 end end | Error e -> ( diff --git a/src/dune b/src/dune index 515cee0f7..db8d06c07 100644 --- a/src/dune +++ b/src/dune @@ -39,6 +39,7 @@ env_id float32 float64 + function_contract func_id func_intf grouped diff --git a/src/utils/result.ml b/src/utils/result.ml index 9f6270ddb..30c12b51d 100644 --- a/src/utils/result.ml +++ b/src/utils/result.ml @@ -59,6 +59,9 @@ type err = | `Unknown_table of Types.text Types.indice | `Unknown_type of Types.text Types.indice | `Unsupported_file_extension of string + | `Annotation_id_incorrect of string + | `Unknown_annotation_clause + | `Unknown_annotation_object ] type 'a t = ('a, err) Prelude.Result.t diff --git a/src/utils/result.mli b/src/utils/result.mli index 8eacfbbc5..94dd8f28e 100644 --- a/src/utils/result.mli +++ b/src/utils/result.mli @@ -59,6 +59,9 @@ type err = | `Unknown_table of Types.text Types.indice | `Unknown_type of Types.text Types.indice | `Unsupported_file_extension of string + | `Annotation_id_incorrect of string + | `Unknown_annotation_clause + | `Unknown_annotation_object ] type 'a t = ('a, err) Prelude.Result.t From ff2ec9c997c10508b466f0ab9e207f33a2fa4952 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Mon, 29 Jul 2024 14:48:28 +0200 Subject: [PATCH 12/51] replace let* with let+ --- src/annot/function_contract.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/annot/function_contract.ml b/src/annot/function_contract.ml index c7715bdb4..d3f1a2fc7 100644 --- a/src/annot/function_contract.ml +++ b/src/annot/function_contract.ml @@ -32,5 +32,5 @@ let parse Annot.{ annotid; items } = Error (`Annotation_id_incorrect annotid) else let* func, items' = parse_func items in - let* preconditions, postconditions = parse_clauses items' in - Ok { func; preconditions; postconditions } + let+ preconditions, postconditions = parse_clauses items' in + { func; preconditions; postconditions } From 18bb3e14446282a01d11b468fd9893ffc3fa8dfa Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Wed, 31 Jul 2024 17:02:09 +0200 Subject: [PATCH 13/51] definition of function contracts --- src/annot/contract.ml | 34 +++++++++++++++++++++++++++++++ src/annot/contract.mli | 34 +++++++++++++++++++++++++++++++ src/annot/function_contract.ml | 36 --------------------------------- src/annot/function_contract.mli | 9 --------- src/dune | 2 +- 5 files changed, 69 insertions(+), 46 deletions(-) create mode 100644 src/annot/contract.ml create mode 100644 src/annot/contract.mli delete mode 100644 src/annot/function_contract.ml delete mode 100644 src/annot/function_contract.mli diff --git a/src/annot/contract.ml b/src/annot/contract.ml new file mode 100644 index 000000000..820b6eb5a --- /dev/null +++ b/src/annot/contract.ml @@ -0,0 +1,34 @@ +open Types + +type nonrec binpred = + | Ge + | Gt + | Le + | Lt + | Eq + | Neq + +type nonrec unconnect = Neg + +type nonrec binconnect = + | And + | Or + | Imply + | Equiv + +type 'a prop = + | Const of bool + | BinPred of binpred * 'a term * 'a term + | UnConnect of unconnect * 'a prop + | BinConnect of binconnect * 'a prop * 'a prop + +and 'a term = + | Int of int + | Global of 'a indice + | Result + +type 'a t = + { func : 'a indice + ; preconditions : 'a prop list + ; postconditions : 'a prop list + } diff --git a/src/annot/contract.mli b/src/annot/contract.mli new file mode 100644 index 000000000..820b6eb5a --- /dev/null +++ b/src/annot/contract.mli @@ -0,0 +1,34 @@ +open Types + +type nonrec binpred = + | Ge + | Gt + | Le + | Lt + | Eq + | Neq + +type nonrec unconnect = Neg + +type nonrec binconnect = + | And + | Or + | Imply + | Equiv + +type 'a prop = + | Const of bool + | BinPred of binpred * 'a term * 'a term + | UnConnect of unconnect * 'a prop + | BinConnect of binconnect * 'a prop * 'a prop + +and 'a term = + | Int of int + | Global of 'a indice + | Result + +type 'a t = + { func : 'a indice + ; preconditions : 'a prop list + ; postconditions : 'a prop list + } diff --git a/src/annot/function_contract.ml b/src/annot/function_contract.ml deleted file mode 100644 index d3f1a2fc7..000000000 --- a/src/annot/function_contract.ml +++ /dev/null @@ -1,36 +0,0 @@ -open Syntax -open Sexp - -let name = "custom" - -type prop = string - -type t = - { func : string - ; preconditions : prop list - ; postconditions : prop list - } - -let parse_prop _ = "" - -let parse_func = function - | List (Atom func :: items) -> Ok (func, items) - | _ -> Error `Unknown_annotation_object - -let parse_clause (preconditions, postconditions) = function - | List (Atom clauseid :: rest) -> ( - match clauseid with - | "requires" -> Ok (parse_prop rest :: preconditions, postconditions) - | "ensures" -> Ok (preconditions, parse_prop rest :: postconditions) - | _ -> Error `Unknown_annotation_clause ) - | _ -> Error `Unknown_annotation_clause - -let parse_clauses = list_fold_left parse_clause ([], []) - -let parse Annot.{ annotid; items } = - if not (String.equal annotid name) then - Error (`Annotation_id_incorrect annotid) - else - let* func, items' = parse_func items in - let+ preconditions, postconditions = parse_clauses items' in - { func; preconditions; postconditions } diff --git a/src/annot/function_contract.mli b/src/annot/function_contract.mli deleted file mode 100644 index 44e5c8af8..000000000 --- a/src/annot/function_contract.mli +++ /dev/null @@ -1,9 +0,0 @@ -type prop = string - -type t = - { func : string - ; preconditions : prop list - ; postconditions : prop list - } - -val parse : Annot.t -> t Result.t diff --git a/src/dune b/src/dune index db8d06c07..483309e1e 100644 --- a/src/dune +++ b/src/dune @@ -39,7 +39,7 @@ env_id float32 float64 - function_contract + contract func_id func_intf grouped From 76d7b533bb066a3028d26010b839de3ea83a6c32 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Wed, 31 Jul 2024 17:30:31 +0200 Subject: [PATCH 14/51] add custom section to binary module --- src/ast/binary.ml | 6 ++++ src/ast/binary_to_text.ml | 3 +- src/parser/binary_parser.ml | 59 ++++++++++++++++++++--------------- src/text_to_binary/rewrite.ml | 2 +- 4 files changed, 42 insertions(+), 28 deletions(-) diff --git a/src/ast/binary.ml b/src/ast/binary.ml index 15bc972d2..a33a9c2f7 100644 --- a/src/ast/binary.ml +++ b/src/ast/binary.ml @@ -48,6 +48,10 @@ type elem = ; mode : elem_mode } +type custom = + | Uninterpreted of (string, Sexp.t) Either.t + | Contract of binary Contract.t + type modul = { id : string option ; types : binary rec_type array @@ -60,6 +64,7 @@ type modul = ; data : data array ; exports : exports ; start : int option + ; custom : custom list } let empty_modul = @@ -73,4 +78,5 @@ let empty_modul = ; data = [||] ; exports = { global = []; mem = []; table = []; func = [] } ; start = None + ; custom = [] } diff --git a/src/ast/binary_to_text.ml b/src/ast/binary_to_text.ml index e696ce579..554b2c44b 100644 --- a/src/ast/binary_to_text.ml +++ b/src/ast/binary_to_text.ml @@ -235,7 +235,8 @@ let from_exports (exports : Binary.exports) : Text.module_field list = let from_start = function None -> [] | Some n -> [ MStart (Raw n) ] let modul - { Binary.id; types; global; table; mem; func; elem; data; start; exports } = + { Binary.id; types; global; table; mem; func; elem; data; start; exports; _ } + = let fields = from_types types @ from_global global @ from_table table @ from_mem mem @ from_func func @ from_elem elem @ from_data data @ from_exports exports diff --git a/src/parser/binary_parser.ml b/src/parser/binary_parser.ml index 4945a8527..0e78c37c3 100644 --- a/src/parser/binary_parser.ml +++ b/src/parser/binary_parser.ml @@ -927,7 +927,7 @@ let parse_many_custom_section input = let sections_iterate (input : Input.t) = (* Custom *) - let* _custom_sections, input = parse_many_custom_section input in + let* custom_sections, input = parse_many_custom_section input in (* Type *) let* types, input = @@ -936,8 +936,8 @@ let sections_iterate (input : Input.t) = let types = Array.of_list types in (* Custom *) - let* _custom_sections', input = parse_many_custom_section input in - let _custom_sections = _custom_sections @ _custom_sections' in + let* custom_sections', input = parse_many_custom_section input in + let custom_sections = custom_sections @ custom_sections' in (* Imports *) let* import_section, input = @@ -945,8 +945,8 @@ let sections_iterate (input : Input.t) = in (* Custom *) - let* _custom_sections', input = parse_many_custom_section input in - let _custom_sections = _custom_sections @ _custom_sections' in + let* custom_sections', input = parse_many_custom_section input in + let custom_sections = custom_sections @ custom_sections' in (* Function *) let* function_section, input = @@ -954,8 +954,8 @@ let sections_iterate (input : Input.t) = in (* Custom *) - let* _custom_sections', input = parse_many_custom_section input in - let _custom_sections = _custom_sections @ _custom_sections' in + let* custom_sections', input = parse_many_custom_section input in + let custom_sections = custom_sections @ custom_sections' in (* Tables *) let* table_section, input = @@ -963,8 +963,8 @@ let sections_iterate (input : Input.t) = in (* Custom *) - let* _custom_sections', input = parse_many_custom_section input in - let _custom_sections = _custom_sections @ _custom_sections' in + let* custom_sections', input = parse_many_custom_section input in + let custom_sections = custom_sections @ custom_sections' in (* Memory *) let* memory_section, input = @@ -972,8 +972,8 @@ let sections_iterate (input : Input.t) = in (* Custom *) - let* _custom_sections', input = parse_many_custom_section input in - let _custom_sections = _custom_sections @ _custom_sections' in + let* custom_sections', input = parse_many_custom_section input in + let custom_sections = custom_sections @ custom_sections' in (* Globals *) let* global_section, input = @@ -982,8 +982,8 @@ let sections_iterate (input : Input.t) = in (* Custom *) - let* _custom_sections', input = parse_many_custom_section input in - let _custom_sections = _custom_sections @ _custom_sections' in + let* custom_sections', input = parse_many_custom_section input in + let custom_sections = custom_sections @ custom_sections' in (* Exports *) let* export_section, input = @@ -991,8 +991,8 @@ let sections_iterate (input : Input.t) = in (* Custom *) - let* _custom_sections', input = parse_many_custom_section input in - let _custom_sections = _custom_sections @ _custom_sections' in + let* custom_sections', input = parse_many_custom_section input in + let custom_sections = custom_sections @ custom_sections' in (* Start *) let* start_section, input = @@ -1002,8 +1002,8 @@ let sections_iterate (input : Input.t) = in (* Custom *) - let* _custom_sections', input = parse_many_custom_section input in - let _custom_sections = _custom_sections @ _custom_sections' in + let* custom_sections', input = parse_many_custom_section input in + let custom_sections = custom_sections @ custom_sections' in (* Elements *) let* element_section, input = @@ -1012,8 +1012,8 @@ let sections_iterate (input : Input.t) = in (* Custom *) - let* _custom_sections', input = parse_many_custom_section input in - let _custom_sections = _custom_sections @ _custom_sections' in + let* custom_sections', input = parse_many_custom_section input in + let custom_sections = custom_sections @ custom_sections' in (* Data_count *) let* data_count_section, input = @@ -1023,8 +1023,8 @@ let sections_iterate (input : Input.t) = in (* Custom *) - let* _custom_sections', input = parse_many_custom_section input in - let _custom_sections = _custom_sections @ _custom_sections' in + let* custom_sections', input = parse_many_custom_section input in + let custom_sections = custom_sections @ custom_sections' in (* Code *) let* code_section, input = @@ -1038,8 +1038,8 @@ let sections_iterate (input : Input.t) = in (* Custom *) - let* _custom_sections', input = parse_many_custom_section input in - let _custom_sections = _custom_sections @ _custom_sections' in + let* custom_sections', input = parse_many_custom_section input in + let custom_sections = custom_sections @ custom_sections' in (* Data *) let+ data, input = @@ -1066,9 +1066,8 @@ let sections_iterate (input : Input.t) = in (* Custom *) - (* TODO: actually use the various custom sections *) - let* _custom_sections', input = parse_many_custom_section input in - let _custom_sections = _custom_sections @ _custom_sections' in + let* custom_sections', input = parse_many_custom_section input in + let custom_sections = custom_sections @ custom_sections' in let+ () = if not @@ Input.is_empty input then Error (`Msg "malformed section id") @@ -1188,6 +1187,13 @@ let sections_iterate (input : Input.t) = } in + (* Custom *) + let custom = + List.filter_map + (Option.map (fun x -> Uninterpreted (Either.Left x))) + custom_sections + in + { id = None ; types ; global @@ -1198,6 +1204,7 @@ let sections_iterate (input : Input.t) = ; start = start_section ; data ; exports + ; custom } let from_string content = diff --git a/src/text_to_binary/rewrite.ml b/src/text_to_binary/rewrite.ml index 74b3e44a1..6e0a1e2c1 100644 --- a/src/text_to_binary/rewrite.ml +++ b/src/text_to_binary/rewrite.ml @@ -400,6 +400,6 @@ let modul (modul : Assigned.t) : Binary.modul Result.t = let func = Named.to_array func in let modul : Binary.modul = - { id; mem; table; types; global; elem; data; exports; func; start } + { id; mem; table; types; global; elem; data; exports; func; start; custom = [] } in modul From 240b77a6c1d3cb0177a98dc077213ef603c4a8b3 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Fri, 2 Aug 2024 14:00:46 +0200 Subject: [PATCH 15/51] add function contracts as one kind of annotation, to be parsed either from s-expressions or directly from code --- src/annot/annot.ml | 19 +++++-- src/annot/annot.mli | 11 +++-- src/annot/contract.ml | 36 ++++---------- src/annot/contract.mli | 31 ++---------- src/annot/spec.ml | 98 +++++++++++++++++++++++++++++++++++++ src/ast/binary.ml | 4 +- src/ast/text.ml | 2 +- src/dune | 1 + src/parser/binary_parser.ml | 4 +- src/parser/text_lexer.ml | 4 +- 10 files changed, 140 insertions(+), 70 deletions(-) create mode 100644 src/annot/spec.ml diff --git a/src/annot/annot.ml b/src/annot/annot.ml index 24cdb944f..645ba793b 100644 --- a/src/annot/annot.ml +++ b/src/annot/annot.ml @@ -1,17 +1,26 @@ open Fmt +open Types type t = { annotid : string ; items : Sexp.t } -let pp_annot fmt annot = - pf fmt "(@%a@\n @[%a@]@\n)" string annot.annotid Sexp.pp_sexp - annot.items +type 'a annot = + | Contract of 'a Contract.t + | Annot of t -let annot_recorder : (string, t) Hashtbl.t = Hashtbl.create 17 +let pp_annot fmt = function + | Contract contract -> + pf fmt "(@%a@\n @[%a@]@\n)" string "contract" Contract.pp_contract + contract + | Annot annot -> + pf fmt "(@%a@\n @[%a@]@\n)" string annot.annotid Sexp.pp_sexp + annot.items -let record_annot annot = Hashtbl.add annot_recorder annot.annotid annot +let annot_recorder : (string, text annot) Hashtbl.t = Hashtbl.create 17 + +let record_annot annotid annot = Hashtbl.add annot_recorder annotid annot let get_annots ?name () = match name with diff --git a/src/annot/annot.mli b/src/annot/annot.mli index b55a4a2fd..f6d878cf6 100644 --- a/src/annot/annot.mli +++ b/src/annot/annot.mli @@ -1,12 +1,17 @@ open Fmt +open Types type t = { annotid : string ; items : Sexp.t } -val pp_annot : formatter -> t -> unit +type 'a annot = + | Contract of 'a Contract.t + | Annot of t -val record_annot : t -> unit +val pp_annot : formatter -> text annot -> unit -val get_annots : ?name:string -> unit -> t list +val record_annot : string -> text annot -> unit + +val get_annots : ?name:string -> unit -> text annot list diff --git a/src/annot/contract.ml b/src/annot/contract.ml index 820b6eb5a..5bb2d754c 100644 --- a/src/annot/contract.ml +++ b/src/annot/contract.ml @@ -1,34 +1,16 @@ +open Fmt open Types - -type nonrec binpred = - | Ge - | Gt - | Le - | Lt - | Eq - | Neq - -type nonrec unconnect = Neg - -type nonrec binconnect = - | And - | Or - | Imply - | Equiv - -type 'a prop = - | Const of bool - | BinPred of binpred * 'a term * 'a term - | UnConnect of unconnect * 'a prop - | BinConnect of binconnect * 'a prop * 'a prop - -and 'a term = - | Int of int - | Global of 'a indice - | Result +open Spec type 'a t = { func : 'a indice ; preconditions : 'a prop list ; postconditions : 'a prop list } + +let pp_contract fmt { func; preconditions; postconditions } = + pf fmt "%a@,%a@,%a@," pp_indice func + (list ~sep:pp_newline pp_prop) + preconditions + (list ~sep:pp_newline pp_prop) + postconditions diff --git a/src/annot/contract.mli b/src/annot/contract.mli index 820b6eb5a..1c8607d88 100644 --- a/src/annot/contract.mli +++ b/src/annot/contract.mli @@ -1,34 +1,11 @@ +open Fmt open Types - -type nonrec binpred = - | Ge - | Gt - | Le - | Lt - | Eq - | Neq - -type nonrec unconnect = Neg - -type nonrec binconnect = - | And - | Or - | Imply - | Equiv - -type 'a prop = - | Const of bool - | BinPred of binpred * 'a term * 'a term - | UnConnect of unconnect * 'a prop - | BinConnect of binconnect * 'a prop * 'a prop - -and 'a term = - | Int of int - | Global of 'a indice - | Result +open Spec type 'a t = { func : 'a indice ; preconditions : 'a prop list ; postconditions : 'a prop list } + +val pp_contract : formatter -> 'a t -> unit diff --git a/src/annot/spec.ml b/src/annot/spec.ml new file mode 100644 index 000000000..eefd4ff57 --- /dev/null +++ b/src/annot/spec.ml @@ -0,0 +1,98 @@ +open Types +open Fmt + +(* + text: + (local index) + (global index) + (binder index) + string_id + + binary: + (local index) + (global index) + (binder index) +*) + +type nonrec binpred = + | Ge + | Gt + | Le + | Lt + | Eq + | Neq + +type nonrec unconnect = Neg + +type nonrec binconnect = + | And + | Or + | Imply + | Equiv + +type nonrec binder = + | Forall + | Exists + +type nonrec binder_type = num_type + +type 'a prop = + | Const : bool -> 'a prop + | BinPred : binpred * 'a term * 'a term -> 'a prop + | UnConnect : unconnect * 'a prop -> 'a prop + | BinConnect : binconnect * 'a prop * 'a prop -> 'a prop + | Binder : binder * binder_type * string option * 'a prop -> 'a prop + +and 'a term = + | Int32 : int32 -> 'a term + | Var : text indice -> text term + | GlobalVar : 'a indice -> 'a term + | BinderVar : 'a indice -> 'a term + | Result : 'a term + +let pp_bool fmt = function true -> pf fmt "true" | false -> pf fmt "false" + +let pp_binpred fmt = function + | Ge -> pf fmt ">=" + | Gt -> pf fmt ">" + | Le -> pf fmt "<=" + | Lt -> pf fmt "<" + | Eq -> pf fmt "=" + | Neq -> pf fmt "!=" + +let pp_unconnect fmt = function Neg -> pf fmt "!" + +let pp_binconnect fmt = function + | And -> pf fmt "&&" + | Or -> pf fmt "||" + | Imply -> pf fmt "==>" + | Equiv -> pf fmt "<==>" + +let pp_binder fmt = function + | Forall -> pf fmt {|\forall|} + | Exists -> pf fmt {|\exists|} + +let pp_binder_type = pp_num_type + +let rec pp_prop fmt = function + | Const bool -> pf fmt {|"\%a"|} pp_bool bool + | BinPred (b, tm1, tm2) -> + pf fmt "@[%a@ %a@ %a@]" pp_term tm1 pp_binpred b pp_term tm2 + | UnConnect (u, pr1) -> pf fmt "@[%a@ %a@]" pp_unconnect u pp_prop pr1 + | BinConnect (b, pr1, pr2) -> + pf fmt "@[%a@ %a@ %a@]" pp_prop pr1 pp_binconnect b pp_prop pr2 + | Binder (b, bt, id_opt, pr1) -> ( + match id_opt with + | Some id -> + pf fmt "@[%a@ %a@ %a, %a@]" pp_binder b pp_binder_type bt pp_id id + pp_prop pr1 + | None -> + pf fmt "@[%a@ %a@, %a@]" pp_binder b pp_binder_type bt pp_prop pr1 ) + +and pp_term (type e) fmt (tm : e term) = + match tm with + | Int32 i -> pf fmt "%i" (Int32.to_int i) + | Var ind -> pf fmt "%a" pp_indice ind + | GlobalVar ind -> pf fmt "global.%a" pp_indice ind + | BinderVar ind -> pf fmt "binder.%a" pp_indice ind + | Result -> pf fmt {|\result|} diff --git a/src/ast/binary.ml b/src/ast/binary.ml index a33a9c2f7..f2435a9ef 100644 --- a/src/ast/binary.ml +++ b/src/ast/binary.ml @@ -49,8 +49,8 @@ type elem = } type custom = - | Uninterpreted of (string, Sexp.t) Either.t - | Contract of binary Contract.t + | Uninterpreted of string + | From_annot of binary Annot.annot type modul = { id : string option diff --git a/src/ast/text.ml b/src/ast/text.ml index 041bcba49..715058535 100644 --- a/src/ast/text.ml +++ b/src/ast/text.ml @@ -95,7 +95,7 @@ let pp_module_field fmt = function type modul = { id : string option ; fields : module_field list - ; annots : Annot.t list + ; annots : text Annot.annot list } let pp_modul fmt (m : modul) = diff --git a/src/dune b/src/dune index 483309e1e..fcd0cb281 100644 --- a/src/dune +++ b/src/dune @@ -50,6 +50,7 @@ interpret interpret_intf kind + spec link link_env log diff --git a/src/parser/binary_parser.ml b/src/parser/binary_parser.ml index 0e78c37c3..3a45fb5bf 100644 --- a/src/parser/binary_parser.ml +++ b/src/parser/binary_parser.ml @@ -1189,9 +1189,7 @@ let sections_iterate (input : Input.t) = (* Custom *) let custom = - List.filter_map - (Option.map (fun x -> Uninterpreted (Either.Left x))) - custom_sections + List.filter_map (Option.map (fun x -> Uninterpreted x)) custom_sections in { id = None diff --git a/src/parser/text_lexer.ml b/src/parser/text_lexer.ml index 6dc78d983..095d537cf 100644 --- a/src/parser/text_lexer.ml +++ b/src/parser/text_lexer.ml @@ -452,14 +452,14 @@ let rec token buf = if String.equal "" annotid then Log.err "empty annotation id" else let items = Sexp.List (annot buf) in - Annot.(record_annot { annotid; items }); + Annot.(record_annot annotid (Annot { annotid; items })); token buf | "(@", Plus id_char -> let annotid = Utf8.lexeme buf in let annotid = String.sub annotid 2 (String.length annotid - 2) in let annotid = mk_string buf annotid in let items = Sexp.List (annot buf) in - Annot.(record_annot { annotid; items }); + Annot.(record_annot annotid (Annot { annotid; items })); token buf | "(@" -> Log.err "empty annotation id" (* 1 *) From 21b93f647cb71e597c5f4abedc953ce886bc6fd4 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Mon, 12 Aug 2024 11:06:00 +0200 Subject: [PATCH 16/51] remove duplicate pattern --- src/parser/text_lexer.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parser/text_lexer.ml b/src/parser/text_lexer.ml index 095d537cf..9fdcfdb4f 100644 --- a/src/parser/text_lexer.ml +++ b/src/parser/text_lexer.ml @@ -105,7 +105,7 @@ let id_char = | 'a' .. 'z' | 'A' .. 'Z' | '!' | '#' | '$' | '%' | '&' | '\'' | '*' | '+' | '-' | '.' | '/' | ':' - | '<' | '=' | '>' | '?' | '@' | '\\' | '^' | '_' | '`' | '|' | '~' | '*' )] + | '<' | '=' | '>' | '?' | '@' | '\\' | '^' | '_' | '`' | '|' | '~' )] let name = [%sedlex.regexp? "\"", Star (Sub (any, "\"") | "\\\""), "\""] From 08c36996dee2e00e64069349aa94077d2c2d76d4 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Mon, 12 Aug 2024 14:01:55 +0200 Subject: [PATCH 17/51] parse function contract --- src/annot/contract.ml | 33 ++++- src/annot/contract.mli | 2 + src/annot/spec.ml | 276 ++++++++++++++++++++++++++++++++++++----- src/annot/spec.mli | 70 +++++++++++ src/bin/owi.ml | 9 +- src/utils/result.ml | 20 ++- src/utils/result.mli | 9 +- 7 files changed, 381 insertions(+), 38 deletions(-) create mode 100644 src/annot/spec.mli diff --git a/src/annot/contract.ml b/src/annot/contract.ml index 5bb2d754c..89fce95fe 100644 --- a/src/annot/contract.ml +++ b/src/annot/contract.ml @@ -1,6 +1,7 @@ -open Fmt open Types +open Fmt open Spec +open Syntax type 'a t = { func : 'a indice @@ -9,8 +10,36 @@ type 'a t = } let pp_contract fmt { func; preconditions; postconditions } = - pf fmt "%a@,%a@,%a@," pp_indice func + pf fmt + "@[Contract:@;\ + <1 2>%a\n\ + Preconditions:@;\ + <1 2>@[%a@]\n\ + Postconditions:@;\ + <1 2>@[%a@]@]" pp_indice func (list ~sep:pp_newline pp_prop) preconditions (list ~sep:pp_newline pp_prop) postconditions + +let cons_first (l1, l2) x1 = (x1 :: l1, l2) + +let cons_second (l1, l2) x2 = (l1, x2 :: l2) + +let parse_contract = + let open Sexp in + function + | List (Atom func :: conds) -> + let aux acc = function + | List [ Atom "requires"; precond ] -> + let+ precond = parse_prop precond in + cons_first acc precond + | List [ Atom "ensures"; postcond ] -> + let+ postcond = parse_prop postcond in + cons_second acc postcond + | _ as s -> Error (`Unknown_annotation_clause s) + in + let* func = parse_indice func in + let+ preconditions, postconditions = list_fold_left aux ([], []) conds in + { func; preconditions; postconditions } + | _ as s -> Error (`Unknown_annotation_object s) diff --git a/src/annot/contract.mli b/src/annot/contract.mli index 1c8607d88..8ec944414 100644 --- a/src/annot/contract.mli +++ b/src/annot/contract.mli @@ -9,3 +9,5 @@ type 'a t = } val pp_contract : formatter -> 'a t -> unit + +val parse_contract : Sexp.t -> text t Result.t diff --git a/src/annot/spec.ml b/src/annot/spec.ml index eefd4ff57..657d889e8 100644 --- a/src/annot/spec.ml +++ b/src/annot/spec.ml @@ -1,17 +1,60 @@ open Types open Fmt +open Syntax (* - text: - (local index) - (global index) - (binder index) - string_id - - binary: - (local index) - (global index) - (binder index) + +unop ::= '-' ==> Neg + +binop ::= '+' ==> Plus + | '-' ==> Minus + | '*' ==> Mult + | '/' ==> Div + +term ::= '(' pterm ')' ==> pterm + | result ==> Result + +pterm ::= 'i32' i32 ==> Int32 (Int32.of_string i32) + | 'var' ind ==> Var (Text ind) if (valid_text_indice ind) + | 'global' ind ==> Global (Text ind) if (valid_text_indice ind) + ==> Global (Raw ind) if (valid_binary_indice ind) + | 'binder' ind ==> Binder (Text ind) if (valid_text_indice ind) + ==> Binder (Raw ind) if (valid_binary_indice ind) + | unop term_1 ==> Unop (unop, term_1) + | binop term_1 term_2 ==> BinOp (binop, term_1, term_2) + +binpred ::= '>=' ==> Ge + | '>' ==> Gt + | '<=' ==> Le + | '<' ==> Lt + | '=' ==> Eq + | '!=' ==> Neq + +unconnect ::= '!' ==> Not + +binconnect ::= '&&' ==> And + | '||' ==> Or + | '==>' ==> Imply + | '<==>' ==> Equiv + +prop ::= '(' pprop ')' ==> pprop + | 'true' ==> Const true + | 'false' ==> Const false + +binder ::= 'forall' ==> Forall + | 'exists' ==> Exists + +binder_type ::= 'i32' ==> I32 + | 'i64' ==> I64 + | 'f32' ==> F32 + | 'f64' ==> F64 + +pprop ::= binpred term_1 term_2 ==> BinPred (binpred, term_1, term_2) + | unconnect prop_1 ==> UnConnect (unconnect, prop_1) + | binconnect prop_1 prop_2 ==> BinConnect (binconnect, prop_1, prop_2) + | binder binder_type prop_1 ==> Binder (binder, binder_type, None, prop_1) + | binder binder_type ind prop_1 ==> Binder (binder, binder_type, Some ind, prop_1) + if (valid_text_indice ind) *) type nonrec binpred = @@ -22,7 +65,7 @@ type nonrec binpred = | Eq | Neq -type nonrec unconnect = Neg +type nonrec unconnect = Not type nonrec binconnect = | And @@ -36,20 +79,30 @@ type nonrec binder = type nonrec binder_type = num_type -type 'a prop = - | Const : bool -> 'a prop - | BinPred : binpred * 'a term * 'a term -> 'a prop - | UnConnect : unconnect * 'a prop -> 'a prop - | BinConnect : binconnect * 'a prop * 'a prop -> 'a prop - | Binder : binder * binder_type * string option * 'a prop -> 'a prop +type nonrec unop = Neg -and 'a term = +type nonrec binop = + | Plus + | Minus + | Mult + | Div + +type 'a term = | Int32 : int32 -> 'a term | Var : text indice -> text term | GlobalVar : 'a indice -> 'a term | BinderVar : 'a indice -> 'a term + | UnOp : unop * 'a term -> 'a term + | BinOp : binop * 'a term * 'a term -> 'a term | Result : 'a term +type 'a prop = + | Const : bool -> 'a prop + | BinPred : binpred * 'a term * 'a term -> 'a prop + | UnConnect : unconnect * 'a prop -> 'a prop + | BinConnect : binconnect * 'a prop * 'a prop -> 'a prop + | Binder : binder * binder_type * string option * 'a prop -> 'a prop + let pp_bool fmt = function true -> pf fmt "true" | false -> pf fmt "false" let pp_binpred fmt = function @@ -60,7 +113,7 @@ let pp_binpred fmt = function | Eq -> pf fmt "=" | Neq -> pf fmt "!=" -let pp_unconnect fmt = function Neg -> pf fmt "!" +let pp_unconnect fmt = function Not -> pf fmt "!" let pp_binconnect fmt = function | And -> pf fmt "&&" @@ -69,13 +122,33 @@ let pp_binconnect fmt = function | Equiv -> pf fmt "<==>" let pp_binder fmt = function - | Forall -> pf fmt {|\forall|} - | Exists -> pf fmt {|\exists|} + | Forall -> pf fmt "forall" + | Exists -> pf fmt "exists" let pp_binder_type = pp_num_type -let rec pp_prop fmt = function - | Const bool -> pf fmt {|"\%a"|} pp_bool bool +let pp_unop fmt = function Neg -> pf fmt "-" + +let pp_binop fmt = function + | Plus -> pf fmt "+" + | Minus -> pf fmt "-" + | Mult -> pf fmt "*" + | Div -> pf fmt "/" + +let rec pp_term : type a. formatter -> a term -> unit = + fun fmt -> function + | Int32 i -> pf fmt "%i" (Int32.to_int i) + | Var ind -> pf fmt "%a" pp_indice ind + | GlobalVar ind -> pf fmt "global.%a" pp_indice ind + | BinderVar ind -> pf fmt "binder.%a" pp_indice ind + | UnOp (u, tm1) -> pf fmt "@[%a@ %a@]" pp_unop u pp_term tm1 + | BinOp (b, tm1, tm2) -> + pf fmt "@[%a@ %a@ %a@]" pp_binop b pp_term tm1 pp_term tm2 + | Result -> pf fmt {|\result|} + +let rec pp_prop : type a. formatter -> a prop -> unit = + fun fmt -> function + | Const bool -> pf fmt "%a" pp_bool bool | BinPred (b, tm1, tm2) -> pf fmt "@[%a@ %a@ %a@]" pp_term tm1 pp_binpred b pp_term tm2 | UnConnect (u, pr1) -> pf fmt "@[%a@ %a@]" pp_unconnect u pp_prop pr1 @@ -89,10 +162,153 @@ let rec pp_prop fmt = function | None -> pf fmt "@[%a@ %a@, %a@]" pp_binder b pp_binder_type bt pp_prop pr1 ) -and pp_term (type e) fmt (tm : e term) = - match tm with - | Int32 i -> pf fmt "%i" (Int32.to_int i) - | Var ind -> pf fmt "%a" pp_indice ind - | GlobalVar ind -> pf fmt "global.%a" pp_indice ind - | BinderVar ind -> pf fmt "binder.%a" pp_indice ind - | Result -> pf fmt {|\result|} +let valid_text_indice_char = function + | '0' .. '9' + | 'a' .. 'z' + | 'A' .. 'Z' + | '!' | '#' | '$' | '%' | '&' | '\'' | '*' | '+' | '-' | '.' | '/' | ':' | '<' + | '=' | '>' | '?' | '@' | '\\' | '^' | '_' | '`' | '|' | '~' -> + true + | _ -> false + +let valid_text_indice ind = + match List.of_seq (String.to_seq ind) with + | '$' :: rest -> List.for_all valid_text_indice_char rest + | _ -> false + +let valid_binary_indice x = + Option.to_result ~none:(`Invalid_indice x) (int_of_string x) + +let parse_indice ind = + if valid_text_indice ind then ok @@ Text ind + else + let* ind = valid_binary_indice ind in + ok @@ Raw ind + +let parse_binder_type = + let open Sexp in + function + | Atom "i32" -> ok I32 + | Atom "i64" -> ok I64 + | Atom "f32" -> ok F32 + | Atom "f64" -> ok F64 + | _ as bt -> Error (`Unknown_binder_type bt) + +let rec parse_term = + let open Sexp in + function + (* Int32 *) + | List [ Atom "i32"; Atom i32 ] -> ok @@ Int32 (Int32.of_string i32) + (* Var *) + | List [ Atom "local"; Atom ind ] -> + if valid_text_indice ind then ok @@ Var (Text ind) + else Error (`Invalid_text_indice ind) + (* GlobalVar *) + | List [ Atom "global"; Atom ind ] -> + let+ ind = parse_indice ind in + GlobalVar ind + (* BinderVar *) + | List [ Atom "binder"; Atom ind ] -> + let+ ind = parse_indice ind in + BinderVar ind + (* UnOp *) + | List [ Atom "-"; tm1 ] -> + let+ tm1 = parse_term tm1 in + UnOp (Neg, tm1) + (* BinOp *) + | List [ Atom "+"; tm1; tm2 ] -> + let* tm1 = parse_term tm1 in + let+ tm2 = parse_term tm2 in + BinOp (Plus, tm1, tm2) + | List [ Atom "-"; tm1; tm2 ] -> + let* tm1 = parse_term tm1 in + let+ tm2 = parse_term tm2 in + BinOp (Minus, tm1, tm2) + | List [ Atom "*"; tm1; tm2 ] -> + let* tm1 = parse_term tm1 in + let+ tm2 = parse_term tm2 in + BinOp (Mult, tm1, tm2) + | List [ Atom "/"; tm1; tm2 ] -> + let* tm1 = parse_term tm1 in + let+ tm2 = parse_term tm2 in + BinOp (Div, tm1, tm2) + (* Result *) + | Atom "result" -> ok Result + (* Invalid *) + | _ as tm -> Error (`Unknown_term tm) + +let rec parse_prop = + let open Sexp in + function + (* Const *) + | Atom "true" -> ok @@ Const true + | Atom "false" -> ok @@ Const false + (* BinPred *) + | List [ Atom ">="; tm1; tm2 ] -> + let* tm1 = parse_term tm1 in + let+ tm2 = parse_term tm2 in + BinPred (Ge, tm1, tm2) + | List [ Atom ">"; tm1; tm2 ] -> + let* tm1 = parse_term tm1 in + let+ tm2 = parse_term tm2 in + BinPred (Gt, tm1, tm2) + | List [ Atom "<="; tm1; tm2 ] -> + let* tm1 = parse_term tm1 in + let+ tm2 = parse_term tm2 in + BinPred (Le, tm1, tm2) + | List [ Atom "<"; tm1; tm2 ] -> + let* tm1 = parse_term tm1 in + let+ tm2 = parse_term tm2 in + BinPred (Lt, tm1, tm2) + | List [ Atom "="; tm1; tm2 ] -> + let* tm1 = parse_term tm1 in + let+ tm2 = parse_term tm2 in + BinPred (Eq, tm1, tm2) + | List [ Atom "!="; tm1; tm2 ] -> + let* tm1 = parse_term tm1 in + let+ tm2 = parse_term tm2 in + BinPred (Neq, tm1, tm2) + (* UnConnect *) + | List [ Atom "!"; pr1 ] -> + let+ pr1 = parse_prop pr1 in + UnConnect (Not, pr1) + (* BinConnect *) + | List [ Atom "&&"; pr1; pr2 ] -> + let* pr1 = parse_prop pr1 in + let+ pr2 = parse_prop pr2 in + BinConnect (And, pr1, pr2) + | List [ Atom "||"; pr1; pr2 ] -> + let* pr1 = parse_prop pr1 in + let+ pr2 = parse_prop pr2 in + BinConnect (Or, pr1, pr2) + | List [ Atom "==>"; pr1; pr2 ] -> + let* pr1 = parse_prop pr1 in + let+ pr2 = parse_prop pr2 in + BinConnect (Imply, pr1, pr2) + | List [ Atom "<==>"; pr1; pr2 ] -> + let* pr1 = parse_prop pr1 in + let+ pr2 = parse_prop pr2 in + BinConnect (Equiv, pr1, pr2) + (* Binder *) + | List [ Atom "forall"; bt; pr1 ] -> + let* bt = parse_binder_type bt in + let+ pr1 = parse_prop pr1 in + Binder (Forall, bt, None, pr1) + | List [ Atom "forall"; bt; Atom ind; pr1 ] -> + if valid_text_indice ind then + let* bt = parse_binder_type bt in + let+ pr1 = parse_prop pr1 in + Binder (Forall, bt, Some ind, pr1) + else Error (`Invalid_text_indice ind) + | List [ Atom "exists"; bt; pr1 ] -> + let* bt = parse_binder_type bt in + let+ pr1 = parse_prop pr1 in + Binder (Exists, bt, None, pr1) + | List [ Atom "exists"; bt; Atom ind; pr1 ] -> + if valid_text_indice ind then + let* bt = parse_binder_type bt in + let+ pr1 = parse_prop pr1 in + Binder (Exists, bt, Some ind, pr1) + else Error (`Invalid_text_indice ind) + (* invalid *) + | _ as pr -> Error (`Unknown_prop pr) diff --git a/src/annot/spec.mli b/src/annot/spec.mli new file mode 100644 index 000000000..448dc6eec --- /dev/null +++ b/src/annot/spec.mli @@ -0,0 +1,70 @@ +open Types +open Fmt + +type nonrec binpred = + | Ge + | Gt + | Le + | Lt + | Eq + | Neq + +type nonrec unconnect = Not + +type nonrec binconnect = + | And + | Or + | Imply + | Equiv + +type nonrec binder = + | Forall + | Exists + +type nonrec binder_type = num_type + +type nonrec unop = Neg + +type nonrec binop = + | Plus + | Minus + | Mult + | Div + +type 'a term = + | Int32 : int32 -> 'a term + | Var : text indice -> text term + | GlobalVar : 'a indice -> 'a term + | BinderVar : 'a indice -> 'a term + | UnOp : unop * 'a term -> 'a term + | BinOp : binop * 'a term * 'a term -> 'a term + | Result : 'a term + +type 'a prop = + | Const : bool -> 'a prop + | BinPred : binpred * 'a term * 'a term -> 'a prop + | UnConnect : unconnect * 'a prop -> 'a prop + | BinConnect : binconnect * 'a prop * 'a prop -> 'a prop + | Binder : binder * binder_type * string option * 'a prop -> 'a prop + +val pp_bool : formatter -> bool -> unit + +val pp_binpred : formatter -> binpred -> unit + +val pp_unconnect : formatter -> unconnect -> unit + +val pp_binconnect : formatter -> binconnect -> unit + +val pp_binder : formatter -> binder -> unit + +val pp_binder_type : formatter -> binder_type -> unit + +val pp_prop : formatter -> 'a prop -> unit + +val pp_term : formatter -> 'a term -> unit + +val parse_indice : string -> text indice Result.t + +val parse_prop : Sexp.t -> text prop Result.t + +val parse_term : Sexp.t -> text term Result.t diff --git a/src/bin/owi.ml b/src/bin/owi.ml index 5cdfce742..5e210eee4 100644 --- a/src/bin/owi.ml +++ b/src/bin/owi.ml @@ -369,8 +369,13 @@ let exit_code = | `Unsupported_file_extension _ext -> 53 | `Failed_with_but_expected (_got, _expected) -> 54 | `Annotation_id_incorrect _annotid -> 55 - | `Unknown_annotation_clause -> 56 - | `Unknown_annotation_object -> 57 + | `Invalid_indice _ind -> 56 + | `Invalid_text_indice _ind -> 57 + | `Unknown_annotation_clause _s -> 58 + | `Unknown_annotation_object _s -> 59 + | `Unknown_binder_type _s -> 60 + | `Unknown_prop _pr -> 61 + | `Unknown_term _tm -> 62 end end | Error e -> ( diff --git a/src/utils/result.ml b/src/utils/result.ml index 30c12b51d..820b6bc6d 100644 --- a/src/utils/result.ml +++ b/src/utils/result.ml @@ -60,8 +60,13 @@ type err = | `Unknown_type of Types.text Types.indice | `Unsupported_file_extension of string | `Annotation_id_incorrect of string - | `Unknown_annotation_clause - | `Unknown_annotation_object + | `Invalid_indice of string + | `Invalid_text_indice of string + | `Unknown_annotation_clause of Sexp.t + | `Unknown_annotation_object of Sexp.t + | `Unknown_binder_type of Sexp.t + | `Unknown_prop of Sexp.t + | `Unknown_term of Sexp.t ] type 'a t = ('a, err) Prelude.Result.t @@ -127,3 +132,14 @@ let rec err_to_string = function | `Unknown_type id -> Fmt.str "unknown type %a" Types.pp_indice id | `Unsupported_file_extension ext -> Fmt.str "unsupported file_extension %S" ext + | `Annotation_id_incorrect annotid -> + Fmt.str "annotation id %S incorrect" annotid + | `Invalid_indice ind -> Fmt.str "invalid indice %S" ind + | `Invalid_text_indice ind -> Fmt.str "invalid text indice %S" ind + | `Unknown_annotation_clause s -> + Fmt.str "unknown annotation clause %a" Sexp.pp_sexp s + | `Unknown_annotation_object s -> + Fmt.str "unknown annotation object %a" Sexp.pp_sexp s + | `Unknown_binder_type s -> Fmt.str "unknown binder type %a" Sexp.pp_sexp s + | `Unknown_prop pr -> Fmt.str "unknown prop %a" Sexp.pp_sexp pr + | `Unknown_term tm -> Fmt.str "unknown term %a" Sexp.pp_sexp tm diff --git a/src/utils/result.mli b/src/utils/result.mli index 94dd8f28e..8c8363b98 100644 --- a/src/utils/result.mli +++ b/src/utils/result.mli @@ -60,8 +60,13 @@ type err = | `Unknown_type of Types.text Types.indice | `Unsupported_file_extension of string | `Annotation_id_incorrect of string - | `Unknown_annotation_clause - | `Unknown_annotation_object + | `Invalid_indice of string + | `Invalid_text_indice of string + | `Unknown_annotation_clause of Sexp.t + | `Unknown_annotation_object of Sexp.t + | `Unknown_binder_type of Sexp.t + | `Unknown_prop of Sexp.t + | `Unknown_term of Sexp.t ] type 'a t = ('a, err) Prelude.Result.t From 9511220b730ff34677441d2139427ad04dd41af2 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Mon, 12 Aug 2024 16:00:42 +0200 Subject: [PATCH 18/51] add annotations to text_to_binary --- src/bin/owi.ml | 12 +++-- src/text_to_binary/assigned.ml | 2 + src/text_to_binary/assigned.mli | 1 + src/text_to_binary/grouped.ml | 8 ++- src/text_to_binary/grouped.mli | 1 + src/text_to_binary/rewrite.ml | 86 +++++++++++++++++++++++++++++++-- src/utils/result.ml | 9 +++- src/utils/result.mli | 2 + 8 files changed, 108 insertions(+), 13 deletions(-) diff --git a/src/bin/owi.ml b/src/bin/owi.ml index 5e210eee4..4f086e289 100644 --- a/src/bin/owi.ml +++ b/src/bin/owi.ml @@ -369,13 +369,15 @@ let exit_code = | `Unsupported_file_extension _ext -> 53 | `Failed_with_but_expected (_got, _expected) -> 54 | `Annotation_id_incorrect _annotid -> 55 - | `Invalid_indice _ind -> 56 - | `Invalid_text_indice _ind -> 57 + | `Invalid_indice _id -> 56 + | `Invalid_text_indice _id -> 57 | `Unknown_annotation_clause _s -> 58 | `Unknown_annotation_object _s -> 59 - | `Unknown_binder_type _s -> 60 - | `Unknown_prop _pr -> 61 - | `Unknown_term _tm -> 62 + | `Unknown_binder _id -> 60 + | `Unknown_binder_or_global _id -> 61 + | `Unknown_binder_type _s -> 62 + | `Unknown_prop _pr -> 63 + | `Unknown_term _tm -> 64 end end | Error e -> ( diff --git a/src/text_to_binary/assigned.ml b/src/text_to_binary/assigned.ml index 6672494db..e126159a8 100644 --- a/src/text_to_binary/assigned.ml +++ b/src/text_to_binary/assigned.ml @@ -24,6 +24,7 @@ type t = ; data : Text.data Named.t ; exports : Grouped.opt_exports ; start : text indice option + ; annots : text Annot.annot list } type type_acc = @@ -166,4 +167,5 @@ let of_grouped (modul : Grouped.t) : t Result.t = ; data ; exports = modul.exports ; start = modul.start + ; annots = modul.annots } diff --git a/src/text_to_binary/assigned.mli b/src/text_to_binary/assigned.mli index b61d982ee..f1e5769ba 100644 --- a/src/text_to_binary/assigned.mli +++ b/src/text_to_binary/assigned.mli @@ -15,6 +15,7 @@ type t = ; data : Text.data Named.t ; exports : Grouped.opt_exports ; start : text indice option + ; annots : text Annot.annot list } val of_grouped : Grouped.t -> t Result.t diff --git a/src/text_to_binary/grouped.ml b/src/text_to_binary/grouped.ml index 81a8489c5..1018f2852 100644 --- a/src/text_to_binary/grouped.ml +++ b/src/text_to_binary/grouped.ml @@ -39,6 +39,7 @@ type t = ; data : Text.data Indexed.t list ; exports : opt_exports ; start : text indice option + ; annots : text Annot.annot list } let imp (import : text import) (assigned_name, desc) : 'a Imported.t = @@ -57,6 +58,7 @@ let empty_module id = ; data = [] ; exports = { global = []; table = []; mem = []; func = [] } ; start = None + ; annots = [] } type curr = @@ -211,6 +213,8 @@ let add_field curr (fields : t) = function ok @@ add_data data fields curr | MStart start -> Ok { fields with start = Some start } -let of_symbolic { Text.fields; id; _ } = +let of_symbolic { Text.fields; id; annots } = Log.debug0 "grouping ...@\n"; - list_fold_left (add_field (init_curr ())) (empty_module id) fields + let+ modul = list_fold_left (add_field (init_curr ())) (empty_module id) fields + in + { modul with annots } diff --git a/src/text_to_binary/grouped.mli b/src/text_to_binary/grouped.mli index cfd4207e3..63e532195 100644 --- a/src/text_to_binary/grouped.mli +++ b/src/text_to_binary/grouped.mli @@ -35,6 +35,7 @@ type t = ; data : Text.data Indexed.t list ; exports : opt_exports ; start : text indice option + ; annots : text Annot.annot list } val of_symbolic : Text.modul -> t Result.t diff --git a/src/text_to_binary/rewrite.ml b/src/text_to_binary/rewrite.ml index 6e0a1e2c1..b23c14706 100644 --- a/src/text_to_binary/rewrite.ml +++ b/src/text_to_binary/rewrite.ml @@ -54,6 +54,19 @@ let rewrite_block_type (typemap : binary indice TypeMap.t) (modul : Assigned.t) in Bt_raw (Some idx, t) +let find_binder (binder_list : string option list) (ind : text indice) : + binary indice Result.t = + match ind with + | Raw id -> Ok (Raw id) + | Text id -> + let rec aux acc = function + | [] -> Error (`Unknown_binder ind) + | Some id' :: bl -> + if String.equal id id' then Ok (Raw acc) else aux (acc + 1) bl + | _ :: bl -> aux (acc + 1) bl + in + aux 0 binder_list + let rewrite_expr (typemap : binary indice TypeMap.t) (modul : Assigned.t) (locals : binary param list) (iexpr : text expr) : binary expr Result.t = (* block_ids handling *) @@ -210,7 +223,7 @@ let rewrite_expr (typemap : binary indice TypeMap.t) (modul : Assigned.t) Ok (Elem_drop id) | Select typ -> begin match typ with - | None -> ok @@ Select None + | None -> Ok (Select None) | Some [ t ] -> let+ t = Binary_types.convert_val_type None t in Select (Some [ t ]) @@ -361,6 +374,70 @@ let rewrite_types (_modul : Assigned.t) (t : binary str_type) : let t = [ (None, (Final, [], t)) ] in Ok t +let rec rewrite_term (modul : Assigned.t) (binder_list : string option list) : + text Spec.term -> binary Spec.term Result.t = + let open Spec in + function + | Int32 i -> Ok (Int32 i) + | Var ind -> ( + match (find_binder binder_list ind, find_global modul ind) with + | Ok ind, _ -> Ok (BinderVar ind) + | _, Ok ind -> Ok (GlobalVar ind) + | _, _ -> Error (`Unknown_binder_or_global ind) ) + | GlobalVar ind -> + let+ ind = find_global modul ind in + GlobalVar ind + | BinderVar ind -> + let+ ind = find_binder binder_list ind in + BinderVar ind + | UnOp (u, tm1) -> + let+ tm1 = rewrite_term modul binder_list tm1 in + UnOp (u, tm1) + | BinOp (b, tm1, tm2) -> + let* tm1 = rewrite_term modul binder_list tm1 in + let+ tm2 = rewrite_term modul binder_list tm2 in + BinOp (b, tm1, tm2) + | Result -> Ok Result + +let rec rewrite_prop (modul : Assigned.t) (binder_list : string option list) : + text Spec.prop -> binary Spec.prop Result.t = + let open Spec in + function + | Const b -> Ok (Const b) + | BinPred (b, tm1, tm2) -> + let* tm1 = rewrite_term modul binder_list tm1 in + let+ tm2 = rewrite_term modul binder_list tm2 in + BinPred (b, tm1, tm2) + | UnConnect (u, pr1) -> + let+ pr1 = rewrite_prop modul binder_list pr1 in + UnConnect (u, pr1) + | BinConnect (b, pr1, pr2) -> + let* pr1 = rewrite_prop modul binder_list pr1 in + let+ pr2 = rewrite_prop modul binder_list pr2 in + BinConnect (b, pr1, pr2) + | Binder (b, bt, id_opt, pr1) -> + let+ pr1 = rewrite_prop modul (id_opt :: binder_list) pr1 in + Binder (b, bt, id_opt, pr1) + +let rewrite_contract (modul : Assigned.t) : + text Contract.t -> binary Contract.t Result.t = + fun { Contract.func; preconditions; postconditions } -> + let* func = find (`Unknown_func func) modul.func func in + let* preconditions = list_map (rewrite_prop modul []) preconditions in + let+ postconditions = list_map (rewrite_prop modul []) postconditions in + { Contract.func; preconditions; postconditions } + +let rewrite_annot (modul : Assigned.t) : + text Annot.annot -> Binary.custom Result.t = function + | Contract contract -> + let+ contract = rewrite_contract modul contract in + Binary.From_annot (Contract contract) + | Annot annot -> ok @@ Binary.From_annot (Annot annot) + +let rewrite_annots (modul : Assigned.t) : + text Annot.annot list -> Binary.custom list Result.t = + list_map (rewrite_annot modul) + let modul (modul : Assigned.t) : Binary.modul Result.t = Log.debug0 "rewriting ...@\n"; let typemap = typemap modul.typ in @@ -381,14 +458,15 @@ let modul (modul : Assigned.t) : Binary.modul Result.t = let runtime = rewrite_runtime (rewrite_func typemap modul) import in rewrite_named runtime modul.func in - let+ types = rewrite_named (rewrite_types modul) modul.typ in - let start = + let* types = rewrite_named (rewrite_types modul) modul.typ in + let* start = match modul.start with | None -> None | Some id -> let (Raw id) = find func id in Some id in + let+ custom = rewrite_annots modul modul.annots in let id = modul.id in let mem = Named.to_array modul.mem in @@ -400,6 +478,6 @@ let modul (modul : Assigned.t) : Binary.modul Result.t = let func = Named.to_array func in let modul : Binary.modul = - { id; mem; table; types; global; elem; data; exports; func; start; custom = [] } + { id; mem; table; types; global; elem; data; exports; func; start; custom } in modul diff --git a/src/utils/result.ml b/src/utils/result.ml index 820b6bc6d..e1023316f 100644 --- a/src/utils/result.ml +++ b/src/utils/result.ml @@ -64,6 +64,8 @@ type err = | `Invalid_text_indice of string | `Unknown_annotation_clause of Sexp.t | `Unknown_annotation_object of Sexp.t + | `Unknown_binder of Types.text Types.indice + | `Unknown_binder_or_global of Types.text Types.indice | `Unknown_binder_type of Sexp.t | `Unknown_prop of Sexp.t | `Unknown_term of Sexp.t @@ -134,12 +136,15 @@ let rec err_to_string = function Fmt.str "unsupported file_extension %S" ext | `Annotation_id_incorrect annotid -> Fmt.str "annotation id %S incorrect" annotid - | `Invalid_indice ind -> Fmt.str "invalid indice %S" ind - | `Invalid_text_indice ind -> Fmt.str "invalid text indice %S" ind + | `Invalid_indice id -> Fmt.str "invalid indice %S" id + | `Invalid_text_indice id -> Fmt.str "invalid text indice %S" id | `Unknown_annotation_clause s -> Fmt.str "unknown annotation clause %a" Sexp.pp_sexp s | `Unknown_annotation_object s -> Fmt.str "unknown annotation object %a" Sexp.pp_sexp s + | `Unknown_binder id -> Fmt.str "unknown binder %a" Types.pp_indice id + | `Unknown_binder_or_global id -> + Fmt.str "unknown binder or global %a" Types.pp_indice id | `Unknown_binder_type s -> Fmt.str "unknown binder type %a" Sexp.pp_sexp s | `Unknown_prop pr -> Fmt.str "unknown prop %a" Sexp.pp_sexp pr | `Unknown_term tm -> Fmt.str "unknown term %a" Sexp.pp_sexp tm diff --git a/src/utils/result.mli b/src/utils/result.mli index 8c8363b98..e20975cf2 100644 --- a/src/utils/result.mli +++ b/src/utils/result.mli @@ -64,6 +64,8 @@ type err = | `Invalid_text_indice of string | `Unknown_annotation_clause of Sexp.t | `Unknown_annotation_object of Sexp.t + | `Unknown_binder of Types.text Types.indice + | `Unknown_binder_or_global of Types.text Types.indice | `Unknown_binder_type of Sexp.t | `Unknown_prop of Sexp.t | `Unknown_term of Sexp.t From 7111a133def390211708938bcb3e98b15610c7d3 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Mon, 12 Aug 2024 23:25:20 +0200 Subject: [PATCH 19/51] fix parser --- src/annot/spec.ml | 112 ++++++++++++++++++++++--------------- src/bin/owi.ml | 19 ++++--- src/primitives/float32.ml | 2 + src/primitives/float32.mli | 2 + src/primitives/float64.ml | 2 + src/primitives/float64.mli | 2 + src/primitives/int32.ml | 2 + src/primitives/int32.mli | 2 + src/primitives/int64.ml | 2 + src/primitives/int64.mli | 2 + src/utils/result.ml | 2 + src/utils/result.mli | 1 + 12 files changed, 95 insertions(+), 55 deletions(-) diff --git a/src/annot/spec.ml b/src/annot/spec.ml index 657d889e8..0b85c7b15 100644 --- a/src/annot/spec.ml +++ b/src/annot/spec.ml @@ -12,14 +12,13 @@ binop ::= '+' ==> Plus | '/' ==> Div term ::= '(' pterm ')' ==> pterm + | i32 ==> Int32 (Int32.of_string i32) if Option.is_some (Int32.of_string_opt i32) + | ind ==> let* ind = parse_text_indice ind in Var ind if Option.is_some (parse_text_id ind) | result ==> Result pterm ::= 'i32' i32 ==> Int32 (Int32.of_string i32) - | 'var' ind ==> Var (Text ind) if (valid_text_indice ind) - | 'global' ind ==> Global (Text ind) if (valid_text_indice ind) - ==> Global (Raw ind) if (valid_binary_indice ind) - | 'binder' ind ==> Binder (Text ind) if (valid_text_indice ind) - ==> Binder (Raw ind) if (valid_binary_indice ind) + | 'global' ind ==> let* ind = parse_indice ind in Global ind + | 'binder' ind ==> let* ind = parse_indice ind in Binder ind | unop term_1 ==> Unop (unop, term_1) | binop term_1 term_2 ==> BinOp (binop, term_1, term_2) @@ -53,8 +52,9 @@ pprop ::= binpred term_1 term_2 ==> BinPred (binpred, term_1, term_2) | unconnect prop_1 ==> UnConnect (unconnect, prop_1) | binconnect prop_1 prop_2 ==> BinConnect (binconnect, prop_1, prop_2) | binder binder_type prop_1 ==> Binder (binder, binder_type, None, prop_1) - | binder binder_type ind prop_1 ==> Binder (binder, binder_type, Some ind, prop_1) - if (valid_text_indice ind) + | binder binder_type ind prop_1 ==> let* ind = (parse_text_id_result ind) in + Binder (binder, binder_type, Some ind, prop_1) + *) type nonrec binpred = @@ -106,24 +106,22 @@ type 'a prop = let pp_bool fmt = function true -> pf fmt "true" | false -> pf fmt "false" let pp_binpred fmt = function - | Ge -> pf fmt ">=" + | Ge -> pf fmt "≥" | Gt -> pf fmt ">" - | Le -> pf fmt "<=" + | Le -> pf fmt "≤" | Lt -> pf fmt "<" | Eq -> pf fmt "=" - | Neq -> pf fmt "!=" + | Neq -> pf fmt "≠" -let pp_unconnect fmt = function Not -> pf fmt "!" +let pp_unconnect fmt = function Not -> pf fmt "¬" let pp_binconnect fmt = function - | And -> pf fmt "&&" - | Or -> pf fmt "||" - | Imply -> pf fmt "==>" - | Equiv -> pf fmt "<==>" + | And -> pf fmt "∧" + | Or -> pf fmt "∨" + | Imply -> pf fmt "⇒" + | Equiv -> pf fmt "⇔" -let pp_binder fmt = function - | Forall -> pf fmt "forall" - | Exists -> pf fmt "exists" +let pp_binder fmt = function Forall -> pf fmt "∀" | Exists -> pf fmt "∃" let pp_binder_type = pp_num_type @@ -143,7 +141,7 @@ let rec pp_term : type a. formatter -> a term -> unit = | BinderVar ind -> pf fmt "binder.%a" pp_indice ind | UnOp (u, tm1) -> pf fmt "@[%a@ %a@]" pp_unop u pp_term tm1 | BinOp (b, tm1, tm2) -> - pf fmt "@[%a@ %a@ %a@]" pp_binop b pp_term tm1 pp_term tm2 + pf fmt "@[%a@ %a@ %a@]" pp_term tm1 pp_binop b pp_term tm2 | Result -> pf fmt {|\result|} let rec pp_prop : type a. formatter -> a prop -> unit = @@ -171,19 +169,38 @@ let valid_text_indice_char = function true | _ -> false -let valid_text_indice ind = - match List.of_seq (String.to_seq ind) with - | '$' :: rest -> List.for_all valid_text_indice_char rest - | _ -> false - -let valid_binary_indice x = - Option.to_result ~none:(`Invalid_indice x) (int_of_string x) - -let parse_indice ind = - if valid_text_indice ind then ok @@ Text ind - else - let* ind = valid_binary_indice ind in - ok @@ Raw ind +let parse_text_id id = + try + let len = String.length id in + let hd = String.get id 0 in + let tl = String.sub id 1 (len - 1) in + if Char.equal hd '$' && String.for_all valid_text_indice_char id then + Some tl + else None + with Invalid_argument _ -> None + +let parse_text_id_result id = + try + let len = String.length id in + let hd = String.get id 0 in + let tl = String.sub id 1 (len - 1) in + if Char.equal hd '$' && String.for_all valid_text_indice_char id then Ok tl + else Error (`Invalid_text_indice id) + with Invalid_argument _ -> Error (`Invalid_text_indice id) + +let parse_raw_id id = + match int_of_string id with Some id -> Some id | None -> None + +let parse_text_indice id = + match parse_text_id id with + | Some id -> Ok (Text id) + | None -> Error (`Invalid_text_indice id) + +let parse_indice id = + match (parse_text_id id, parse_raw_id id) with + | Some id, _ -> Ok (Text id) + | _, Some id -> Ok (Raw id) + | _, _ -> Error (`Invalid_indice id) let parse_binder_type = let open Sexp in @@ -198,11 +215,16 @@ let rec parse_term = let open Sexp in function (* Int32 *) - | List [ Atom "i32"; Atom i32 ] -> ok @@ Int32 (Int32.of_string i32) + | Atom i32 when Option.is_some (Int32.of_string_opt i32) -> + ok @@ Int32 (Int32.of_string i32) + | List [ Atom "i32"; Atom i32 ] -> ( + match Int32.of_string_opt i32 with + | Some i32 -> ok @@ Int32 i32 + | None -> Error (`Invalid_int32 i32) ) (* Var *) - | List [ Atom "local"; Atom ind ] -> - if valid_text_indice ind then ok @@ Var (Text ind) - else Error (`Invalid_text_indice ind) + | Atom ind when Option.is_some (parse_text_id ind) -> + let+ ind = parse_text_indice ind in + Var ind (* GlobalVar *) | List [ Atom "global"; Atom ind ] -> let+ ind = parse_indice ind in @@ -295,20 +317,18 @@ let rec parse_prop = let+ pr1 = parse_prop pr1 in Binder (Forall, bt, None, pr1) | List [ Atom "forall"; bt; Atom ind; pr1 ] -> - if valid_text_indice ind then - let* bt = parse_binder_type bt in - let+ pr1 = parse_prop pr1 in - Binder (Forall, bt, Some ind, pr1) - else Error (`Invalid_text_indice ind) + let* bt = parse_binder_type bt in + let* ind = parse_text_id_result ind in + let+ pr1 = parse_prop pr1 in + Binder (Forall, bt, Some ind, pr1) | List [ Atom "exists"; bt; pr1 ] -> let* bt = parse_binder_type bt in let+ pr1 = parse_prop pr1 in Binder (Exists, bt, None, pr1) | List [ Atom "exists"; bt; Atom ind; pr1 ] -> - if valid_text_indice ind then - let* bt = parse_binder_type bt in - let+ pr1 = parse_prop pr1 in - Binder (Exists, bt, Some ind, pr1) - else Error (`Invalid_text_indice ind) + let* bt = parse_binder_type bt in + let* ind = parse_text_id_result ind in + let+ pr1 = parse_prop pr1 in + Binder (Exists, bt, Some ind, pr1) (* invalid *) | _ as pr -> Error (`Unknown_prop pr) diff --git a/src/bin/owi.ml b/src/bin/owi.ml index 4f086e289..94bf0d28b 100644 --- a/src/bin/owi.ml +++ b/src/bin/owi.ml @@ -369,15 +369,16 @@ let exit_code = | `Unsupported_file_extension _ext -> 53 | `Failed_with_but_expected (_got, _expected) -> 54 | `Annotation_id_incorrect _annotid -> 55 - | `Invalid_indice _id -> 56 - | `Invalid_text_indice _id -> 57 - | `Unknown_annotation_clause _s -> 58 - | `Unknown_annotation_object _s -> 59 - | `Unknown_binder _id -> 60 - | `Unknown_binder_or_global _id -> 61 - | `Unknown_binder_type _s -> 62 - | `Unknown_prop _pr -> 63 - | `Unknown_term _tm -> 64 + | `Invalid_int32 _int32 -> 56 + | `Invalid_indice _id -> 57 + | `Invalid_text_indice _id -> 58 + | `Unknown_annotation_clause _s -> 59 + | `Unknown_annotation_object _s -> 60 + | `Unknown_binder _id -> 61 + | `Unknown_binder_or_global _id -> 62 + | `Unknown_binder_type _s -> 63 + | `Unknown_prop _pr -> 64 + | `Unknown_term _tm -> 65 end end | Error e -> ( diff --git a/src/primitives/float32.ml b/src/primitives/float32.ml index e6f8a1bb5..21ed92898 100644 --- a/src/primitives/float32.ml +++ b/src/primitives/float32.ml @@ -312,6 +312,8 @@ let of_string s = if Char.equal s.[0] '+' then x else neg x else of_signless_string s +let of_string_opt s = try Some (of_string s) with _ -> None + (* String conversion that groups digits for readability *) let is_digit = function '0' .. '9' -> true | _ -> false diff --git a/src/primitives/float32.mli b/src/primitives/float32.mli index 7b981048f..fd2e56260 100644 --- a/src/primitives/float32.mli +++ b/src/primitives/float32.mli @@ -62,6 +62,8 @@ val ge : t -> t -> bool val of_string : string -> t +val of_string_opt : string -> t option + val to_hex_string : t -> string val to_string : t -> string diff --git a/src/primitives/float64.ml b/src/primitives/float64.ml index ad08ebad9..d4b7c194b 100644 --- a/src/primitives/float64.ml +++ b/src/primitives/float64.ml @@ -311,6 +311,8 @@ let of_string s = if Char.equal s.[0] '+' then x else neg x else of_signless_string s +let of_string_opt s = try Some (of_string s) with _ -> None + (* String conversion that groups digits for readability *) let is_digit = function '0' .. '9' -> true | _ -> false diff --git a/src/primitives/float64.mli b/src/primitives/float64.mli index 54ea182ee..739f55589 100644 --- a/src/primitives/float64.mli +++ b/src/primitives/float64.mli @@ -62,6 +62,8 @@ val ge : t -> t -> bool val of_string : string -> t +val of_string_opt : string -> t option + val to_hex_string : t -> string val to_string : t -> string diff --git a/src/primitives/int32.ml b/src/primitives/int32.ml index d8264b5f3..4636e2c9c 100644 --- a/src/primitives/int32.ml +++ b/src/primitives/int32.ml @@ -148,3 +148,5 @@ let of_string s = let parsed = sign_extend parsed in require (le low_int parsed && le parsed high_int); parsed + +let of_string_opt s = try Some (of_string s) with _ -> None diff --git a/src/primitives/int32.mli b/src/primitives/int32.mli index 1c2685a1b..a01bad37e 100644 --- a/src/primitives/int32.mli +++ b/src/primitives/int32.mli @@ -24,6 +24,8 @@ val to_float : t -> float val of_string : string -> t +val of_string_opt : string -> t option + val of_int : int -> t val to_int : t -> int diff --git a/src/primitives/int64.ml b/src/primitives/int64.ml index c4dfbf4bd..9ea3a1bc6 100644 --- a/src/primitives/int64.ml +++ b/src/primitives/int64.ml @@ -162,3 +162,5 @@ let of_string s = in require (le low_int parsed && le parsed high_int); parsed + +let of_string_opt s = try Some (of_string s) with _ -> None diff --git a/src/primitives/int64.mli b/src/primitives/int64.mli index 11939ebb8..d0512e7eb 100644 --- a/src/primitives/int64.mli +++ b/src/primitives/int64.mli @@ -24,6 +24,8 @@ val to_float : t -> float val of_string : string -> t +val of_string_opt : string -> t option + val of_int : int -> t val to_int : t -> int diff --git a/src/utils/result.ml b/src/utils/result.ml index e1023316f..d33049129 100644 --- a/src/utils/result.ml +++ b/src/utils/result.ml @@ -60,6 +60,7 @@ type err = | `Unknown_type of Types.text Types.indice | `Unsupported_file_extension of string | `Annotation_id_incorrect of string + | `Invalid_int32 of string | `Invalid_indice of string | `Invalid_text_indice of string | `Unknown_annotation_clause of Sexp.t @@ -136,6 +137,7 @@ let rec err_to_string = function Fmt.str "unsupported file_extension %S" ext | `Annotation_id_incorrect annotid -> Fmt.str "annotation id %S incorrect" annotid + | `Invalid_int32 int32 -> Fmt.str "invalid int32 %S" int32 | `Invalid_indice id -> Fmt.str "invalid indice %S" id | `Invalid_text_indice id -> Fmt.str "invalid text indice %S" id | `Unknown_annotation_clause s -> diff --git a/src/utils/result.mli b/src/utils/result.mli index e20975cf2..2efec5d2f 100644 --- a/src/utils/result.mli +++ b/src/utils/result.mli @@ -60,6 +60,7 @@ type err = | `Unknown_type of Types.text Types.indice | `Unsupported_file_extension of string | `Annotation_id_incorrect of string + | `Invalid_int32 of string | `Invalid_indice of string | `Invalid_text_indice of string | `Unknown_annotation_clause of Sexp.t From 3187bd8604bc1ea0888b74c5fc6e3a8f22f0dac3 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Mon, 12 Aug 2024 23:26:20 +0200 Subject: [PATCH 20/51] delete quantified variable name in the process of rewrite --- src/text_to_binary/rewrite.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/text_to_binary/rewrite.ml b/src/text_to_binary/rewrite.ml index b23c14706..2db8679c0 100644 --- a/src/text_to_binary/rewrite.ml +++ b/src/text_to_binary/rewrite.ml @@ -417,7 +417,7 @@ let rec rewrite_prop (modul : Assigned.t) (binder_list : string option list) : BinConnect (b, pr1, pr2) | Binder (b, bt, id_opt, pr1) -> let+ pr1 = rewrite_prop modul (id_opt :: binder_list) pr1 in - Binder (b, bt, id_opt, pr1) + Binder (b, bt, None, pr1) let rewrite_contract (modul : Assigned.t) : text Contract.t -> binary Contract.t Result.t = From 7f7f87bfe077a07faf794725a4e579c519aa88ca Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Tue, 13 Aug 2024 00:07:21 +0200 Subject: [PATCH 21/51] better pretty printer --- src/annot/contract.ml | 5 ++-- src/annot/spec.ml | 48 ++++++++++++++++++++++++++--------- src/annot/spec.mli | 5 +++- src/bin/owi.ml | 23 +++++++++-------- src/text_to_binary/rewrite.ml | 5 +++- src/utils/result.ml | 8 +++++- src/utils/result.mli | 3 +++ 7 files changed, 69 insertions(+), 28 deletions(-) diff --git a/src/annot/contract.ml b/src/annot/contract.ml index 89fce95fe..8b0d49b29 100644 --- a/src/annot/contract.ml +++ b/src/annot/contract.ml @@ -11,10 +11,9 @@ type 'a t = let pp_contract fmt { func; preconditions; postconditions } = pf fmt - "@[Contract:@;\ - <1 2>%a\n\ + "@[Contract of function %a@,\ Preconditions:@;\ - <1 2>@[%a@]\n\ + <1 2>@[%a@]@,\ Postconditions:@;\ <1 2>@[%a@]@]" pp_indice func (list ~sep:pp_newline pp_prop) diff --git a/src/annot/spec.ml b/src/annot/spec.ml index 0b85c7b15..5d290bf74 100644 --- a/src/annot/spec.ml +++ b/src/annot/spec.ml @@ -17,6 +17,9 @@ term ::= '(' pterm ')' ==> pterm | result ==> Result pterm ::= 'i32' i32 ==> Int32 (Int32.of_string i32) + | 'i64' i64 ==> Int64 (Int64.of_string i64) + | 'f32' f32 ==> Float32 (Float32.of_string f32) + | 'f64' f64 ==> Float64 (Float64.of_string f64) | 'global' ind ==> let* ind = parse_indice ind in Global ind | 'binder' ind ==> let* ind = parse_indice ind in Binder ind | unop term_1 ==> Unop (unop, term_1) @@ -88,7 +91,10 @@ type nonrec binop = | Div type 'a term = - | Int32 : int32 -> 'a term + | Int32 : Int32.t -> 'a term + | Int64 : Int64.t -> 'a term + | Float32 : Float32.t -> 'a term + | Float64 : Float64.t -> 'a term | Var : text indice -> text term | GlobalVar : 'a indice -> 'a term | BinderVar : 'a indice -> 'a term @@ -135,30 +141,33 @@ let pp_binop fmt = function let rec pp_term : type a. formatter -> a term -> unit = fun fmt -> function - | Int32 i -> pf fmt "%i" (Int32.to_int i) + | Int32 i32 -> pf fmt "(i32 %i)" (Int32.to_int i32) + | Int64 i64 -> pf fmt "(i64 %i)" (Int64.to_int i64) + | Float32 f32 -> pf fmt "(f32 %a)" Float32.pp f32 + | Float64 f64 -> pf fmt "(f64 %a)" Float64.pp f64 | Var ind -> pf fmt "%a" pp_indice ind - | GlobalVar ind -> pf fmt "global.%a" pp_indice ind - | BinderVar ind -> pf fmt "binder.%a" pp_indice ind - | UnOp (u, tm1) -> pf fmt "@[%a@ %a@]" pp_unop u pp_term tm1 + | GlobalVar ind -> pf fmt "(global %a)" pp_indice ind + | BinderVar ind -> pf fmt "(binder %a)" pp_indice ind + | UnOp (u, tm1) -> pf fmt "@[(%a@ %a)@]" pp_unop u pp_term tm1 | BinOp (b, tm1, tm2) -> - pf fmt "@[%a@ %a@ %a@]" pp_term tm1 pp_binop b pp_term tm2 - | Result -> pf fmt {|\result|} + pf fmt "@[(%a@ %a@ %a)@]" pp_binop b pp_term tm1 pp_term tm2 + | Result -> pf fmt "result" let rec pp_prop : type a. formatter -> a prop -> unit = fun fmt -> function | Const bool -> pf fmt "%a" pp_bool bool | BinPred (b, tm1, tm2) -> - pf fmt "@[%a@ %a@ %a@]" pp_term tm1 pp_binpred b pp_term tm2 - | UnConnect (u, pr1) -> pf fmt "@[%a@ %a@]" pp_unconnect u pp_prop pr1 + pf fmt "@[(%a@ %a@ %a)@]" pp_binpred b pp_term tm1 pp_term tm2 + | UnConnect (u, pr1) -> pf fmt "@[(%a@ %a)@]" pp_unconnect u pp_prop pr1 | BinConnect (b, pr1, pr2) -> - pf fmt "@[%a@ %a@ %a@]" pp_prop pr1 pp_binconnect b pp_prop pr2 + pf fmt "@[(%a@ %a@ %a)@]" pp_binconnect b pp_prop pr1 pp_prop pr2 | Binder (b, bt, id_opt, pr1) -> ( match id_opt with | Some id -> - pf fmt "@[%a@ %a@ %a, %a@]" pp_binder b pp_binder_type bt pp_id id + pf fmt "@[(%a %a:%a@ %a)@]" pp_binder b pp_id id pp_binder_type bt pp_prop pr1 | None -> - pf fmt "@[%a@ %a@, %a@]" pp_binder b pp_binder_type bt pp_prop pr1 ) + pf fmt "@[(%a %a@ %a)@]" pp_binder b pp_binder_type bt pp_prop pr1 ) let valid_text_indice_char = function | '0' .. '9' @@ -221,6 +230,21 @@ let rec parse_term = match Int32.of_string_opt i32 with | Some i32 -> ok @@ Int32 i32 | None -> Error (`Invalid_int32 i32) ) + (* Int64 *) + | List [ Atom "i64"; Atom i64 ] -> ( + match Int64.of_string_opt i64 with + | Some i64 -> ok @@ Int64 i64 + | None -> Error (`Invalid_int64 i64) ) + (* Float32 *) + | List [ Atom "f32"; Atom f32 ] -> ( + match Float32.of_string_opt f32 with + | Some f32 -> ok @@ Float32 f32 + | None -> Error (`Invalid_float32 f32) ) + (* Float64 *) + | List [ Atom "f64"; Atom f64 ] -> ( + match Float64.of_string_opt f64 with + | Some f64 -> ok @@ Float64 f64 + | None -> Error (`Invalid_float64 f64) ) (* Var *) | Atom ind when Option.is_some (parse_text_id ind) -> let+ ind = parse_text_indice ind in diff --git a/src/annot/spec.mli b/src/annot/spec.mli index 448dc6eec..febbc0cea 100644 --- a/src/annot/spec.mli +++ b/src/annot/spec.mli @@ -32,7 +32,10 @@ type nonrec binop = | Div type 'a term = - | Int32 : int32 -> 'a term + | Int32 : Int32.t -> 'a term + | Int64 : Int64.t -> 'a term + | Float32 : Float32.t -> 'a term + | Float64 : Float64.t -> 'a term | Var : text indice -> text term | GlobalVar : 'a indice -> 'a term | BinderVar : 'a indice -> 'a term diff --git a/src/bin/owi.ml b/src/bin/owi.ml index 94bf0d28b..ba50d4cbd 100644 --- a/src/bin/owi.ml +++ b/src/bin/owi.ml @@ -369,16 +369,19 @@ let exit_code = | `Unsupported_file_extension _ext -> 53 | `Failed_with_but_expected (_got, _expected) -> 54 | `Annotation_id_incorrect _annotid -> 55 - | `Invalid_int32 _int32 -> 56 - | `Invalid_indice _id -> 57 - | `Invalid_text_indice _id -> 58 - | `Unknown_annotation_clause _s -> 59 - | `Unknown_annotation_object _s -> 60 - | `Unknown_binder _id -> 61 - | `Unknown_binder_or_global _id -> 62 - | `Unknown_binder_type _s -> 63 - | `Unknown_prop _pr -> 64 - | `Unknown_term _tm -> 65 + | `Invalid_int32 _i32 -> 56 + | `Invalid_int64 _i64 -> 57 + | `Invalid_float32 _f32 -> 58 + | `Invalid_float64 _f64 -> 59 + | `Invalid_indice _id -> 60 + | `Invalid_text_indice _id -> 61 + | `Unknown_annotation_clause _s -> 62 + | `Unknown_annotation_object _s -> 63 + | `Unknown_binder _id -> 64 + | `Unknown_binder_or_global _id -> 65 + | `Unknown_binder_type _s -> 66 + | `Unknown_prop _pr -> 67 + | `Unknown_term _tm -> 68 end end | Error e -> ( diff --git a/src/text_to_binary/rewrite.ml b/src/text_to_binary/rewrite.ml index 2db8679c0..d10424612 100644 --- a/src/text_to_binary/rewrite.ml +++ b/src/text_to_binary/rewrite.ml @@ -378,7 +378,10 @@ let rec rewrite_term (modul : Assigned.t) (binder_list : string option list) : text Spec.term -> binary Spec.term Result.t = let open Spec in function - | Int32 i -> Ok (Int32 i) + | Int32 i32 -> Ok (Int32 i32) + | Int64 i64 -> Ok (Int64 i64) + | Float32 f32 -> Ok (Float32 f32) + | Float64 f64 -> Ok (Float64 f64) | Var ind -> ( match (find_binder binder_list ind, find_global modul ind) with | Ok ind, _ -> Ok (BinderVar ind) diff --git a/src/utils/result.ml b/src/utils/result.ml index d33049129..d34fcf71a 100644 --- a/src/utils/result.ml +++ b/src/utils/result.ml @@ -61,6 +61,9 @@ type err = | `Unsupported_file_extension of string | `Annotation_id_incorrect of string | `Invalid_int32 of string + | `Invalid_int64 of string + | `Invalid_float32 of string + | `Invalid_float64 of string | `Invalid_indice of string | `Invalid_text_indice of string | `Unknown_annotation_clause of Sexp.t @@ -137,7 +140,10 @@ let rec err_to_string = function Fmt.str "unsupported file_extension %S" ext | `Annotation_id_incorrect annotid -> Fmt.str "annotation id %S incorrect" annotid - | `Invalid_int32 int32 -> Fmt.str "invalid int32 %S" int32 + | `Invalid_int32 i32 -> Fmt.str "invalid int32 %S" i32 + | `Invalid_int64 i64 -> Fmt.str "invalid int64 %S" i64 + | `Invalid_float32 f32 -> Fmt.str "invalid float32 %S" f32 + | `Invalid_float64 f64 -> Fmt.str "invalid float64 %S" f64 | `Invalid_indice id -> Fmt.str "invalid indice %S" id | `Invalid_text_indice id -> Fmt.str "invalid text indice %S" id | `Unknown_annotation_clause s -> diff --git a/src/utils/result.mli b/src/utils/result.mli index 2efec5d2f..7e8a783d8 100644 --- a/src/utils/result.mli +++ b/src/utils/result.mli @@ -61,6 +61,9 @@ type err = | `Unsupported_file_extension of string | `Annotation_id_incorrect of string | `Invalid_int32 of string + | `Invalid_int64 of string + | `Invalid_float32 of string + | `Invalid_float64 of string | `Invalid_indice of string | `Invalid_text_indice of string | `Unknown_annotation_clause of Sexp.t From e4920d442843e35bcae837cc9d02c33e820b94ee Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Tue, 13 Aug 2024 00:52:52 +0200 Subject: [PATCH 22/51] add unfinished test of spec --- test/conc/plus.wat | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 test/conc/plus.wat diff --git a/test/conc/plus.wat b/test/conc/plus.wat new file mode 100644 index 000000000..f8fd727ba --- /dev/null +++ b/test/conc/plus.wat @@ -0,0 +1,8 @@ +(module + (@contract $plus_three + (ensures (= result (+ $x 3))) + ) + (func $plus_three + (param $x i32) (result i32) + (i32.add (i32.const 3) (local.get $x))) +) From 88856907202e65252d10b6d3c245d0004bf5f2ad Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Tue, 13 Aug 2024 13:30:55 +0200 Subject: [PATCH 23/51] add rewriting for function parameters --- src/annot/contract.ml | 12 ++-- src/annot/contract.mli | 2 +- src/annot/spec.ml | 28 ++++++-- src/annot/spec.mli | 6 +- src/bin/owi.ml | 9 +-- src/parser/text_parser.mly | 20 +++++- src/text_to_binary/rewrite.ml | 128 +++++++++++++++++++++++----------- src/utils/result.ml | 7 +- src/utils/result.mli | 3 +- 9 files changed, 153 insertions(+), 62 deletions(-) diff --git a/src/annot/contract.ml b/src/annot/contract.ml index 8b0d49b29..18729ba3f 100644 --- a/src/annot/contract.ml +++ b/src/annot/contract.ml @@ -4,18 +4,18 @@ open Spec open Syntax type 'a t = - { func : 'a indice + { funcid : 'a indice ; preconditions : 'a prop list ; postconditions : 'a prop list } -let pp_contract fmt { func; preconditions; postconditions } = +let pp_contract fmt { funcid; preconditions; postconditions } = pf fmt "@[Contract of function %a@,\ Preconditions:@;\ <1 2>@[%a@]@,\ Postconditions:@;\ - <1 2>@[%a@]@]" pp_indice func + <1 2>@[%a@]@]" pp_indice funcid (list ~sep:pp_newline pp_prop) preconditions (list ~sep:pp_newline pp_prop) @@ -28,7 +28,7 @@ let cons_second (l1, l2) x2 = (l1, x2 :: l2) let parse_contract = let open Sexp in function - | List (Atom func :: conds) -> + | List (Atom funcid :: conds) -> let aux acc = function | List [ Atom "requires"; precond ] -> let+ precond = parse_prop precond in @@ -38,7 +38,7 @@ let parse_contract = cons_second acc postcond | _ as s -> Error (`Unknown_annotation_clause s) in - let* func = parse_indice func in + let* funcid = parse_indice funcid in let+ preconditions, postconditions = list_fold_left aux ([], []) conds in - { func; preconditions; postconditions } + { funcid; preconditions; postconditions } | _ as s -> Error (`Unknown_annotation_object s) diff --git a/src/annot/contract.mli b/src/annot/contract.mli index 8ec944414..38e85911e 100644 --- a/src/annot/contract.mli +++ b/src/annot/contract.mli @@ -3,7 +3,7 @@ open Types open Spec type 'a t = - { func : 'a indice + { funcid : 'a indice ; preconditions : 'a prop list ; postconditions : 'a prop list } diff --git a/src/annot/spec.ml b/src/annot/spec.ml index 5d290bf74..7cd14f17a 100644 --- a/src/annot/spec.ml +++ b/src/annot/spec.ml @@ -20,8 +20,9 @@ pterm ::= 'i32' i32 ==> Int32 (Int32.of_string i32) | 'i64' i64 ==> Int64 (Int64.of_string i64) | 'f32' f32 ==> Float32 (Float32.of_string f32) | 'f64' f64 ==> Float64 (Float64.of_string f64) - | 'global' ind ==> let* ind = parse_indice ind in Global ind - | 'binder' ind ==> let* ind = parse_indice ind in Binder ind + | 'param' ind ==> let* ind = parse_indice ind in ParamVar ind + | 'global' ind ==> let* ind = parse_indice ind in GlobalVar ind + | 'binder' ind ==> let* ind = parse_indice ind in BinderVar ind | unop term_1 ==> Unop (unop, term_1) | binop term_1 term_2 ==> BinOp (binop, term_1, term_2) @@ -82,13 +83,16 @@ type nonrec binder = type nonrec binder_type = num_type -type nonrec unop = Neg +type nonrec unop = + | Neg + | CustomUnOp of string (* for testing purpose only *) type nonrec binop = | Plus | Minus | Mult | Div + | CustomBinOp of string (* for testing purpose only *) type 'a term = | Int32 : Int32.t -> 'a term @@ -96,6 +100,7 @@ type 'a term = | Float32 : Float32.t -> 'a term | Float64 : Float64.t -> 'a term | Var : text indice -> text term + | ParamVar : 'a indice -> 'a term | GlobalVar : 'a indice -> 'a term | BinderVar : 'a indice -> 'a term | UnOp : unop * 'a term -> 'a term @@ -131,13 +136,16 @@ let pp_binder fmt = function Forall -> pf fmt "∀" | Exists -> pf fmt "∃" let pp_binder_type = pp_num_type -let pp_unop fmt = function Neg -> pf fmt "-" +let pp_unop fmt = function + | Neg -> pf fmt "-" + | CustomUnOp c -> pf fmt "%a" string c let pp_binop fmt = function | Plus -> pf fmt "+" | Minus -> pf fmt "-" | Mult -> pf fmt "*" | Div -> pf fmt "/" + | CustomBinOp c -> pf fmt "%a" string c let rec pp_term : type a. formatter -> a term -> unit = fun fmt -> function @@ -146,6 +154,7 @@ let rec pp_term : type a. formatter -> a term -> unit = | Float32 f32 -> pf fmt "(f32 %a)" Float32.pp f32 | Float64 f64 -> pf fmt "(f64 %a)" Float64.pp f64 | Var ind -> pf fmt "%a" pp_indice ind + | ParamVar ind -> pf fmt "(param %a)" pp_indice ind | GlobalVar ind -> pf fmt "(global %a)" pp_indice ind | BinderVar ind -> pf fmt "(binder %a)" pp_indice ind | UnOp (u, tm1) -> pf fmt "@[(%a@ %a)@]" pp_unop u pp_term tm1 @@ -249,6 +258,10 @@ let rec parse_term = | Atom ind when Option.is_some (parse_text_id ind) -> let+ ind = parse_text_indice ind in Var ind + (* ParamVar *) + | List [ Atom "param"; Atom ind ] -> + let+ ind = parse_indice ind in + ParamVar ind (* GlobalVar *) | List [ Atom "global"; Atom ind ] -> let+ ind = parse_indice ind in @@ -261,6 +274,9 @@ let rec parse_term = | List [ Atom "-"; tm1 ] -> let+ tm1 = parse_term tm1 in UnOp (Neg, tm1) + | List [ Atom c; tm1 ] -> + let+ tm1 = parse_term tm1 in + UnOp (CustomUnOp c, tm1) (* BinOp *) | List [ Atom "+"; tm1; tm2 ] -> let* tm1 = parse_term tm1 in @@ -278,6 +294,10 @@ let rec parse_term = let* tm1 = parse_term tm1 in let+ tm2 = parse_term tm2 in BinOp (Div, tm1, tm2) + | List [ Atom c; tm1; tm2 ] -> + let* tm1 = parse_term tm1 in + let+ tm2 = parse_term tm2 in + BinOp (CustomBinOp c, tm1, tm2) (* Result *) | Atom "result" -> ok Result (* Invalid *) diff --git a/src/annot/spec.mli b/src/annot/spec.mli index febbc0cea..a52f47626 100644 --- a/src/annot/spec.mli +++ b/src/annot/spec.mli @@ -23,13 +23,16 @@ type nonrec binder = type nonrec binder_type = num_type -type nonrec unop = Neg +type nonrec unop = + | Neg + | CustomUnOp of string (* for testing purpose only *) type nonrec binop = | Plus | Minus | Mult | Div + | CustomBinOp of string (* for testing purpose only *) type 'a term = | Int32 : Int32.t -> 'a term @@ -37,6 +40,7 @@ type 'a term = | Float32 : Float32.t -> 'a term | Float64 : Float64.t -> 'a term | Var : text indice -> text term + | ParamVar : 'a indice -> 'a term | GlobalVar : 'a indice -> 'a term | BinderVar : 'a indice -> 'a term | UnOp : unop * 'a term -> 'a term diff --git a/src/bin/owi.ml b/src/bin/owi.ml index ba50d4cbd..8388404a9 100644 --- a/src/bin/owi.ml +++ b/src/bin/owi.ml @@ -378,10 +378,11 @@ let exit_code = | `Unknown_annotation_clause _s -> 62 | `Unknown_annotation_object _s -> 63 | `Unknown_binder _id -> 64 - | `Unknown_binder_or_global _id -> 65 - | `Unknown_binder_type _s -> 66 - | `Unknown_prop _pr -> 67 - | `Unknown_term _tm -> 68 + | `Unknown_param _id -> 65 + | `Unknown_variable _id -> 66 + | `Unknown_binder_type _s -> 67 + | `Unknown_prop _pr -> 68 + | `Unknown_term _tm -> 69 end end | Error e -> ( diff --git a/src/parser/text_parser.mly b/src/parser/text_parser.mly index 29645ea08..367b0af1c 100644 --- a/src/parser/text_parser.mly +++ b/src/parser/text_parser.mly @@ -992,8 +992,24 @@ let inline_module_inner == | fields = list(par(module_field)); { let fields = List.flatten fields in let id = None in - let annots = Annot.get_annots () in - let () = Fmt.pr "%a" (Fmt.list ~sep:(fun _ _ -> Fmt.pr "@\n ") Annot.pp_annot) annots in + let open Annot in + let open Contract in + let open Syntax in + let annots = get_annots () in + let annots = + match (list_map + (fun t -> + match t with + | Annot t -> + let+ c = parse_contract t.items in + Contract c + | _ -> Error (`Invalid_indice "")) + annots) with + | Ok annots -> annots + | _ -> [] + in + Fmt.(pr "Recorded annotations:\n"); + Fmt.(pr "%a\n" (list pp_annot) annots); { id; fields; annots } } diff --git a/src/text_to_binary/rewrite.ml b/src/text_to_binary/rewrite.ml index d10424612..6b0634622 100644 --- a/src/text_to_binary/rewrite.ml +++ b/src/text_to_binary/rewrite.ml @@ -54,19 +54,6 @@ let rewrite_block_type (typemap : binary indice TypeMap.t) (modul : Assigned.t) in Bt_raw (Some idx, t) -let find_binder (binder_list : string option list) (ind : text indice) : - binary indice Result.t = - match ind with - | Raw id -> Ok (Raw id) - | Text id -> - let rec aux acc = function - | [] -> Error (`Unknown_binder ind) - | Some id' :: bl -> - if String.equal id id' then Ok (Raw acc) else aux (acc + 1) bl - | _ :: bl -> aux (acc + 1) bl - in - aux 0 binder_list - let rewrite_expr (typemap : binary indice TypeMap.t) (modul : Assigned.t) (locals : binary param list) (iexpr : text expr) : binary expr Result.t = (* block_ids handling *) @@ -374,8 +361,41 @@ let rewrite_types (_modul : Assigned.t) (t : binary str_type) : let t = [ (None, (Final, [], t)) ] in Ok t -let rec rewrite_term (modul : Assigned.t) (binder_list : string option list) : +let rec rewrite_term (binder_list : string option list) + ?(modul : Binary.modul = Binary.empty_modul) + ?(func_param_list : string option list = []) : text Spec.term -> binary Spec.term Result.t = + let rec aux error acc id = function + | [] -> Error error + | Some id' :: bl -> + if String.equal id id' then Ok (Raw acc) else aux error (acc + 1) id bl + | _ :: bl -> aux error (acc + 1) id bl + in + + let find_binder (binder_list : string option list) (ind : text indice) : + binary indice Result.t = + match ind with + | Raw id -> Ok (Raw id) + | Text id -> aux (`Unknown_binder ind) 0 id binder_list + in + + let find_param (func_param_list : string option list) (ind : text indice) : + binary indice Result.t = + match ind with + | Raw id -> Ok (Raw id) + | Text id -> aux (`Unknown_param ind) 0 id func_param_list + in + + let find_global (modul : Binary.modul) (ind : text indice) : + binary indice Result.t = + match ind with + | Raw id -> Ok (Raw id) + | Text id -> ( + match String_map.find_opt id modul.global.named with + | None -> Error (`Unknown_global ind) + | Some i -> Ok (Raw i) ) + in + let open Spec in function | Int32 i32 -> Ok (Int32 i32) @@ -383,10 +403,18 @@ let rec rewrite_term (modul : Assigned.t) (binder_list : string option list) : | Float32 f32 -> Ok (Float32 f32) | Float64 f64 -> Ok (Float64 f64) | Var ind -> ( - match (find_binder binder_list ind, find_global modul ind) with - | Ok ind, _ -> Ok (BinderVar ind) - | _, Ok ind -> Ok (GlobalVar ind) - | _, _ -> Error (`Unknown_binder_or_global ind) ) + match + ( find_binder binder_list ind + , find_param func_param_list ind + , find_global modul ind ) + with + | Ok ind, _, _ -> Ok (BinderVar ind) + | _, Ok ind, _ -> Ok (ParamVar ind) + | _, _, Ok ind -> Ok (GlobalVar ind) + | _, _, _ -> Error (`Unknown_variable ind) ) + | ParamVar ind -> + let+ ind = find_param func_param_list ind in + ParamVar ind | GlobalVar ind -> let+ ind = find_global modul ind in GlobalVar ind @@ -394,50 +422,67 @@ let rec rewrite_term (modul : Assigned.t) (binder_list : string option list) : let+ ind = find_binder binder_list ind in BinderVar ind | UnOp (u, tm1) -> - let+ tm1 = rewrite_term modul binder_list tm1 in + let+ tm1 = rewrite_term binder_list ~modul ~func_param_list tm1 in UnOp (u, tm1) | BinOp (b, tm1, tm2) -> - let* tm1 = rewrite_term modul binder_list tm1 in - let+ tm2 = rewrite_term modul binder_list tm2 in + let* tm1 = rewrite_term binder_list ~modul ~func_param_list tm1 in + let+ tm2 = rewrite_term binder_list ~modul ~func_param_list tm2 in BinOp (b, tm1, tm2) | Result -> Ok Result -let rec rewrite_prop (modul : Assigned.t) (binder_list : string option list) : +let rec rewrite_prop (binder_list : string option list) + ?(modul : Binary.modul = Binary.empty_modul) + ?(func_param_list : string option list = []) : text Spec.prop -> binary Spec.prop Result.t = let open Spec in function | Const b -> Ok (Const b) | BinPred (b, tm1, tm2) -> - let* tm1 = rewrite_term modul binder_list tm1 in - let+ tm2 = rewrite_term modul binder_list tm2 in + let* tm1 = rewrite_term binder_list ~modul ~func_param_list tm1 in + let+ tm2 = rewrite_term binder_list ~modul ~func_param_list tm2 in BinPred (b, tm1, tm2) | UnConnect (u, pr1) -> - let+ pr1 = rewrite_prop modul binder_list pr1 in + let+ pr1 = rewrite_prop binder_list ~modul ~func_param_list pr1 in UnConnect (u, pr1) | BinConnect (b, pr1, pr2) -> - let* pr1 = rewrite_prop modul binder_list pr1 in - let+ pr2 = rewrite_prop modul binder_list pr2 in + let* pr1 = rewrite_prop binder_list ~modul ~func_param_list pr1 in + let+ pr2 = rewrite_prop binder_list ~modul ~func_param_list pr2 in BinConnect (b, pr1, pr2) | Binder (b, bt, id_opt, pr1) -> - let+ pr1 = rewrite_prop modul (id_opt :: binder_list) pr1 in - Binder (b, bt, None, pr1) + let+ pr1 = + rewrite_prop (id_opt :: binder_list) ~modul ~func_param_list pr1 + in + Binder (b, bt, id_opt, pr1) -let rewrite_contract (modul : Assigned.t) : +let rewrite_contract (modul : Binary.modul) : text Contract.t -> binary Contract.t Result.t = - fun { Contract.func; preconditions; postconditions } -> - let* func = find (`Unknown_func func) modul.func func in - let* preconditions = list_map (rewrite_prop modul []) preconditions in - let+ postconditions = list_map (rewrite_prop modul []) postconditions in - { Contract.func; preconditions; postconditions } + fun { Contract.funcid; preconditions; postconditions } -> + let* func = get (`Unknown_func funcid) modul.func funcid in + let funcid = Raw (Indexed.get_index func) in + let func_param_list = + let (Bt_raw (_, (params, _))) = + match Indexed.get func with + | Local { type_f; _ } -> type_f + | Imported { desc; _ } -> desc + in + List.map fst params + in + let* preconditions = + list_map (rewrite_prop [] ~modul ~func_param_list) preconditions + in + let+ postconditions = + list_map (rewrite_prop [] ~modul ~func_param_list) postconditions + in + { Contract.funcid; preconditions; postconditions } -let rewrite_annot (modul : Assigned.t) : +let rewrite_annot (modul : Binary.modul) : text Annot.annot -> Binary.custom Result.t = function | Contract contract -> let+ contract = rewrite_contract modul contract in Binary.From_annot (Contract contract) | Annot annot -> ok @@ Binary.From_annot (Annot annot) -let rewrite_annots (modul : Assigned.t) : +let rewrite_annots (modul : Binary.modul) : text Annot.annot list -> Binary.custom list Result.t = list_map (rewrite_annot modul) @@ -469,7 +514,6 @@ let modul (modul : Assigned.t) : Binary.modul Result.t = let (Raw id) = find func id in Some id in - let+ custom = rewrite_annots modul modul.annots in let id = modul.id in let mem = Named.to_array modul.mem in @@ -480,7 +524,11 @@ let modul (modul : Assigned.t) : Binary.modul Result.t = let data = Named.to_array data in let func = Named.to_array func in - let modul : Binary.modul = - { id; mem; table; types; global; elem; data; exports; func; start; custom } + let modul_without_annots : Binary.modul = + { id; mem; table; types; global; elem; data; exports; func; start; custom = [] } in + + let+ custom = rewrite_annots modul_without_annots modul.annots in + + let modul : Binary.modul = { modul_without_annots with custom } in modul diff --git a/src/utils/result.ml b/src/utils/result.ml index d34fcf71a..f4361e0ab 100644 --- a/src/utils/result.ml +++ b/src/utils/result.ml @@ -69,7 +69,8 @@ type err = | `Unknown_annotation_clause of Sexp.t | `Unknown_annotation_object of Sexp.t | `Unknown_binder of Types.text Types.indice - | `Unknown_binder_or_global of Types.text Types.indice + | `Unknown_param of Types.text Types.indice + | `Unknown_variable of Types.text Types.indice | `Unknown_binder_type of Sexp.t | `Unknown_prop of Sexp.t | `Unknown_term of Sexp.t @@ -151,8 +152,8 @@ let rec err_to_string = function | `Unknown_annotation_object s -> Fmt.str "unknown annotation object %a" Sexp.pp_sexp s | `Unknown_binder id -> Fmt.str "unknown binder %a" Types.pp_indice id - | `Unknown_binder_or_global id -> - Fmt.str "unknown binder or global %a" Types.pp_indice id + | `Unknown_param id -> Fmt.str "unknown param %a" Types.pp_indice id + | `Unknown_variable id -> Fmt.str "unknown variable %a" Types.pp_indice id | `Unknown_binder_type s -> Fmt.str "unknown binder type %a" Sexp.pp_sexp s | `Unknown_prop pr -> Fmt.str "unknown prop %a" Sexp.pp_sexp pr | `Unknown_term tm -> Fmt.str "unknown term %a" Sexp.pp_sexp tm diff --git a/src/utils/result.mli b/src/utils/result.mli index 7e8a783d8..bbc69331b 100644 --- a/src/utils/result.mli +++ b/src/utils/result.mli @@ -69,7 +69,8 @@ type err = | `Unknown_annotation_clause of Sexp.t | `Unknown_annotation_object of Sexp.t | `Unknown_binder of Types.text Types.indice - | `Unknown_binder_or_global of Types.text Types.indice + | `Unknown_param of Types.text Types.indice + | `Unknown_variable of Types.text Types.indice | `Unknown_binder_type of Sexp.t | `Unknown_prop of Sexp.t | `Unknown_term of Sexp.t From 8e916ab0c68e8cf224a49ac69da4704af2a1e750 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Tue, 13 Aug 2024 14:06:32 +0200 Subject: [PATCH 24/51] small fixes --- src/annot/contract.ml | 14 +++++--------- src/annot/spec.ml | 19 ++++++++----------- src/annot/spec.mli | 2 -- 3 files changed, 13 insertions(+), 22 deletions(-) diff --git a/src/annot/contract.ml b/src/annot/contract.ml index 18729ba3f..39fe06644 100644 --- a/src/annot/contract.ml +++ b/src/annot/contract.ml @@ -21,24 +21,20 @@ let pp_contract fmt { funcid; preconditions; postconditions } = (list ~sep:pp_newline pp_prop) postconditions -let cons_first (l1, l2) x1 = (x1 :: l1, l2) - -let cons_second (l1, l2) x2 = (l1, x2 :: l2) - let parse_contract = let open Sexp in function | List (Atom funcid :: conds) -> - let aux acc = function + let aux (l1, l2) = function | List [ Atom "requires"; precond ] -> let+ precond = parse_prop precond in - cons_first acc precond + (precond :: l1, l2) | List [ Atom "ensures"; postcond ] -> let+ postcond = parse_prop postcond in - cons_second acc postcond - | _ as s -> Error (`Unknown_annotation_clause s) + (l1, postcond :: l2) + | cl -> Error (`Unknown_annotation_clause cl) in let* funcid = parse_indice funcid in let+ preconditions, postconditions = list_fold_left aux ([], []) conds in { funcid; preconditions; postconditions } - | _ as s -> Error (`Unknown_annotation_object s) + | annot -> Error (`Unknown_annotation_object annot) diff --git a/src/annot/spec.ml b/src/annot/spec.ml index 7cd14f17a..fd4775aee 100644 --- a/src/annot/spec.ml +++ b/src/annot/spec.ml @@ -114,8 +114,6 @@ type 'a prop = | BinConnect : binconnect * 'a prop * 'a prop -> 'a prop | Binder : binder * binder_type * string option * 'a prop -> 'a prop -let pp_bool fmt = function true -> pf fmt "true" | false -> pf fmt "false" - let pp_binpred fmt = function | Ge -> pf fmt "≥" | Gt -> pf fmt ">" @@ -164,7 +162,7 @@ let rec pp_term : type a. formatter -> a term -> unit = let rec pp_prop : type a. formatter -> a prop -> unit = fun fmt -> function - | Const bool -> pf fmt "%a" pp_bool bool + | Const bool -> pf fmt "%a" Fmt.bool bool | BinPred (b, tm1, tm2) -> pf fmt "@[(%a@ %a@ %a)@]" pp_binpred b pp_term tm1 pp_term tm2 | UnConnect (u, pr1) -> pf fmt "@[(%a@ %a)@]" pp_unconnect u pp_prop pr1 @@ -206,8 +204,7 @@ let parse_text_id_result id = else Error (`Invalid_text_indice id) with Invalid_argument _ -> Error (`Invalid_text_indice id) -let parse_raw_id id = - match int_of_string id with Some id -> Some id | None -> None +let parse_raw_id id = int_of_string id let parse_text_indice id = match parse_text_id id with @@ -223,11 +220,11 @@ let parse_indice id = let parse_binder_type = let open Sexp in function - | Atom "i32" -> ok I32 - | Atom "i64" -> ok I64 - | Atom "f32" -> ok F32 - | Atom "f64" -> ok F64 - | _ as bt -> Error (`Unknown_binder_type bt) + | Atom "i32" -> Ok I32 + | Atom "i64" -> Ok I64 + | Atom "f32" -> Ok F32 + | Atom "f64" -> Ok F64 + | bt -> Error (`Unknown_binder_type bt) let rec parse_term = let open Sexp in @@ -301,7 +298,7 @@ let rec parse_term = (* Result *) | Atom "result" -> ok Result (* Invalid *) - | _ as tm -> Error (`Unknown_term tm) + | tm -> Error (`Unknown_term tm) let rec parse_prop = let open Sexp in diff --git a/src/annot/spec.mli b/src/annot/spec.mli index a52f47626..d7c1078a8 100644 --- a/src/annot/spec.mli +++ b/src/annot/spec.mli @@ -54,8 +54,6 @@ type 'a prop = | BinConnect : binconnect * 'a prop * 'a prop -> 'a prop | Binder : binder * binder_type * string option * 'a prop -> 'a prop -val pp_bool : formatter -> bool -> unit - val pp_binpred : formatter -> binpred -> unit val pp_unconnect : formatter -> unconnect -> unit From 49909b7e06301f4c0279ac17094769277517c40f Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Tue, 13 Aug 2024 14:13:09 +0200 Subject: [PATCH 25/51] fix --- src/annot/spec.ml | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/annot/spec.ml b/src/annot/spec.ml index fd4775aee..9038a505e 100644 --- a/src/annot/spec.ml +++ b/src/annot/spec.ml @@ -186,23 +186,24 @@ let valid_text_indice_char = function | _ -> false let parse_text_id id = - try - let len = String.length id in + let len = String.length id in + if len >= 2 then let hd = String.get id 0 in let tl = String.sub id 1 (len - 1) in - if Char.equal hd '$' && String.for_all valid_text_indice_char id then - Some tl + if Char.equal hd '$' && String.for_all valid_text_indice_char id + then Some tl else None - with Invalid_argument _ -> None + else None let parse_text_id_result id = - try - let len = String.length id in + let len = String.length id in + if len >= 2 then let hd = String.get id 0 in let tl = String.sub id 1 (len - 1) in - if Char.equal hd '$' && String.for_all valid_text_indice_char id then Ok tl + if Char.equal hd '$' && String.for_all valid_text_indice_char id + then Ok tl else Error (`Invalid_text_indice id) - with Invalid_argument _ -> Error (`Invalid_text_indice id) + else Error (`Invalid_text_indice id) let parse_raw_id id = int_of_string id From 6c76976a1b1193fb093b0451a918ed5d9e293644 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Tue, 13 Aug 2024 15:24:38 +0200 Subject: [PATCH 26/51] rename Int32.to_string to Int32.to_string_exn rename Int32.to_string_opt to Int32.to_string same for Int64, Float32, Float64 --- src/annot/spec.ml | 53 +++++++++++++++++------------------ src/parser/text_parser.mly | 11 ++++---- src/primitives/float32.ml | 8 +++--- src/primitives/float32.mli | 4 +-- src/primitives/float64.ml | 8 +++--- src/primitives/float64.mli | 4 +-- src/primitives/int32.ml | 4 +-- src/primitives/int32.mli | 4 +-- src/primitives/int64.ml | 4 +-- src/primitives/int64.mli | 4 +-- src/text_to_binary/rewrite.ml | 11 ++++---- test/conc/plus.wat | 8 ------ test/script/annotations.t | 1 - test/script/reference.t | 1 + test/script/reference_opt.t | 1 + 15 files changed, 59 insertions(+), 67 deletions(-) delete mode 100644 test/conc/plus.wat delete mode 100644 test/script/annotations.t diff --git a/src/annot/spec.ml b/src/annot/spec.ml index 9038a505e..78dd50966 100644 --- a/src/annot/spec.ml +++ b/src/annot/spec.ml @@ -12,14 +12,14 @@ binop ::= '+' ==> Plus | '/' ==> Div term ::= '(' pterm ')' ==> pterm - | i32 ==> Int32 (Int32.of_string i32) if Option.is_some (Int32.of_string_opt i32) - | ind ==> let* ind = parse_text_indice ind in Var ind if Option.is_some (parse_text_id ind) + | i32 ==> match Int32.of_string i32 with Some i32 -> Int32 i32 + | ind ==> match parse_text_id ind with Some ind -> Var (Text ind) | result ==> Result -pterm ::= 'i32' i32 ==> Int32 (Int32.of_string i32) - | 'i64' i64 ==> Int64 (Int64.of_string i64) - | 'f32' f32 ==> Float32 (Float32.of_string f32) - | 'f64' f64 ==> Float64 (Float64.of_string f64) +pterm ::= 'i32' i32 ==> match Int32.of_string i32 with Some i32 -> Int32 i32 | None -> `Invalid_int32 i32 + | 'i64' i64 ==> match Int64.of_string i64 with Some i64 -> Int64 i64 | None -> `Invalid_int64 i64 + | 'f32' f32 ==> match Float32.of_string f32 with Some f32 -> Float32 f32 | None -> `Invalid_float32 f32 + | 'f64' f64 ==> match Float64.of_string f64 with Some f64 -> Float64 f64 | None -> `Invalid_float64 f64 | 'param' ind ==> let* ind = parse_indice ind in ParamVar ind | 'global' ind ==> let* ind = parse_indice ind in GlobalVar ind | 'binder' ind ==> let* ind = parse_indice ind in BinderVar ind @@ -190,8 +190,8 @@ let parse_text_id id = if len >= 2 then let hd = String.get id 0 in let tl = String.sub id 1 (len - 1) in - if Char.equal hd '$' && String.for_all valid_text_indice_char id - then Some tl + if Char.equal hd '$' && String.for_all valid_text_indice_char id then + Some tl else None else None @@ -200,18 +200,12 @@ let parse_text_id_result id = if len >= 2 then let hd = String.get id 0 in let tl = String.sub id 1 (len - 1) in - if Char.equal hd '$' && String.for_all valid_text_indice_char id - then Ok tl + if Char.equal hd '$' && String.for_all valid_text_indice_char id then Ok tl else Error (`Invalid_text_indice id) else Error (`Invalid_text_indice id) let parse_raw_id id = int_of_string id -let parse_text_indice id = - match parse_text_id id with - | Some id -> Ok (Text id) - | None -> Error (`Invalid_text_indice id) - let parse_indice id = match (parse_text_id id, parse_raw_id id) with | Some id, _ -> Ok (Text id) @@ -230,32 +224,39 @@ let parse_binder_type = let rec parse_term = let open Sexp in function + | Atom a as tm -> begin + (* Int32 *) + match Int32.of_string a with + | Some i32 -> Ok (Int32 i32) + | None -> ( + (* Var *) + match parse_text_id a with + | Some ind -> Ok (Var (Text ind)) + | None -> + (* Result *) + if String.equal "result" a then Ok Result (* Invalid *) + else Error (`Unknown_term tm) ) + end (* Int32 *) - | Atom i32 when Option.is_some (Int32.of_string_opt i32) -> - ok @@ Int32 (Int32.of_string i32) | List [ Atom "i32"; Atom i32 ] -> ( - match Int32.of_string_opt i32 with + match Int32.of_string i32 with | Some i32 -> ok @@ Int32 i32 | None -> Error (`Invalid_int32 i32) ) (* Int64 *) | List [ Atom "i64"; Atom i64 ] -> ( - match Int64.of_string_opt i64 with + match Int64.of_string i64 with | Some i64 -> ok @@ Int64 i64 | None -> Error (`Invalid_int64 i64) ) (* Float32 *) | List [ Atom "f32"; Atom f32 ] -> ( - match Float32.of_string_opt f32 with + match Float32.of_string f32 with | Some f32 -> ok @@ Float32 f32 | None -> Error (`Invalid_float32 f32) ) (* Float64 *) | List [ Atom "f64"; Atom f64 ] -> ( - match Float64.of_string_opt f64 with + match Float64.of_string f64 with | Some f64 -> ok @@ Float64 f64 | None -> Error (`Invalid_float64 f64) ) - (* Var *) - | Atom ind when Option.is_some (parse_text_id ind) -> - let+ ind = parse_text_indice ind in - Var ind (* ParamVar *) | List [ Atom "param"; Atom ind ] -> let+ ind = parse_indice ind in @@ -296,8 +297,6 @@ let rec parse_term = let* tm1 = parse_term tm1 in let+ tm2 = parse_term tm2 in BinOp (CustomBinOp c, tm1, tm2) - (* Result *) - | Atom "result" -> ok Result (* Invalid *) | tm -> Error (`Unknown_term tm) diff --git a/src/parser/text_parser.mly b/src/parser/text_parser.mly index 367b0af1c..d0d15487d 100644 --- a/src/parser/text_parser.mly +++ b/src/parser/text_parser.mly @@ -36,19 +36,19 @@ let u32 s = with Failure msg -> Fmt.kstr failwith "constant out of range %s (%s)" s msg let i32 s = - try Int32.of_string s + try Int32.of_string_exn s with Failure msg -> Fmt.kstr failwith "constant out of range %s (%s)" s msg let i64 s = - try Int64.of_string s + try Int64.of_string_exn s with Failure msg -> Fmt.kstr failwith "constant out of range %s (%s)" s msg let f64 s = - try Float64.of_string s + try Float64.of_string_exn s with Failure msg -> Fmt.kstr failwith "constant out of range %s (%s)" s msg let f32 s = - try Float32.of_string s + try Float32.of_string_exn s with Failure msg -> Fmt.kstr failwith "constant out of range %s (%s)" s msg %} @@ -1008,8 +1008,7 @@ let inline_module_inner == | Ok annots -> annots | _ -> [] in - Fmt.(pr "Recorded annotations:\n"); - Fmt.(pr "%a\n" (list pp_annot) annots); + let () = Fmt.(pr "%a\n" (list pp_annot) annots) in { id; fields; annots } } diff --git a/src/primitives/float32.ml b/src/primitives/float32.ml index 21ed92898..9d7096361 100644 --- a/src/primitives/float32.ml +++ b/src/primitives/float32.ml @@ -293,7 +293,7 @@ let of_signless_string s = if String.equal s "inf" then pos_inf else if String.equal s "nan" then pos_nan else if String.length s > 6 && String.equal (String.sub s 0 6) "nan:0x" then - let x = Int32.of_string (String.sub s 4 (String.length s - 4)) in + let x = Int32.of_string_exn (String.sub s 4 (String.length s - 4)) in if Int32.eq x Int32.zero then Fmt.failwith "nan payload must not be zero" else if Int32.ne (Int32.logand x bare_nan) Int32.zero then Fmt.failwith "nan payload must not overlap with exponent bits" @@ -305,14 +305,14 @@ let of_signless_string s = let x = of_float (float_of_string_prevent_double_rounding s') in if is_inf x then Log.err "of_string" else x -let of_string s = - if String.equal s "" then Log.err "of_string" +let of_string_exn s = + if String.equal s "" then Log.err "of_string_exn" else if Char.equal s.[0] '+' || Char.equal s.[0] '-' then let x = of_signless_string (String.sub s 1 (String.length s - 1)) in if Char.equal s.[0] '+' then x else neg x else of_signless_string s -let of_string_opt s = try Some (of_string s) with _ -> None +let of_string s = try Some (of_string_exn s) with _ -> None (* String conversion that groups digits for readability *) diff --git a/src/primitives/float32.mli b/src/primitives/float32.mli index fd2e56260..f6d7e2645 100644 --- a/src/primitives/float32.mli +++ b/src/primitives/float32.mli @@ -60,9 +60,9 @@ val le : t -> t -> bool val ge : t -> t -> bool -val of_string : string -> t +val of_string_exn : string -> t -val of_string_opt : string -> t option +val of_string : string -> t option val to_hex_string : t -> string diff --git a/src/primitives/float64.ml b/src/primitives/float64.ml index d4b7c194b..9ba034651 100644 --- a/src/primitives/float64.ml +++ b/src/primitives/float64.ml @@ -292,7 +292,7 @@ let of_signless_string s = if String.equal s "inf" then pos_inf else if String.equal s "nan" then pos_nan else if String.length s > 6 && String.equal (String.sub s 0 6) "nan:0x" then - let x = Int64.of_string (String.sub s 4 (String.length s - 4)) in + let x = Int64.of_string_exn (String.sub s 4 (String.length s - 4)) in if Int64.eq x Int64.zero then Fmt.failwith "nan payload must not be zero" else if Int64.ne (Int64.logand x bare_nan) Int64.zero then Fmt.failwith "nan payload must not overlap with exponent bits" @@ -304,14 +304,14 @@ let of_signless_string s = let x = of_float (float_of_string_prevent_double_rounding s') in if is_inf x then Log.err "of_string" else x -let of_string s = - if String.equal s "" then Log.err "of_string" +let of_string_exn s = + if String.equal s "" then Log.err "of_string_exn" else if Char.equal s.[0] '+' || Char.equal s.[0] '-' then let x = of_signless_string (String.sub s 1 (String.length s - 1)) in if Char.equal s.[0] '+' then x else neg x else of_signless_string s -let of_string_opt s = try Some (of_string s) with _ -> None +let of_string s = try Some (of_string_exn s) with _ -> None (* String conversion that groups digits for readability *) diff --git a/src/primitives/float64.mli b/src/primitives/float64.mli index 739f55589..6afa5a46f 100644 --- a/src/primitives/float64.mli +++ b/src/primitives/float64.mli @@ -60,9 +60,9 @@ val le : t -> t -> bool val ge : t -> t -> bool -val of_string : string -> t +val of_string_exn : string -> t -val of_string_opt : string -> t option +val of_string : string -> t option val to_hex_string : t -> string diff --git a/src/primitives/int32.ml b/src/primitives/int32.ml index 4636e2c9c..221e8a863 100644 --- a/src/primitives/int32.ml +++ b/src/primitives/int32.ml @@ -111,7 +111,7 @@ let sign_extend i = let sign_mask = shift_left minus_one 32 in logor sign_mask i -let of_string s = +let of_string_exn s = let len = String.length s in let rec parse_hex i num = if i = len then num @@ -149,4 +149,4 @@ let of_string s = require (le low_int parsed && le parsed high_int); parsed -let of_string_opt s = try Some (of_string s) with _ -> None +let of_string s = try Some (of_string_exn s) with _ -> None diff --git a/src/primitives/int32.mli b/src/primitives/int32.mli index a01bad37e..3aa714bac 100644 --- a/src/primitives/int32.mli +++ b/src/primitives/int32.mli @@ -22,9 +22,9 @@ val of_float : float -> t val to_float : t -> float -val of_string : string -> t +val of_string_exn : string -> t -val of_string_opt : string -> t option +val of_string : string -> t option val of_int : int -> t diff --git a/src/primitives/int64.ml b/src/primitives/int64.ml index 9ea3a1bc6..e380a036f 100644 --- a/src/primitives/int64.ml +++ b/src/primitives/int64.ml @@ -126,7 +126,7 @@ let hex_digit = function let max_upper, max_lower = divrem_u minus_one 10L -let of_string s = +let of_string_exn s = let len = String.length s in let rec parse_hex i num = if i = len then num @@ -163,4 +163,4 @@ let of_string s = require (le low_int parsed && le parsed high_int); parsed -let of_string_opt s = try Some (of_string s) with _ -> None +let of_string s = try Some (of_string_exn s) with _ -> None diff --git a/src/primitives/int64.mli b/src/primitives/int64.mli index d0512e7eb..5704695dd 100644 --- a/src/primitives/int64.mli +++ b/src/primitives/int64.mli @@ -22,9 +22,9 @@ val of_float : float -> t val to_float : t -> float -val of_string : string -> t +val of_string_exn : string -> t -val of_string_opt : string -> t option +val of_string : string -> t option val of_int : int -> t diff --git a/src/text_to_binary/rewrite.ml b/src/text_to_binary/rewrite.ml index 6b0634622..51c55a633 100644 --- a/src/text_to_binary/rewrite.ml +++ b/src/text_to_binary/rewrite.ml @@ -365,25 +365,26 @@ let rec rewrite_term (binder_list : string option list) ?(modul : Binary.modul = Binary.empty_modul) ?(func_param_list : string option list = []) : text Spec.term -> binary Spec.term Result.t = - let rec aux error acc id = function + let rec find_raw_indice error acc id = function | [] -> Error error | Some id' :: bl -> - if String.equal id id' then Ok (Raw acc) else aux error (acc + 1) id bl - | _ :: bl -> aux error (acc + 1) id bl + if String.equal id id' then Ok (Raw acc) + else find_raw_indice error (acc + 1) id bl + | None :: bl -> find_raw_indice error (acc + 1) id bl in let find_binder (binder_list : string option list) (ind : text indice) : binary indice Result.t = match ind with | Raw id -> Ok (Raw id) - | Text id -> aux (`Unknown_binder ind) 0 id binder_list + | Text id -> find_raw_indice (`Unknown_binder ind) 0 id binder_list in let find_param (func_param_list : string option list) (ind : text indice) : binary indice Result.t = match ind with | Raw id -> Ok (Raw id) - | Text id -> aux (`Unknown_param ind) 0 id func_param_list + | Text id -> find_raw_indice (`Unknown_param ind) 0 id func_param_list in let find_global (modul : Binary.modul) (ind : text indice) : diff --git a/test/conc/plus.wat b/test/conc/plus.wat deleted file mode 100644 index f8fd727ba..000000000 --- a/test/conc/plus.wat +++ /dev/null @@ -1,8 +0,0 @@ -(module - (@contract $plus_three - (ensures (= result (+ $x 3))) - ) - (func $plus_three - (param $x i32) (result i32) - (i32.add (i32.const 3) (local.get $x))) -) diff --git a/test/script/annotations.t b/test/script/annotations.t deleted file mode 100644 index 16105f883..000000000 --- a/test/script/annotations.t +++ /dev/null @@ -1 +0,0 @@ - $ owi script --no-exhaustion reference/proposals/annotations/annotations.wast diff --git a/test/script/reference.t b/test/script/reference.t index 2c13f126e..781f92854 100644 --- a/test/script/reference.t +++ b/test/script/reference.t @@ -112,3 +112,4 @@ $ owi script --no-exhaustion reference/utf8-import-field.wast $ owi script --no-exhaustion reference/utf8-import-module.wast $ owi script --no-exhaustion reference/utf8-invalid-encoding.wast + $ owi script --no-exhaustion reference/proposals/annotations/annotations.wast diff --git a/test/script/reference_opt.t b/test/script/reference_opt.t index cfd9d4623..e3b73e373 100644 --- a/test/script/reference_opt.t +++ b/test/script/reference_opt.t @@ -112,3 +112,4 @@ $ owi script --no-exhaustion --optimize reference/utf8-import-field.wast $ owi script --no-exhaustion --optimize reference/utf8-import-module.wast $ owi script --no-exhaustion --optimize reference/utf8-invalid-encoding.wast + $ owi script --no-exhaustion --optimize reference/proposals/annotations/annotations.wast From 8b79776d58e6a59521c375131aecc9f2a121d7e3 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Tue, 13 Aug 2024 15:31:23 +0200 Subject: [PATCH 27/51] replace optional arguments with labeled arguments in rewrite.ml --- src/text_to_binary/rewrite.ml | 39 ++++++++++++++++++----------------- 1 file changed, 20 insertions(+), 19 deletions(-) diff --git a/src/text_to_binary/rewrite.ml b/src/text_to_binary/rewrite.ml index 51c55a633..7aa7ed500 100644 --- a/src/text_to_binary/rewrite.ml +++ b/src/text_to_binary/rewrite.ml @@ -361,9 +361,8 @@ let rewrite_types (_modul : Assigned.t) (t : binary str_type) : let t = [ (None, (Final, [], t)) ] in Ok t -let rec rewrite_term (binder_list : string option list) - ?(modul : Binary.modul = Binary.empty_modul) - ?(func_param_list : string option list = []) : +let rec rewrite_term ~(binder_list : string option list) ~(modul : Binary.modul) + ~(func_param_list : string option list) : text Spec.term -> binary Spec.term Result.t = let rec find_raw_indice error acc id = function | [] -> Error error @@ -423,36 +422,34 @@ let rec rewrite_term (binder_list : string option list) let+ ind = find_binder binder_list ind in BinderVar ind | UnOp (u, tm1) -> - let+ tm1 = rewrite_term binder_list ~modul ~func_param_list tm1 in + let+ tm1 = rewrite_term ~binder_list ~modul ~func_param_list tm1 in UnOp (u, tm1) | BinOp (b, tm1, tm2) -> - let* tm1 = rewrite_term binder_list ~modul ~func_param_list tm1 in - let+ tm2 = rewrite_term binder_list ~modul ~func_param_list tm2 in + let* tm1 = rewrite_term ~binder_list ~modul ~func_param_list tm1 in + let+ tm2 = rewrite_term ~binder_list ~modul ~func_param_list tm2 in BinOp (b, tm1, tm2) | Result -> Ok Result -let rec rewrite_prop (binder_list : string option list) - ?(modul : Binary.modul = Binary.empty_modul) - ?(func_param_list : string option list = []) : +let rec rewrite_prop ~(binder_list : string option list) ~(modul : Binary.modul) + ~(func_param_list : string option list) : text Spec.prop -> binary Spec.prop Result.t = let open Spec in function | Const b -> Ok (Const b) | BinPred (b, tm1, tm2) -> - let* tm1 = rewrite_term binder_list ~modul ~func_param_list tm1 in - let+ tm2 = rewrite_term binder_list ~modul ~func_param_list tm2 in + let* tm1 = rewrite_term ~binder_list ~modul ~func_param_list tm1 in + let+ tm2 = rewrite_term ~binder_list ~modul ~func_param_list tm2 in BinPred (b, tm1, tm2) | UnConnect (u, pr1) -> - let+ pr1 = rewrite_prop binder_list ~modul ~func_param_list pr1 in + let+ pr1 = rewrite_prop ~binder_list ~modul ~func_param_list pr1 in UnConnect (u, pr1) | BinConnect (b, pr1, pr2) -> - let* pr1 = rewrite_prop binder_list ~modul ~func_param_list pr1 in - let+ pr2 = rewrite_prop binder_list ~modul ~func_param_list pr2 in + let* pr1 = rewrite_prop ~binder_list ~modul ~func_param_list pr1 in + let+ pr2 = rewrite_prop ~binder_list ~modul ~func_param_list pr2 in BinConnect (b, pr1, pr2) | Binder (b, bt, id_opt, pr1) -> - let+ pr1 = - rewrite_prop (id_opt :: binder_list) ~modul ~func_param_list pr1 - in + let binder_list = id_opt :: binder_list in + let+ pr1 = rewrite_prop ~binder_list ~modul ~func_param_list pr1 in Binder (b, bt, id_opt, pr1) let rewrite_contract (modul : Binary.modul) : @@ -469,10 +466,14 @@ let rewrite_contract (modul : Binary.modul) : List.map fst params in let* preconditions = - list_map (rewrite_prop [] ~modul ~func_param_list) preconditions + list_map + (rewrite_prop ~binder_list:[] ~modul ~func_param_list) + preconditions in let+ postconditions = - list_map (rewrite_prop [] ~modul ~func_param_list) postconditions + list_map + (rewrite_prop ~binder_list:[] ~modul ~func_param_list) + postconditions in { Contract.funcid; preconditions; postconditions } From ea5d14f1537599d6df431f8e5859233e8b695c72 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Tue, 13 Aug 2024 15:40:16 +0200 Subject: [PATCH 28/51] allow nicer symbols to be parsed --- src/annot/spec.ml | 24 ++++++++++++------------ src/parser/text_parser.mly | 2 +- 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/annot/spec.ml b/src/annot/spec.ml index 78dd50966..870b142f3 100644 --- a/src/annot/spec.ml +++ b/src/annot/spec.ml @@ -307,7 +307,7 @@ let rec parse_prop = | Atom "true" -> ok @@ Const true | Atom "false" -> ok @@ Const false (* BinPred *) - | List [ Atom ">="; tm1; tm2 ] -> + | List [ Atom (">=" | "≥"); tm1; tm2 ] -> let* tm1 = parse_term tm1 in let+ tm2 = parse_term tm2 in BinPred (Ge, tm1, tm2) @@ -315,7 +315,7 @@ let rec parse_prop = let* tm1 = parse_term tm1 in let+ tm2 = parse_term tm2 in BinPred (Gt, tm1, tm2) - | List [ Atom "<="; tm1; tm2 ] -> + | List [ Atom ("<=" | "≤"); tm1; tm2 ] -> let* tm1 = parse_term tm1 in let+ tm2 = parse_term tm2 in BinPred (Le, tm1, tm2) @@ -327,46 +327,46 @@ let rec parse_prop = let* tm1 = parse_term tm1 in let+ tm2 = parse_term tm2 in BinPred (Eq, tm1, tm2) - | List [ Atom "!="; tm1; tm2 ] -> + | List [ Atom ("!=" | "≠"); tm1; tm2 ] -> let* tm1 = parse_term tm1 in let+ tm2 = parse_term tm2 in BinPred (Neq, tm1, tm2) (* UnConnect *) - | List [ Atom "!"; pr1 ] -> + | List [ Atom ("!" | "¬"); pr1 ] -> let+ pr1 = parse_prop pr1 in UnConnect (Not, pr1) (* BinConnect *) - | List [ Atom "&&"; pr1; pr2 ] -> + | List [ Atom ("&&" | "∧"); pr1; pr2 ] -> let* pr1 = parse_prop pr1 in let+ pr2 = parse_prop pr2 in BinConnect (And, pr1, pr2) - | List [ Atom "||"; pr1; pr2 ] -> + | List [ Atom ("||" | "∨"); pr1; pr2 ] -> let* pr1 = parse_prop pr1 in let+ pr2 = parse_prop pr2 in BinConnect (Or, pr1, pr2) - | List [ Atom "==>"; pr1; pr2 ] -> + | List [ Atom ("==>" | "⇒"); pr1; pr2 ] -> let* pr1 = parse_prop pr1 in let+ pr2 = parse_prop pr2 in BinConnect (Imply, pr1, pr2) - | List [ Atom "<==>"; pr1; pr2 ] -> + | List [ Atom ("<==>" | "⇔"); pr1; pr2 ] -> let* pr1 = parse_prop pr1 in let+ pr2 = parse_prop pr2 in BinConnect (Equiv, pr1, pr2) (* Binder *) - | List [ Atom "forall"; bt; pr1 ] -> + | List [ Atom ("forall" | "∀"); bt; pr1 ] -> let* bt = parse_binder_type bt in let+ pr1 = parse_prop pr1 in Binder (Forall, bt, None, pr1) - | List [ Atom "forall"; bt; Atom ind; pr1 ] -> + | List [ Atom ("forall" | "∀"); bt; Atom ind; pr1 ] -> let* bt = parse_binder_type bt in let* ind = parse_text_id_result ind in let+ pr1 = parse_prop pr1 in Binder (Forall, bt, Some ind, pr1) - | List [ Atom "exists"; bt; pr1 ] -> + | List [ Atom ("exists" | "∃"); bt; pr1 ] -> let* bt = parse_binder_type bt in let+ pr1 = parse_prop pr1 in Binder (Exists, bt, None, pr1) - | List [ Atom "exists"; bt; Atom ind; pr1 ] -> + | List [ Atom ("exists" | "∃"); bt; Atom ind; pr1 ] -> let* bt = parse_binder_type bt in let* ind = parse_text_id_result ind in let+ pr1 = parse_prop pr1 in diff --git a/src/parser/text_parser.mly b/src/parser/text_parser.mly index d0d15487d..d100600ea 100644 --- a/src/parser/text_parser.mly +++ b/src/parser/text_parser.mly @@ -1008,7 +1008,7 @@ let inline_module_inner == | Ok annots -> annots | _ -> [] in - let () = Fmt.(pr "%a\n" (list pp_annot) annots) in + let () = Fmt.(pr "%a" (list pp_annot) annots) in { id; fields; annots } } From 86328903f1444662e9f82714fabfe3d5a14ef0f8 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Tue, 13 Aug 2024 23:18:22 +0200 Subject: [PATCH 29/51] deal with error when merging --- src/text_to_binary/rewrite.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/text_to_binary/rewrite.ml b/src/text_to_binary/rewrite.ml index 7aa7ed500..8b911fc67 100644 --- a/src/text_to_binary/rewrite.ml +++ b/src/text_to_binary/rewrite.ml @@ -511,10 +511,10 @@ let modul (modul : Assigned.t) : Binary.modul Result.t = let* types = rewrite_named (rewrite_types modul) modul.typ in let* start = match modul.start with - | None -> None + | None -> Ok None | Some id -> let (Raw id) = find func id in - Some id + Ok (Some id) in let id = modul.id in From 574dc993aa1447a0fbffaaf2ec2764953c78e89d Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Wed, 14 Aug 2024 00:34:42 +0200 Subject: [PATCH 30/51] add cmdline option for code generation --- src/annot/annot.ml | 17 ++++++++++------- src/annot/annot.mli | 7 +++---- src/bin/owi.ml | 12 ++++++++---- src/cmd/cmd_c.ml | 2 +- src/cmd/cmd_conc.ml | 3 ++- src/cmd/cmd_conc.mli | 1 + src/cmd/cmd_sym.ml | 3 ++- src/cmd/cmd_sym.mli | 1 + src/parser/text_lexer.ml | 4 ++-- src/parser/text_parser.mly | 22 +++++++++++----------- 10 files changed, 41 insertions(+), 31 deletions(-) diff --git a/src/annot/annot.ml b/src/annot/annot.ml index 645ba793b..67507ffcc 100644 --- a/src/annot/annot.ml +++ b/src/annot/annot.ml @@ -1,5 +1,4 @@ open Fmt -open Types type t = { annotid : string @@ -18,11 +17,15 @@ let pp_annot fmt = function pf fmt "(@%a@\n @[%a@]@\n)" string annot.annotid Sexp.pp_sexp annot.items -let annot_recorder : (string, text annot) Hashtbl.t = Hashtbl.create 17 +let annot_recorder : (string, Sexp.t) Hashtbl.t = Hashtbl.create 17 -let record_annot annotid annot = Hashtbl.add annot_recorder annotid annot +let record_annot annotid sexp = Hashtbl.add annot_recorder annotid sexp -let get_annots ?name () = - match name with - | Some name -> Hashtbl.find_all annot_recorder name - | None -> Hashtbl.fold (fun _ annot acc -> annot :: acc) annot_recorder [] +let get_annots () = + let res = + Hashtbl.fold + (fun annotid items acc -> { annotid; items } :: acc) + annot_recorder [] + in + Hashtbl.reset annot_recorder; + res diff --git a/src/annot/annot.mli b/src/annot/annot.mli index f6d878cf6..364d9884a 100644 --- a/src/annot/annot.mli +++ b/src/annot/annot.mli @@ -1,5 +1,4 @@ open Fmt -open Types type t = { annotid : string @@ -10,8 +9,8 @@ type 'a annot = | Contract of 'a Contract.t | Annot of t -val pp_annot : formatter -> text annot -> unit +val pp_annot : formatter -> 'a annot -> unit -val record_annot : string -> text annot -> unit +val record_annot : string -> Sexp.t -> unit -val get_annots : ?name:string -> unit -> text annot list +val get_annots : unit -> t list diff --git a/src/bin/owi.ml b/src/bin/owi.ml index 8388404a9..2928be11b 100644 --- a/src/bin/owi.ml +++ b/src/bin/owi.ml @@ -122,6 +122,10 @@ let workspace = Cmdliner.Arg.( value & opt dir_file (Fpath.v "owi-out") & info [ "workspace" ] ~doc ) +let spec = + let doc = "WEbAssembly Specification Language" in + Cmdliner.Arg.(value & flag & info [ "spec" ] ~doc) + let copts_t = Cmdliner.Term.(const []) let sdocs = Cmdliner.Manpage.s_common_options @@ -239,8 +243,8 @@ let sym_cmd = Cmd.v info Term.( const Cmd_sym.cmd $ profiling $ debug $ unsafe $ optimize $ workers - $ no_stop_at_failure $ no_values $ deterministic_result_order $ fail_mode - $ workspace $ solver $ files ) + $ no_stop_at_failure $ no_values $ deterministic_result_order $ spec + $ fail_mode $ workspace $ solver $ files ) let conc_cmd = let open Cmdliner in @@ -252,8 +256,8 @@ let conc_cmd = Cmd.v info Term.( const Cmd_conc.cmd $ profiling $ debug $ unsafe $ optimize $ workers - $ no_stop_at_failure $ no_values $ deterministic_result_order $ fail_mode - $ workspace $ solver $ files ) + $ no_stop_at_failure $ no_values $ deterministic_result_order $ spec + $ fail_mode $ workspace $ solver $ files ) let wasm2wat_cmd = let open Cmdliner in diff --git a/src/cmd/cmd_c.ml b/src/cmd/cmd_c.ml index e719a3dc4..8fa8de721 100644 --- a/src/cmd/cmd_c.ml +++ b/src/cmd/cmd_c.ml @@ -196,4 +196,4 @@ let cmd debug arch property _testcomp workspace workers opt_lvl includes files let files = [ modul ] in (if concolic then Cmd_conc.cmd else Cmd_sym.cmd) profiling debug unsafe optimize workers no_stop_at_failure no_values - deterministic_result_order fail_mode workspace solver files + deterministic_result_order false fail_mode workspace solver files diff --git a/src/cmd/cmd_conc.ml b/src/cmd/cmd_conc.ml index 5a8d5dca1..365919cc7 100644 --- a/src/cmd/cmd_conc.ml +++ b/src/cmd/cmd_conc.ml @@ -415,7 +415,8 @@ let run solver tree link_state modules_to_run = which are handled here. Most of the computations are done in the Result monad, hence the let*. *) let cmd profiling debug unsafe optimize _workers _no_stop_at_failure no_values - _deterministic_result_order _fail_mode (workspace : Fpath.t) solver files = + _deterministic_result_order _spec _fail_mode (workspace : Fpath.t) solver + files = if profiling then Log.profiling_on := true; if debug then Log.debug_on := true; (* deterministic_result_order implies no_stop_at_failure *) diff --git a/src/cmd/cmd_conc.mli b/src/cmd/cmd_conc.mli index 5d841000a..d80f29826 100644 --- a/src/cmd/cmd_conc.mli +++ b/src/cmd/cmd_conc.mli @@ -11,6 +11,7 @@ val cmd : -> bool -> bool -> bool + -> bool -> Cmd_sym.fail_mode -> Fpath.t -> Smtml.Solver_dispatcher.solver_type diff --git a/src/cmd/cmd_sym.ml b/src/cmd/cmd_sym.ml index b53eeb9c8..8960b2840 100644 --- a/src/cmd/cmd_sym.ml +++ b/src/cmd/cmd_sym.ml @@ -47,7 +47,8 @@ let run_file ~unsafe ~optimize pc filename = which are handled here. Most of the computations are done in the Result monad, hence the let*. *) let cmd profiling debug unsafe optimize workers no_stop_at_failure no_values - deterministic_result_order fail_mode (workspace : Fpath.t) solver files = + deterministic_result_order _spec fail_mode (workspace : Fpath.t) solver files + = if profiling then Log.profiling_on := true; if debug then Log.debug_on := true; (* deterministic_result_order implies no_stop_at_failure *) diff --git a/src/cmd/cmd_sym.mli b/src/cmd/cmd_sym.mli index 938f1e343..abd26544f 100644 --- a/src/cmd/cmd_sym.mli +++ b/src/cmd/cmd_sym.mli @@ -17,6 +17,7 @@ val cmd : -> bool -> bool -> bool + -> bool -> fail_mode -> Fpath.t -> Smtml.Solver_dispatcher.solver_type diff --git a/src/parser/text_lexer.ml b/src/parser/text_lexer.ml index 9fdcfdb4f..ba009afdf 100644 --- a/src/parser/text_lexer.ml +++ b/src/parser/text_lexer.ml @@ -452,14 +452,14 @@ let rec token buf = if String.equal "" annotid then Log.err "empty annotation id" else let items = Sexp.List (annot buf) in - Annot.(record_annot annotid (Annot { annotid; items })); + Annot.(record_annot annotid items); token buf | "(@", Plus id_char -> let annotid = Utf8.lexeme buf in let annotid = String.sub annotid 2 (String.length annotid - 2) in let annotid = mk_string buf annotid in let items = Sexp.List (annot buf) in - Annot.(record_annot annotid (Annot { annotid; items })); + Annot.(record_annot annotid items); token buf | "(@" -> Log.err "empty annotation id" (* 1 *) diff --git a/src/parser/text_parser.mly b/src/parser/text_parser.mly index d100600ea..5fb0e8001 100644 --- a/src/parser/text_parser.mly +++ b/src/parser/text_parser.mly @@ -995,20 +995,20 @@ let inline_module_inner == let open Annot in let open Contract in let open Syntax in - let annots = get_annots () in let annots = - match (list_map - (fun t -> - match t with - | Annot t -> - let+ c = parse_contract t.items in - Contract c - | _ -> Error (`Invalid_indice "")) - annots) with + match + list_map + (fun ({ annotid; items } as t) -> + if String.equal "contract" annotid then + let+ c = parse_contract items in + Log.debug2 "%a\n" pp_contract c; + Contract c + else Ok (Annot t) ) + (get_annots ()) + with | Ok annots -> annots - | _ -> [] + | Error err -> failwith (Result.err_to_string err) in - let () = Fmt.(pr "%a" (list pp_annot) annots) in { id; fields; annots } } From fb31c05faf2e6372aca7f4b0a6d5515ff4e4856c Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Thu, 15 Aug 2024 11:34:34 +0200 Subject: [PATCH 31/51] add owi header --- src/annot/annot.ml | 4 ++++ src/annot/annot.mli | 4 ++++ src/annot/contract.ml | 4 ++++ src/annot/contract.mli | 4 ++++ src/annot/spec.ml | 4 ++++ src/annot/spec.mli | 4 ++++ 6 files changed, 24 insertions(+) diff --git a/src/annot/annot.ml b/src/annot/annot.ml index 67507ffcc..25444305e 100644 --- a/src/annot/annot.ml +++ b/src/annot/annot.ml @@ -1,3 +1,7 @@ +(* SPDX-License-Identifier: AGPL-3.0-or-later *) +(* Copyright © 2021-2024 OCamlPro *) +(* Written by the Owi programmers *) + open Fmt type t = diff --git a/src/annot/annot.mli b/src/annot/annot.mli index 364d9884a..eab5e606a 100644 --- a/src/annot/annot.mli +++ b/src/annot/annot.mli @@ -1,3 +1,7 @@ +(* SPDX-License-Identifier: AGPL-3.0-or-later *) +(* Copyright © 2021-2024 OCamlPro *) +(* Written by the Owi programmers *) + open Fmt type t = diff --git a/src/annot/contract.ml b/src/annot/contract.ml index 39fe06644..2cc0da56a 100644 --- a/src/annot/contract.ml +++ b/src/annot/contract.ml @@ -1,3 +1,7 @@ +(* SPDX-License-Identifier: AGPL-3.0-or-later *) +(* Copyright © 2021-2024 OCamlPro *) +(* Written by the Owi programmers *) + open Types open Fmt open Spec diff --git a/src/annot/contract.mli b/src/annot/contract.mli index 38e85911e..cd55c5acb 100644 --- a/src/annot/contract.mli +++ b/src/annot/contract.mli @@ -1,3 +1,7 @@ +(* SPDX-License-Identifier: AGPL-3.0-or-later *) +(* Copyright © 2021-2024 OCamlPro *) +(* Written by the Owi programmers *) + open Fmt open Types open Spec diff --git a/src/annot/spec.ml b/src/annot/spec.ml index 870b142f3..947a653f0 100644 --- a/src/annot/spec.ml +++ b/src/annot/spec.ml @@ -1,3 +1,7 @@ +(* SPDX-License-Identifier: AGPL-3.0-or-later *) +(* Copyright © 2021-2024 OCamlPro *) +(* Written by the Owi programmers *) + open Types open Fmt open Syntax diff --git a/src/annot/spec.mli b/src/annot/spec.mli index d7c1078a8..a0fc1a0e0 100644 --- a/src/annot/spec.mli +++ b/src/annot/spec.mli @@ -1,3 +1,7 @@ +(* SPDX-License-Identifier: AGPL-3.0-or-later *) +(* Copyright © 2021-2024 OCamlPro *) +(* Written by the Owi programmers *) + open Types open Fmt From 3b19c74de337d225a7f044a330de590ce868a71e Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Mon, 19 Aug 2024 01:30:04 +0200 Subject: [PATCH 32/51] framework for rac code generation --- src/annot/contract.ml | 8 + src/annot/contract.mli | 4 + src/annot/spec.ml | 45 +-- src/annot/spec.mli | 8 +- src/ast/binary_encoder.mli | 1 + src/ast/code_generator.ml | 585 ++++++++++++++++++++++++++++++++ src/ast/code_generator.mli | 5 + src/ast/compile.ml | 88 +++-- src/ast/compile.mli | 48 ++- src/ast/types.ml | 17 +- src/bin/owi.ml | 42 +-- src/cmd/cmd_conc.ml | 19 +- src/cmd/cmd_opt.ml | 4 +- src/cmd/cmd_run.ml | 8 +- src/cmd/cmd_run.mli | 2 +- src/cmd/cmd_script.ml | 4 +- src/cmd/cmd_script.mli | 2 +- src/cmd/cmd_sym.ml | 8 +- src/cmd/cmd_validate.ml | 10 +- src/cmd/cmd_validate.mli | 2 +- src/data_structures/indexed.ml | 4 + src/data_structures/indexed.mli | 2 + src/dune | 1 + src/script/script.ml | 24 +- src/script/script.mli | 7 +- src/text_to_binary/rewrite.ml | 18 +- src/utils/result.ml | 60 ++-- src/utils/result.mli | 27 +- src/utils/syntax.ml | 14 + src/utils/syntax.mli | 5 + 30 files changed, 916 insertions(+), 156 deletions(-) create mode 100644 src/ast/code_generator.ml create mode 100644 src/ast/code_generator.mli diff --git a/src/annot/contract.ml b/src/annot/contract.ml index 2cc0da56a..4c69d2ddd 100644 --- a/src/annot/contract.ml +++ b/src/annot/contract.ml @@ -13,6 +13,14 @@ type 'a t = ; postconditions : 'a prop list } +let compare_funcid c1 c2 = compare_indice c1.funcid c2.funcid + +let join_contract { preconditions = pre1; postconditions = post1; funcid } + { preconditions = pre2; postconditions = post2; _ } = + let preconditions = pre1 @ pre2 in + let postconditions = post1 @ post2 in + { funcid; preconditions; postconditions } + let pp_contract fmt { funcid; preconditions; postconditions } = pf fmt "@[Contract of function %a@,\ diff --git a/src/annot/contract.mli b/src/annot/contract.mli index cd55c5acb..2cce4e16a 100644 --- a/src/annot/contract.mli +++ b/src/annot/contract.mli @@ -12,6 +12,10 @@ type 'a t = ; postconditions : 'a prop list } +val compare_funcid : 'a t -> 'a t -> int + +val join_contract : 'a t -> 'a t -> 'a t + val pp_contract : formatter -> 'a t -> unit val parse_contract : Sexp.t -> text t Result.t diff --git a/src/annot/spec.ml b/src/annot/spec.ml index 947a653f0..ee299956a 100644 --- a/src/annot/spec.ml +++ b/src/annot/spec.ml @@ -18,17 +18,18 @@ binop ::= '+' ==> Plus term ::= '(' pterm ')' ==> pterm | i32 ==> match Int32.of_string i32 with Some i32 -> Int32 i32 | ind ==> match parse_text_id ind with Some ind -> Var (Text ind) - | result ==> Result + | 'result' ==> Result None -pterm ::= 'i32' i32 ==> match Int32.of_string i32 with Some i32 -> Int32 i32 | None -> `Invalid_int32 i32 - | 'i64' i64 ==> match Int64.of_string i64 with Some i64 -> Int64 i64 | None -> `Invalid_int64 i64 - | 'f32' f32 ==> match Float32.of_string f32 with Some f32 -> Float32 f32 | None -> `Invalid_float32 f32 - | 'f64' f64 ==> match Float64.of_string f64 with Some f64 -> Float64 f64 | None -> `Invalid_float64 f64 +pterm ::= 'i32' i32 ==> match Int32.of_string i32 with Some i32 -> Int32 i32 | None -> `Spec_invalid_int32 i32 + | 'i64' i64 ==> match Int64.of_string i64 with Some i64 -> Int64 i64 | None -> `Spec_invalid_int64 i64 + | 'f32' f32 ==> match Float32.of_string f32 with Some f32 -> Float32 f32 | None -> `Spec_invalid_float32 f32 + | 'f64' f64 ==> match Float64.of_string f64 with Some f64 -> Float64 f64 | None -> `Spec_invalid_float64 f64 | 'param' ind ==> let* ind = parse_indice ind in ParamVar ind | 'global' ind ==> let* ind = parse_indice ind in GlobalVar ind | 'binder' ind ==> let* ind = parse_indice ind in BinderVar ind | unop term_1 ==> Unop (unop, term_1) | binop term_1 term_2 ==> BinOp (binop, term_1, term_2) + | 'result' i ==> Result (Some i) binpred ::= '>=' ==> Ge | '>' ==> Gt @@ -109,7 +110,7 @@ type 'a term = | BinderVar : 'a indice -> 'a term | UnOp : unop * 'a term -> 'a term | BinOp : binop * 'a term * 'a term -> 'a term - | Result : 'a term + | Result : int option -> 'a term type 'a prop = | Const : bool -> 'a prop @@ -162,7 +163,8 @@ let rec pp_term : type a. formatter -> a term -> unit = | UnOp (u, tm1) -> pf fmt "@[(%a@ %a)@]" pp_unop u pp_term tm1 | BinOp (b, tm1, tm2) -> pf fmt "@[(%a@ %a@ %a)@]" pp_binop b pp_term tm1 pp_term tm2 - | Result -> pf fmt "result" + | Result (Some i) -> pf fmt "(result %i)" i + | Result None -> pf fmt "result" let rec pp_prop : type a. formatter -> a prop -> unit = fun fmt -> function @@ -205,8 +207,8 @@ let parse_text_id_result id = let hd = String.get id 0 in let tl = String.sub id 1 (len - 1) in if Char.equal hd '$' && String.for_all valid_text_indice_char id then Ok tl - else Error (`Invalid_text_indice id) - else Error (`Invalid_text_indice id) + else Error (`Spec_invalid_text_indice id) + else Error (`Spec_invalid_text_indice id) let parse_raw_id id = int_of_string id @@ -214,7 +216,7 @@ let parse_indice id = match (parse_text_id id, parse_raw_id id) with | Some id, _ -> Ok (Text id) | _, Some id -> Ok (Raw id) - | _, _ -> Error (`Invalid_indice id) + | _, _ -> Error (`Spec_invalid_indice id) let parse_binder_type = let open Sexp in @@ -223,7 +225,7 @@ let parse_binder_type = | Atom "i64" -> Ok I64 | Atom "f32" -> Ok F32 | Atom "f64" -> Ok F64 - | bt -> Error (`Unknown_binder_type bt) + | bt -> Error (`Spec_unknown_binder_type bt) let rec parse_term = let open Sexp in @@ -238,29 +240,34 @@ let rec parse_term = | Some ind -> Ok (Var (Text ind)) | None -> (* Result *) - if String.equal "result" a then Ok Result (* Invalid *) - else Error (`Unknown_term tm) ) + if String.equal "result" a then Ok (Result None) (* Invalid *) + else Error (`Spec_unknown_term tm) ) end + (* Result *) + | List [ Atom "result"; Atom i ] -> ( + match int_of_string i with + | Some i -> Ok (Result (Some i)) + | None -> Error (`Spec_invalid_int32 i) ) (* Int32 *) | List [ Atom "i32"; Atom i32 ] -> ( match Int32.of_string i32 with | Some i32 -> ok @@ Int32 i32 - | None -> Error (`Invalid_int32 i32) ) + | None -> Error (`Spec_invalid_int32 i32) ) (* Int64 *) | List [ Atom "i64"; Atom i64 ] -> ( match Int64.of_string i64 with | Some i64 -> ok @@ Int64 i64 - | None -> Error (`Invalid_int64 i64) ) + | None -> Error (`Spec_invalid_int64 i64) ) (* Float32 *) | List [ Atom "f32"; Atom f32 ] -> ( match Float32.of_string f32 with | Some f32 -> ok @@ Float32 f32 - | None -> Error (`Invalid_float32 f32) ) + | None -> Error (`Spec_invalid_float32 f32) ) (* Float64 *) | List [ Atom "f64"; Atom f64 ] -> ( match Float64.of_string f64 with | Some f64 -> ok @@ Float64 f64 - | None -> Error (`Invalid_float64 f64) ) + | None -> Error (`Spec_invalid_float64 f64) ) (* ParamVar *) | List [ Atom "param"; Atom ind ] -> let+ ind = parse_indice ind in @@ -302,7 +309,7 @@ let rec parse_term = let+ tm2 = parse_term tm2 in BinOp (CustomBinOp c, tm1, tm2) (* Invalid *) - | tm -> Error (`Unknown_term tm) + | tm -> Error (`Spec_unknown_term tm) let rec parse_prop = let open Sexp in @@ -376,4 +383,4 @@ let rec parse_prop = let+ pr1 = parse_prop pr1 in Binder (Exists, bt, Some ind, pr1) (* invalid *) - | _ as pr -> Error (`Unknown_prop pr) + | _ as pr -> Error (`Spec_unknown_prop pr) diff --git a/src/annot/spec.mli b/src/annot/spec.mli index a0fc1a0e0..0cac60a82 100644 --- a/src/annot/spec.mli +++ b/src/annot/spec.mli @@ -49,7 +49,7 @@ type 'a term = | BinderVar : 'a indice -> 'a term | UnOp : unop * 'a term -> 'a term | BinOp : binop * 'a term * 'a term -> 'a term - | Result : 'a term + | Result : int option -> 'a term type 'a prop = | Const : bool -> 'a prop @@ -68,10 +68,14 @@ val pp_binder : formatter -> binder -> unit val pp_binder_type : formatter -> binder_type -> unit -val pp_prop : formatter -> 'a prop -> unit +val pp_unop : formatter -> unop -> unit + +val pp_binop : formatter -> binop -> unit val pp_term : formatter -> 'a term -> unit +val pp_prop : formatter -> 'a prop -> unit + val parse_indice : string -> text indice Result.t val parse_prop : Sexp.t -> text prop Result.t diff --git a/src/ast/binary_encoder.mli b/src/ast/binary_encoder.mli index 494008907..1c3b68471 100644 --- a/src/ast/binary_encoder.mli +++ b/src/ast/binary_encoder.mli @@ -6,6 +6,7 @@ val convert : Fpath.t option -> Fpath.t -> unsafe:bool + -> rac:bool -> optimize:bool -> Text.modul -> (unit, Result.err) result diff --git a/src/ast/code_generator.ml b/src/ast/code_generator.ml new file mode 100644 index 000000000..5dc5e34c5 --- /dev/null +++ b/src/ast/code_generator.ml @@ -0,0 +1,585 @@ +(* SPDX-License-Identifier: AGPL-3.0-or-later *) +(* Copyright © 2021-2024 OCamlPro *) +(* Written by the Owi programmers *) + +open Types +open Binary +open Spec +open Syntax + +let type_env (m : modul) (func_ty : binary param_type * binary result_type) + (owi_funcs : (string * int) list) = + object + val param_types : binary val_type list = List.map snd (fst func_ty) + + val global_types : binary val_type list = + let sorted_global_types = + List.sort + (fun x y -> compare (Indexed.get_index x) (Indexed.get_index y)) + m.global.values + in + List.map + (fun (x : (global, binary global_type) Runtime.t Indexed.t) -> + match Indexed.get x with + | Runtime.Local { typ = _, gt; _ } -> gt + | Runtime.Imported { desc = _, gt; _ } -> gt ) + sorted_global_types + + val result_types : binary val_type list = snd func_ty + + val param_number : int = List.length (fst func_ty) + + val result_number : int = List.length (snd func_ty) + + val owi_i32 : int = List.assoc "i32_symbol" owi_funcs + + val owi_i64 : int = List.assoc "i64_symbol" owi_funcs + + val owi_f32 : int = List.assoc "f32_symbol" owi_funcs + + val owi_f64 : int = List.assoc "f64_symbol" owi_funcs + + val owi_assume : int = List.assoc "assume" owi_funcs + + val owi_assert : int = List.assoc "assert" owi_funcs + + method get_param_type (Raw i : binary indice) : binary val_type option = + List.nth_opt param_types i + + method get_global_type (Raw i : binary indice) : binary val_type option = + List.nth_opt global_types i + + method get_result_type (i : int) : binary val_type option = + List.nth_opt result_types i + + method get_param_number : int = param_number + + method get_result_number : int = result_number + + method get_result_types : binary val_type list = result_types + + method get_owi_i32 : int = owi_i32 + + method get_owi_i64 : int = owi_i64 + + method get_owi_f32 : int = owi_f32 + + method get_owi_f64 : int = owi_f64 + + method get_owi_assume : int = owi_assume + + method get_owi_assert : int = owi_assert + end + +let prop_true = I32_const (Int32.of_int 1) + +let prop_false = I32_const (Int32.of_int 0) + +let unop_generate (u : unop) (expr1 : binary expr) (ty1 : binary val_type) : + (binary expr * binary val_type) Result.t = + match u with + | Neg -> ( + match ty1 with + | Num_type I32 -> + let expr = + (I32_const (Int32.of_int 0) :: expr1) @ [ I_binop (S32, Sub) ] + in + Ok (expr, Num_type I32) + | Num_type I64 -> + let expr = + (I64_const (Int64.of_int 0) :: expr1) @ [ I_binop (S64, Sub) ] + in + Ok (expr, Num_type I64) + | Num_type F32 -> + let expr = + (F32_const (Float32.of_float 0.) :: expr1) @ [ F_binop (S32, Sub) ] + in + Ok (expr, Num_type F32) + | Num_type F64 -> + let expr = + (F64_const (Float64.of_float 0.) :: expr1) @ [ F_binop (S64, Sub) ] + in + Ok (expr, Num_type F64) + | Ref_type _ -> Error (`Spec_type_error Fmt.(str "%a" pp_unop u)) ) + | CustomUnOp _ -> Error (`Spec_type_error Fmt.(str "%a" pp_unop u)) + +let binop_generate (b : binop) (expr1 : binary expr) (ty1 : binary val_type) + (expr2 : binary expr) (ty2 : binary val_type) : + (binary expr * binary val_type) Result.t = + match b with + | Plus -> ( + match (ty1, ty2) with + | Num_type I32, Num_type I32 -> + let expr = expr1 @ expr2 @ [ I_binop (S32, Add) ] in + Ok (expr, Num_type I32) + | Num_type I64, Num_type I64 -> + let expr = expr1 @ expr2 @ [ I_binop (S64, Add) ] in + Ok (expr, Num_type I64) + | Num_type F32, Num_type F32 -> + let expr = expr1 @ expr2 @ [ F_binop (S32, Add) ] in + Ok (expr, Num_type F32) + | Num_type F64, Num_type F64 -> + let expr = expr1 @ expr2 @ [ F_binop (S64, Add) ] in + Ok (expr, Num_type F64) + | _, _ -> Error (`Spec_type_error Fmt.(str "%a" pp_binop b)) ) + | Minus -> ( + match (ty1, ty2) with + | Num_type I32, Num_type I32 -> + let expr = expr1 @ expr2 @ [ I_binop (S32, Sub) ] in + Ok (expr, Num_type I32) + | Num_type I64, Num_type I64 -> + let expr = expr1 @ expr2 @ [ I_binop (S64, Sub) ] in + Ok (expr, Num_type I64) + | Num_type F32, Num_type F32 -> + let expr = expr1 @ expr2 @ [ F_binop (S32, Sub) ] in + Ok (expr, Num_type F32) + | Num_type F64, Num_type F64 -> + let expr = expr1 @ expr2 @ [ F_binop (S64, Sub) ] in + Ok (expr, Num_type F64) + | _, _ -> Error (`Spec_type_error Fmt.(str "%a" pp_binop b)) ) + | Mult -> ( + match (ty1, ty2) with + | Num_type I32, Num_type I32 -> + let expr = expr1 @ expr2 @ [ I_binop (S32, Mul) ] in + Ok (expr, Num_type I32) + | Num_type I64, Num_type I64 -> + let expr = expr1 @ expr2 @ [ I_binop (S64, Mul) ] in + Ok (expr, Num_type I64) + | Num_type F32, Num_type F32 -> + let expr = expr1 @ expr2 @ [ F_binop (S32, Mul) ] in + Ok (expr, Num_type F32) + | Num_type F64, Num_type F64 -> + let expr = expr1 @ expr2 @ [ F_binop (S64, Mul) ] in + Ok (expr, Num_type F64) + | _, _ -> Error (`Spec_type_error Fmt.(str "%a" pp_binop b)) ) + | Div -> ( + match (ty1, ty2) with + | Num_type I32, Num_type I32 -> + let expr = expr1 @ expr2 @ [ I_binop (S32, Div S) ] in + Ok (expr, Num_type I32) + | Num_type I64, Num_type I64 -> + let expr = expr1 @ expr2 @ [ I_binop (S64, Div S) ] in + Ok (expr, Num_type I64) + | Num_type F32, Num_type F32 -> + let expr = expr1 @ expr2 @ [ F_binop (S32, Div) ] in + Ok (expr, Num_type F32) + | Num_type F64, Num_type F64 -> + let expr = expr1 @ expr2 @ [ F_binop (S64, Div) ] in + Ok (expr, Num_type F64) + | _, _ -> Error (`Spec_type_error Fmt.(str "%a" pp_binop b)) ) + | CustomBinOp _ -> Error (`Spec_type_error Fmt.(str "%a" pp_binop b)) + +let rec term_generate tenv term : (binary expr * binary val_type) Result.t = + match term with + | Int32 i32 -> Ok ([ I32_const i32 ], Num_type I32) + | Int64 i64 -> Ok ([ I64_const i64 ], Num_type I64) + | Float32 f32 -> Ok ([ F32_const f32 ], Num_type F32) + | Float64 f64 -> Ok ([ F64_const f64 ], Num_type F64) + | ParamVar id -> ( + match tenv#get_param_type id with + | Some t -> Ok ([ Local_get id ], t) + | None -> Error (`Spec_type_error Fmt.(str "%a" pp_term term)) ) + | GlobalVar id -> ( + match tenv#get_global_type id with + | Some t -> Ok ([ Global_get id ], t) + | None -> Error (`Spec_type_error Fmt.(str "%a" pp_term term)) ) + | BinderVar _id -> Ok ([], Num_type I32) (* TODO : binder index calculation *) + | UnOp (u, tm1) -> + let* expr1, ty1 = term_generate tenv tm1 in + unop_generate u expr1 ty1 + | BinOp (b, tm1, tm2) -> + let* expr1, ty1 = term_generate tenv tm1 in + let* expr2, ty2 = term_generate tenv tm2 in + binop_generate b expr1 ty1 expr2 ty2 + | Result (Some i) -> ( + match tenv#get_result_type i with + | Some t -> Ok ([ Local_get (Raw (tenv#get_param_number + i)) ], t) + | None -> Error (`Spec_type_error Fmt.(str "%a" pp_term term)) ) + | Result None -> ( + match tenv#get_result_type 0 with + | Some t -> Ok ([ Local_get (Raw tenv#get_param_number) ], t) + | None -> Error (`Spec_type_error Fmt.(str "%a" pp_term term)) ) + +let binpred_generate (b : binpred) (expr1 : binary expr) (ty1 : binary val_type) + (expr2 : binary expr) (ty2 : binary val_type) : binary expr Result.t = + match b with + | Ge -> ( + match (ty1, ty2) with + | Num_type I32, Num_type I32 -> Ok (expr1 @ expr2 @ [ I_relop (S32, Ge S) ]) + | Num_type I64, Num_type I64 -> Ok (expr1 @ expr2 @ [ I_relop (S64, Ge S) ]) + | Num_type F32, Num_type F32 -> Ok (expr1 @ expr2 @ [ F_relop (S32, Ge) ]) + | Num_type F64, Num_type F64 -> Ok (expr1 @ expr2 @ [ F_relop (S64, Ge) ]) + | _, _ -> Error (`Spec_type_error Fmt.(str "%a" pp_binpred b)) ) + | Gt -> ( + match (ty1, ty2) with + | Num_type I32, Num_type I32 -> Ok (expr1 @ expr2 @ [ I_relop (S32, Gt S) ]) + | Num_type I64, Num_type I64 -> Ok (expr1 @ expr2 @ [ I_relop (S64, Gt S) ]) + | Num_type F32, Num_type F32 -> Ok (expr1 @ expr2 @ [ F_relop (S32, Gt) ]) + | Num_type F64, Num_type F64 -> Ok (expr1 @ expr2 @ [ F_relop (S64, Gt) ]) + | _, _ -> Error (`Spec_type_error Fmt.(str "%a" pp_binpred b)) ) + | Le -> ( + match (ty1, ty2) with + | Num_type I32, Num_type I32 -> Ok (expr1 @ expr2 @ [ I_relop (S32, Le S) ]) + | Num_type I64, Num_type I64 -> Ok (expr1 @ expr2 @ [ I_relop (S64, Le S) ]) + | Num_type F32, Num_type F32 -> Ok (expr1 @ expr2 @ [ F_relop (S32, Le) ]) + | Num_type F64, Num_type F64 -> Ok (expr1 @ expr2 @ [ F_relop (S64, Le) ]) + | _, _ -> Error (`Spec_type_error Fmt.(str "%a" pp_binpred b)) ) + | Lt -> ( + match (ty1, ty2) with + | Num_type I32, Num_type I32 -> Ok (expr1 @ expr2 @ [ I_relop (S32, Lt S) ]) + | Num_type I64, Num_type I64 -> Ok (expr1 @ expr2 @ [ I_relop (S64, Lt S) ]) + | Num_type F32, Num_type F32 -> Ok (expr1 @ expr2 @ [ F_relop (S32, Lt) ]) + | Num_type F64, Num_type F64 -> Ok (expr1 @ expr2 @ [ F_relop (S64, Lt) ]) + | _, _ -> Error (`Spec_type_error Fmt.(str "%a" pp_binpred b)) ) + | Eq -> ( + match (ty1, ty2) with + | Num_type I32, Num_type I32 -> Ok (expr1 @ expr2 @ [ I_relop (S32, Eq) ]) + | Num_type I64, Num_type I64 -> Ok (expr1 @ expr2 @ [ I_relop (S64, Eq) ]) + | Num_type F32, Num_type F32 -> Ok (expr1 @ expr2 @ [ F_relop (S32, Eq) ]) + | Num_type F64, Num_type F64 -> Ok (expr1 @ expr2 @ [ F_relop (S64, Eq) ]) + | _, _ -> Error (`Spec_type_error Fmt.(str "%a" pp_binpred b)) ) + | Neq -> ( + match (ty1, ty2) with + | Num_type I32, Num_type I32 -> Ok (expr1 @ expr2 @ [ I_relop (S32, Ne) ]) + | Num_type I64, Num_type I64 -> Ok (expr1 @ expr2 @ [ I_relop (S64, Ne) ]) + | Num_type F32, Num_type F32 -> Ok (expr1 @ expr2 @ [ F_relop (S32, Ne) ]) + | Num_type F64, Num_type F64 -> Ok (expr1 @ expr2 @ [ F_relop (S64, Ne) ]) + | _, _ -> Error (`Spec_type_error Fmt.(str "%a" pp_binpred b)) ) + +let unconnect_generate (u : unconnect) (expr1 : binary expr) : + binary expr Result.t = + match u with Not -> Ok ((prop_true :: expr1) @ [ I_binop (S32, Xor) ]) + +let binconnect_generate (b : binconnect) (expr1 : binary expr) + (expr2 : binary expr) : binary expr Result.t = + let bt = Bt_raw (None, ([ (None, Num_type I32) ], [ Num_type I32 ])) in + match b with + | And -> Ok (expr1 @ [ If_else (None, Some bt, expr2, [ prop_false ]) ]) + | Or -> Ok (expr1 @ [ If_else (None, Some bt, [ prop_true ], expr2) ]) + | Imply -> Ok (expr1 @ [ If_else (None, Some bt, expr2, [ prop_true ]) ]) + | Equiv -> + Ok + ( expr1 + @ [ If_else + (None, Some bt, expr2, (prop_true :: expr2) @ [ I_binop (S32, Xor) ]) + ] ) + +let prop_generate tenv : binary prop -> binary expr Result.t = + let rec prop_generate_aux = function + | Const true -> Ok [ prop_true ] + | Const false -> Ok [ prop_false ] + | BinPred (b, tm1, tm2) -> + let* expr1, ty1 = term_generate tenv tm1 in + let* expr2, ty2 = term_generate tenv tm2 in + binpred_generate b expr1 ty1 expr2 ty2 + | UnConnect (u, pr1) -> + let* expr1 = prop_generate_aux pr1 in + unconnect_generate u expr1 + | BinConnect (b, pr1, pr2) -> + let* expr1 = prop_generate_aux pr1 in + let* expr2 = prop_generate_aux pr2 in + binconnect_generate b expr1 expr2 + | Binder (_b, _bt, _, _pr1) -> + (* TODO : quantification checking *) + Ok [] + in + fun pr -> + let+ expr = prop_generate_aux pr in + expr @ [ Call (Raw tenv#get_owi_assert) ] + +let subst_index ?(subst_custom = false) (old_index : int) (index : int) + (m : modul) : modul = + let subst i = if i = old_index then index else i in + let rec subst_instr (instr : binary instr) : binary instr = + match instr with + | Ref_func (Raw i) -> Ref_func (Raw (subst i)) + | Block (str_opt, bt_opt, expr1) -> Block (str_opt, bt_opt, subst_expr expr1) + | Loop (str_opt, bt_opt, expr1) -> Loop (str_opt, bt_opt, subst_expr expr1) + | If_else (str_opt, bt_opt, expr1, expr2) -> + If_else (str_opt, bt_opt, subst_expr expr1, subst_expr expr2) + | Return_call (Raw i) -> Return_call (Raw (subst i)) + | Call (Raw i) -> Call (Raw (subst i)) + | instr -> instr + and subst_expr (expr : binary expr) = List.map subst_instr expr in + + let subst_global (global : (global, binary global_type) Runtime.t) = + match global with + | Runtime.Local { typ; init; id } -> + Runtime.Local { typ; init = subst_expr init; id } + | Imported _ -> global + in + let global = + { m.global with + values = + List.map + (fun v -> Indexed.(return (get_index v) (subst_global (get v)))) + m.global.values + } + in + + let subst_func (func : (binary func, binary block_type) Runtime.t) = + match func with + | Runtime.Local { type_f; locals; body; id } -> + Runtime.Local { type_f; locals; body = subst_expr body; id } + | Imported _ -> func + in + let func = + { m.func with + values = + List.map + (fun v -> Indexed.(return (get_index v) (subst_func (get v)))) + m.func.values + } + in + + let subst_elem_mode = function + | Elem_passive -> Elem_passive + | Elem_active (int_opt, expr1) -> Elem_active (int_opt, subst_expr expr1) + | Elem_declarative -> Elem_declarative + in + let subst_elem ({ id; typ; init; mode } : elem) = + { id; typ; init = List.map subst_expr init; mode = subst_elem_mode mode } + in + let elem = + { m.elem with + values = + List.map + (fun v -> Indexed.(return (get_index v) (subst_elem (get v)))) + m.elem.values + } + in + + let subst_data_mode = function + | Data_passive -> Data_passive + | Data_active (int, expr1) -> Data_active (int, subst_expr expr1) + in + let subst_data ({ id; init; mode } : data) = + { id; init; mode = subst_data_mode mode } + in + let data = + { m.data with + values = + List.map + (fun v -> Indexed.(return (get_index v) (subst_data (get v)))) + m.data.values + } + in + + let subst_export ({ name; id } : export) = { name; id = subst id } in + let exports = + { m.exports with func = List.map subst_export m.exports.func } + in + + let start = match m.start with Some i -> Some (subst i) | None -> None in + + let subst_contract + ({ Contract.funcid = Raw i; preconditions; postconditions } : + binary Contract.t ) = + { Contract.funcid = Raw (subst i); preconditions; postconditions } + in + let custom = + if subst_custom then + List.map + (function + | From_annot (Annot.Contract c) -> + From_annot (Contract (subst_contract c)) + | _ as c -> c ) + m.custom + else m.custom + in + + { id = m.id + ; types = m.types + ; global + ; table = m.table + ; mem = m.mem + ; func + ; elem + ; data + ; exports + ; start + ; custom + } + +let contract_generate (owi_funcs : (string * int) list) (m : modul) + ({ funcid = Raw old_index; preconditions; postconditions } : binary Contract.t) + : modul Result.t = + let* old_id, Bt_raw (ty_index, old_type) = + match Indexed.get_at old_index m.func.values with + | Some (Runtime.Local { id; type_f; _ }) -> ( + match id with + | Some id -> Ok (id, type_f) + | None -> Ok (Fmt.str "func_%i" old_index, type_f) ) + | Some (Imported { modul; name; assigned_name; desc }) -> ( + match assigned_name with + | Some assigned_name -> Ok (assigned_name, desc) + | None -> Ok (Fmt.str "func_%s_%s_%i" modul name old_index, desc) ) + | None -> Error (`Contract_unknown_func (Raw old_index)) + in + let index = List.length m.func.values in + let id = Fmt.str "__rac_%s" old_id in + + let tenv = type_env m old_type owi_funcs in + + let locals = + List.mapi + (fun i rt -> (Some Fmt.(str "__rac_res_%i" i), rt)) + tenv#get_result_types + in + let call = + List.init tenv#get_param_number (fun i -> Local_get (Raw i)) + @ [ Call (Raw old_index) ] + @ List.init tenv#get_result_number (fun i -> + Local_set (Raw (tenv#get_param_number + i)) ) + in + let return = + List.init tenv#get_result_number (fun i -> + Local_get (Raw (tenv#get_param_number + i)) ) + in + let* precond_checker = list_concat_map (prop_generate tenv) preconditions in + let+ postcond_checker = list_concat_map (prop_generate tenv) postconditions in + let body = precond_checker @ call @ postcond_checker @ return in + + let m = subst_index old_index index m in + + let value = + Runtime.Local + { type_f = Bt_raw (ty_index, old_type); locals; body; id = Some id } + in + let func = + { Named.values = Indexed.return index value :: m.func.values + ; named = String_map.add id index m.func.named + } + in + { m with func } + +let contracts_generate (owi_funcs : (string * int) list) (m : modul) + (contracts : binary Contract.t list) : modul Result.t = + let rec join = function + | ([] | [ _ ]) as l -> l + | c1 :: c2 :: l -> + if Contract.compare_funcid c1 c2 <> 0 then c1 :: join (c2 :: l) + else join (Contract.join_contract c1 c2 :: l) + in + (* sort by numerical index and join contracts of a same function *) + let contracts = join (List.sort Contract.compare_funcid contracts) in + list_fold_left (contract_generate owi_funcs) m contracts + +let add_owi_funcs (m : modul) : modul * (string * int) list = + let owi_funcs : (string * binary func_type) list = + [ ("i32_symbol", ([], [ Num_type I32 ])) + ; ("i64_symbol", ([], [ Num_type I64 ])) + ; ("f32_symbol", ([], [ Num_type F32 ])) + ; ("f64_symbol", ([], [ Num_type F64 ])) + ; ("assume", ([ (None, Num_type I32) ], [])) + ; ("assert", ([ (None, Num_type I32) ], [])) + ] + in + + (* update module field `types` *) + let update_types () : modul * (string * (binary func_type * int)) list = + let func_type2rec_type : binary func_type -> binary rec_type = + fun ty -> [ (None, (Final, [], Def_func_t ty)) ] + in + let owi_funcs : (string * (binary func_type * binary rec_type)) list = + List.map (fun (name, ty) -> (name, (ty, func_type2rec_type ty))) owi_funcs + in + let values = m.types.values in + let values, owi_funcs = + List.fold_left_map + (fun values (name, (ft, rt)) -> + match + List.find_map + (fun (index, rt') -> + if rec_type_eq rt rt' then Some index else None ) + (Indexed.to_assoc_list values) + with + | Some index -> (values, (name, (ft, index))) + | None -> + let index = List.length values in + (Indexed.return index rt :: values, (name, (ft, index))) ) + (List.rev values) owi_funcs + in + let values = List.rev values in + ({ m with types = { values; named = m.types.named } }, owi_funcs) + in + let m, owi_funcs = update_types () in + + (* update module field `func` *) + let update_func () : modul * (string * int) list = + let imported, locals = + List.partition_map + (fun i -> + let v = Indexed.get i in + match v with + | Runtime.Imported _ -> Either.Left (Indexed.get_index i, v) + | Local _ -> Either.Right (Indexed.get_index i, v) ) + m.func.values + in + let imported_num = List.length imported in + let owi_funcs = + List.mapi + (fun i (name, (ty, index)) -> + ( name + , ( { Imported.modul = "symbolic" + ; name + ; assigned_name = Some name + ; desc = Bt_raw (Some (Raw index), ty) + } + , imported_num + i ) ) ) + owi_funcs + in + + let imported = + List.map + (fun (_, (f, index)) -> (index, Runtime.Imported f)) + (List.rev owi_funcs) + @ imported + in + + let subst_task, locals = + List.fold_left_map + (fun subst_task (old_index, f) -> + let index = old_index + List.length owi_funcs in + ((old_index, index) :: subst_task, (index, f)) ) + [] locals + in + + let values = + List.map (fun (index, f) -> Indexed.return index f) (imported @ locals) + in + let named = + List.map + (fun (name, index) -> + if index < imported_num then (name, index) + else (name, index + List.length owi_funcs) ) + (String_map.to_list m.func.named) + in + let named = + String_map.of_list + (List.map (fun (name, (_, index)) -> (name, index)) owi_funcs @ named) + in + + let m = { m with func = { values; named } } in + + let m = + List.fold_left + (fun m (old_index, index) -> + subst_index ~subst_custom:true old_index index m ) + m subst_task + in + let owi_funcs = + List.map (fun (name, (_, index)) -> (name, index)) owi_funcs + in + (m, owi_funcs) + in + update_func () + +let generate (enabled : bool) (m : modul) : modul Result.t = + if not enabled then Ok m + else + let m, owi_funcs = add_owi_funcs m in + contracts_generate owi_funcs m + (List.filter_map + (function From_annot (Annot.Contract c) -> Some c | _ -> None) + m.custom ) diff --git a/src/ast/code_generator.mli b/src/ast/code_generator.mli new file mode 100644 index 000000000..2f4eca1c1 --- /dev/null +++ b/src/ast/code_generator.mli @@ -0,0 +1,5 @@ +(* SPDX-License-Identifier: AGPL-3.0-or-later *) +(* Copyright © 2021-2024 OCamlPro *) +(* Written by the Owi programmers *) + +val generate : bool -> Binary.modul -> Binary.modul Result.t diff --git a/src/ast/compile.ml b/src/ast/compile.ml index 043e4c56b..330143cac 100644 --- a/src/ast/compile.ml +++ b/src/ast/compile.ml @@ -20,96 +20,132 @@ module Text = struct let* m = until_assign ~unsafe m in Rewrite.modul m +<<<<<<< HEAD let until_binary_validate ~unsafe m = +======= + let until_typecheck ~unsafe ~rac m = +>>>>>>> 66d816d7 (framework for rac code generation) let* m = until_binary ~unsafe m in + let* m = Code_generator.generate rac m in if unsafe then Ok m else let+ () = Binary_validate.modul m in m +<<<<<<< HEAD let until_optimize ~unsafe ~optimize m = let+ m = until_binary_validate ~unsafe m in +======= + let until_optimize ~unsafe ~rac ~optimize m = + let+ m = until_typecheck ~unsafe ~rac m in +>>>>>>> 66d816d7 (framework for rac code generation) if optimize then Optimize.modul m else m - let until_link ~unsafe ~optimize ~name link_state m = - let* m = until_optimize ~unsafe ~optimize m in + let until_link ~unsafe ~rac ~optimize ~name link_state m = + let* m = until_optimize ~unsafe ~rac ~optimize m in Link.modul link_state ~name m - let until_interpret ~unsafe ~optimize ~name link_state m = - let* m, link_state = until_link ~unsafe ~optimize ~name link_state m in + let until_interpret ~unsafe ~rac ~optimize ~name link_state m = + let* m, link_state = until_link ~unsafe ~rac ~optimize ~name link_state m in let+ () = Interpret.Concrete.modul link_state.envs m in link_state end module Binary = struct +<<<<<<< HEAD let until_binary_validate ~unsafe m = +======= + let until_typecheck ~unsafe ~rac m = + let* m = Code_generator.generate rac m in +>>>>>>> 66d816d7 (framework for rac code generation) if unsafe then Ok m else let+ () = Binary_validate.modul m in m +<<<<<<< HEAD let until_optimize ~unsafe ~optimize m = let+ m = until_binary_validate ~unsafe m in +======= + let until_optimize ~unsafe ~rac ~optimize m = + let+ m = until_typecheck ~unsafe ~rac m in +>>>>>>> 66d816d7 (framework for rac code generation) if optimize then Optimize.modul m else m - let until_link ~unsafe ~optimize ~name link_state m = - let* m = until_optimize ~unsafe ~optimize m in + let until_link ~unsafe ~rac ~optimize ~name link_state m = + let* m = until_optimize ~unsafe ~rac ~optimize m in Link.modul link_state ~name m - let until_interpret ~unsafe ~optimize ~name link_state m = - let* m, link_state = until_link ~unsafe ~optimize ~name link_state m in + let until_interpret ~unsafe ~rac ~optimize ~name link_state m = + let* m, link_state = until_link ~unsafe ~rac ~optimize ~name link_state m in let+ () = Interpret.Concrete.modul link_state.envs m in link_state end module Any = struct +<<<<<<< HEAD let until_binary_validate ~unsafe = function | Kind.Wat m -> Text.until_binary_validate ~unsafe m | Wasm m -> Binary.until_binary_validate ~unsafe m +======= + let until_typecheck ~unsafe ~rac = function + | Kind.Wat m -> Text.until_typecheck ~unsafe ~rac m + | Wasm m -> Binary.until_typecheck ~unsafe ~rac m +>>>>>>> 66d816d7 (framework for rac code generation) | Wast _ | Ocaml _ -> assert false - let until_optimize ~unsafe ~optimize = function - | Kind.Wat m -> Text.until_optimize ~unsafe ~optimize m - | Wasm m -> Binary.until_optimize ~unsafe ~optimize m + let until_optimize ~unsafe ~rac ~optimize = function + | Kind.Wat m -> Text.until_optimize ~unsafe ~rac ~optimize m + | Wasm m -> Binary.until_optimize ~unsafe ~rac ~optimize m | Wast _ | Ocaml _ -> assert false - let until_link ~unsafe ~optimize ~name link_state = function - | Kind.Wat m -> Text.until_link ~unsafe ~optimize ~name link_state m - | Wasm m -> Binary.until_link ~unsafe ~optimize ~name link_state m + let until_link ~unsafe ~rac ~optimize ~name link_state = function + | Kind.Wat m -> Text.until_link ~unsafe ~rac ~optimize ~name link_state m + | Wasm m -> Binary.until_link ~unsafe ~rac ~optimize ~name link_state m | Wast _ | Ocaml _ -> assert false - let until_interpret ~unsafe ~optimize ~name link_state = function - | Kind.Wat m -> Text.until_interpret ~unsafe ~optimize ~name link_state m - | Wasm m -> Binary.until_interpret ~unsafe ~optimize ~name link_state m + let until_interpret ~unsafe ~rac ~optimize ~name link_state = function + | Kind.Wat m -> + Text.until_interpret ~unsafe ~rac ~optimize ~name link_state m + | Wasm m -> Binary.until_interpret ~unsafe ~rac ~optimize ~name link_state m | Wast _ | Ocaml _ -> assert false end module File = struct +<<<<<<< HEAD let until_binary_validate ~unsafe filename = let* m = Parse.guess_from_file filename in match m with | Kind.Wat m -> Text.until_binary_validate ~unsafe m | Wasm m -> Binary.until_binary_validate ~unsafe m +======= + let until_typecheck ~unsafe ~rac filename = + let* m = Parse.guess_from_file filename in + match m with + | Kind.Wat m -> Text.until_typecheck ~unsafe ~rac m + | Wasm m -> Binary.until_typecheck ~unsafe ~rac m +>>>>>>> 66d816d7 (framework for rac code generation) | Wast _ | Ocaml _ -> assert false - let until_optimize ~unsafe ~optimize filename = + let until_optimize ~unsafe ~rac ~optimize filename = let* m = Parse.guess_from_file filename in match m with - | Kind.Wat m -> Text.until_optimize ~unsafe ~optimize m - | Wasm m -> Binary.until_optimize ~unsafe ~optimize m + | Kind.Wat m -> Text.until_optimize ~unsafe ~rac ~optimize m + | Wasm m -> Binary.until_optimize ~unsafe ~rac ~optimize m | Wast _ | Ocaml _ -> assert false - let until_link ~unsafe ~optimize ~name link_state filename = + let until_link ~unsafe ~rac ~optimize ~name link_state filename = let* m = Parse.guess_from_file filename in match m with - | Kind.Wat m -> Text.until_link ~unsafe ~optimize ~name link_state m - | Wasm m -> Binary.until_link ~unsafe ~optimize ~name link_state m + | Kind.Wat m -> Text.until_link ~unsafe ~rac ~optimize ~name link_state m + | Wasm m -> Binary.until_link ~unsafe ~rac ~optimize ~name link_state m | Wast _ | Ocaml _ -> assert false - let until_interpret ~unsafe ~optimize ~name link_state filename = + let until_interpret ~unsafe ~rac ~optimize ~name link_state filename = let* m = Parse.guess_from_file filename in match m with - | Kind.Wat m -> Text.until_interpret ~unsafe ~optimize ~name link_state m - | Wasm m -> Binary.until_interpret ~unsafe ~optimize ~name link_state m + | Kind.Wat m -> + Text.until_interpret ~unsafe ~rac ~optimize ~name link_state m + | Wasm m -> Binary.until_interpret ~unsafe ~rac ~optimize ~name link_state m | Wast _ | Ocaml _ -> assert false end diff --git a/src/ast/compile.mli b/src/ast/compile.mli index 0bfa84106..a755336f6 100644 --- a/src/ast/compile.mli +++ b/src/ast/compile.mli @@ -5,16 +5,26 @@ (** Utility functions to compile a module until a given step. *) module Any : sig +<<<<<<< HEAD val until_binary_validate : unsafe:bool -> 'extern_func Kind.t -> Binary.modul Result.t +======= + val until_typecheck : + unsafe:bool -> rac:bool -> 'extern_func Kind.t -> Binary.modul Result.t +>>>>>>> 66d816d7 (framework for rac code generation) val until_optimize : - unsafe:bool -> optimize:bool -> 'extern_func Kind.t -> Binary.modul Result.t + unsafe:bool + -> rac:bool + -> optimize:bool + -> 'extern_func Kind.t + -> Binary.modul Result.t (** compile a module with a given link state and produce a new link state and a runnable module *) val until_link : unsafe:bool + -> rac:bool -> optimize:bool -> name:string option -> 'extern_func Link.state @@ -25,6 +35,7 @@ module Any : sig link state *) val until_interpret : unsafe:bool + -> rac:bool -> optimize:bool -> name:string option -> Concrete_value.Func.extern_func Link.state @@ -33,15 +44,21 @@ module Any : sig end module File : sig +<<<<<<< HEAD val until_binary_validate : unsafe:bool -> Fpath.t -> Binary.modul Result.t +======= + val until_typecheck : + unsafe:bool -> rac:bool -> Fpath.t -> Binary.modul Result.t +>>>>>>> 66d816d7 (framework for rac code generation) val until_optimize : - unsafe:bool -> optimize:bool -> Fpath.t -> Binary.modul Result.t + unsafe:bool -> rac:bool -> optimize:bool -> Fpath.t -> Binary.modul Result.t (** compile a file with a given link state and produce a new link state and a runnable module *) val until_link : unsafe:bool + -> rac:bool -> optimize:bool -> name:string option -> 'extern_func Link.state @@ -52,6 +69,7 @@ module File : sig link state *) val until_interpret : unsafe:bool + -> rac:bool -> optimize:bool -> name:string option -> Concrete_value.Func.extern_func Link.state @@ -64,15 +82,25 @@ module Text : sig val until_binary : unsafe:bool -> Text.modul -> Binary.modul Result.t +<<<<<<< HEAD val until_binary_validate : unsafe:bool -> Text.modul -> Binary.modul Result.t +======= + val until_typecheck : + unsafe:bool -> rac:bool -> Text.modul -> Binary.modul Result.t +>>>>>>> 66d816d7 (framework for rac code generation) val until_optimize : - unsafe:bool -> optimize:bool -> Text.modul -> Binary.modul Result.t + unsafe:bool + -> rac:bool + -> optimize:bool + -> Text.modul + -> Binary.modul Result.t (** compile a module with a given link state and produce a new link state and a runnable module *) val until_link : unsafe:bool + -> rac:bool -> optimize:bool -> name:string option -> 'f Link.state @@ -83,6 +111,7 @@ module Text : sig link state *) val until_interpret : unsafe:bool + -> rac:bool -> optimize:bool -> name:string option -> Concrete_value.Func.extern_func Link.state @@ -91,16 +120,26 @@ module Text : sig end module Binary : sig +<<<<<<< HEAD val until_binary_validate : unsafe:bool -> Binary.modul -> Binary.modul Result.t +======= + val until_typecheck : + unsafe:bool -> rac:bool -> Binary.modul -> Binary.modul Result.t +>>>>>>> 66d816d7 (framework for rac code generation) val until_optimize : - unsafe:bool -> optimize:bool -> Binary.modul -> Binary.modul Result.t + unsafe:bool + -> rac:bool + -> optimize:bool + -> Binary.modul + -> Binary.modul Result.t (** compile a module with a given link state and produce a new link state and a runnable module *) val until_link : unsafe:bool + -> rac:bool -> optimize:bool -> name:string option -> 'f Link.state @@ -111,6 +150,7 @@ module Binary : sig link state *) val until_interpret : unsafe:bool + -> rac:bool -> optimize:bool -> name:string option -> Concrete_value.Func.extern_func Link.state diff --git a/src/ast/types.ml b/src/ast/types.ml index 25d76e21b..d61b60952 100644 --- a/src/ast/types.ml +++ b/src/ast/types.ml @@ -42,13 +42,15 @@ let pp_indice (type kind) fmt : kind indice -> unit = function | Raw u -> int fmt u | Text i -> pp_id fmt i -let compare_indice id1 id2 = +let compare_indice (type a) (id1 : a indice) (id2 : a indice) = match (id1, id2) with | Raw i1, Raw i2 -> compare i1 i2 | Text s1, Text s2 -> String.compare s1 s2 | Raw _, Text _ -> -1 | Text _, Raw _ -> 1 +let indice_eq id1 id2 = compare_indice id1 id2 = 0 + let pp_indice_opt fmt = function None -> () | Some i -> pp_indice fmt i let pp_indices fmt ids = list ~sep:sp pp_indice fmt ids @@ -257,6 +259,11 @@ let pp_final fmt = function | Final -> pf fmt "final" | No_final -> pf fmt "no_final" +let final_eq f1 f2 = + match (f1, f2) with + | Final, Final | No_final, No_final -> true + | _, _ -> false + (** Structure *) (** Types *) @@ -927,6 +934,9 @@ type 'a sub_type = final * 'a indice list * 'a str_type let pp_sub_type fmt (f, ids, t) = pf fmt "(sub %a %a %a)" pp_final f pp_indices ids str_type t +let sub_type_eq (f1, ids1, t1) (f2, ids2, t2) = + final_eq f1 f2 && List.equal indice_eq ids1 ids2 && str_type_eq t1 t2 + type 'a type_def = string option * 'a sub_type let pp_type_def_no_indent fmt (id, t) = @@ -934,6 +944,9 @@ let pp_type_def_no_indent fmt (id, t) = let pp_type_def fmt t = pf fmt "@\n @[%a@]" pp_type_def_no_indent t +let type_def_eq (id1, t1) (id2, t2) = + Option.equal String.equal id1 id2 && sub_type_eq t1 t2 + type 'a rec_type = 'a type_def list let pp_rec_type fmt l = @@ -942,6 +955,8 @@ let pp_rec_type fmt l = | [ t ] -> pf fmt "%a" pp_type_def_no_indent t | l -> pf fmt "(rec %a)" (list ~sep:sp pp_type_def) l +let rec_type_eq l1 l2 = List.equal type_def_eq l1 l2 + let pp_start fmt start = pf fmt "(start %a)" pp_indice start type 'a const = diff --git a/src/bin/owi.ml b/src/bin/owi.ml index 2928be11b..1db49dbc5 100644 --- a/src/bin/owi.ml +++ b/src/bin/owi.ml @@ -122,9 +122,9 @@ let workspace = Cmdliner.Arg.( value & opt dir_file (Fpath.v "owi-out") & info [ "workspace" ] ~doc ) -let spec = +let rac = let doc = "WEbAssembly Specification Language" in - Cmdliner.Arg.(value & flag & info [ "spec" ] ~doc) + Cmdliner.Arg.(value & flag & info [ "runtime-assertion-checking"; "r" ] ~doc) let copts_t = Cmdliner.Term.(const []) @@ -210,7 +210,8 @@ let run_cmd = Cmd.info "run" ~version ~doc ~sdocs ~man in Cmd.v info - Term.(const Cmd_run.cmd $ profiling $ debug $ unsafe $ optimize $ files) + Term.( + const Cmd_run.cmd $ profiling $ debug $ unsafe $ rac $ optimize $ files ) let validate_cmd = let open Cmdliner in @@ -219,7 +220,7 @@ let validate_cmd = let man = [] @ shared_man in Cmd.info "validate" ~version ~doc ~sdocs ~man in - Cmd.v info Term.(const Cmd_validate.cmd $ debug $ files) + Cmd.v info Term.(const Cmd_validate.cmd $ debug $ rac $ files) let script_cmd = let open Cmdliner in @@ -230,7 +231,7 @@ let script_cmd = in Cmd.v info Term.( - const Cmd_script.cmd $ profiling $ debug $ optimize $ files + const Cmd_script.cmd $ profiling $ debug $ rac $ optimize $ files $ no_exhaustion ) let sym_cmd = @@ -243,7 +244,7 @@ let sym_cmd = Cmd.v info Term.( const Cmd_sym.cmd $ profiling $ debug $ unsafe $ optimize $ workers - $ no_stop_at_failure $ no_values $ deterministic_result_order $ spec + $ no_stop_at_failure $ no_values $ deterministic_result_order $ rac $ fail_mode $ workspace $ solver $ files ) let conc_cmd = @@ -256,7 +257,7 @@ let conc_cmd = Cmd.v info Term.( const Cmd_conc.cmd $ profiling $ debug $ unsafe $ optimize $ workers - $ no_stop_at_failure $ no_values $ deterministic_result_order $ spec + $ no_stop_at_failure $ no_values $ deterministic_result_order $ rac $ fail_mode $ workspace $ solver $ files ) let wasm2wat_cmd = @@ -372,21 +373,22 @@ let exit_code = | `Unknown_type _id -> 52 | `Unsupported_file_extension _ext -> 53 | `Failed_with_but_expected (_got, _expected) -> 54 - | `Annotation_id_incorrect _annotid -> 55 - | `Invalid_int32 _i32 -> 56 - | `Invalid_int64 _i64 -> 57 - | `Invalid_float32 _f32 -> 58 - | `Invalid_float64 _f64 -> 59 - | `Invalid_indice _id -> 60 - | `Invalid_text_indice _id -> 61 + | `Spec_invalid_int32 _i32 -> 56 + | `Spec_invalid_int64 _i64 -> 57 + | `Spec_invalid_float32 _f32 -> 58 + | `Spec_invalid_float64 _f64 -> 59 + | `Spec_invalid_indice _id -> 60 + | `Spec_invalid_text_indice _id -> 61 | `Unknown_annotation_clause _s -> 62 | `Unknown_annotation_object _s -> 63 - | `Unknown_binder _id -> 64 - | `Unknown_param _id -> 65 - | `Unknown_variable _id -> 66 - | `Unknown_binder_type _s -> 67 - | `Unknown_prop _pr -> 68 - | `Unknown_term _tm -> 69 + | `Spec_unknown_binder _id -> 64 + | `Spec_unknown_param _id -> 65 + | `Spec_unknown_variable _id -> 66 + | `Spec_unknown_binder_type _s -> 67 + | `Spec_unknown_prop _pr -> 68 + | `Spec_unknown_term _tm -> 69 + | `Spec_type_error _str -> 70 + | `Contract_unknown_func _id -> 71 end end | Error e -> ( diff --git a/src/cmd/cmd_conc.ml b/src/cmd/cmd_conc.ml index 365919cc7..385fd532f 100644 --- a/src/cmd/cmd_conc.ml +++ b/src/cmd/cmd_conc.ml @@ -16,21 +16,26 @@ let ( let** ) (t : 'a Result.t Choice.t) (f : 'a -> 'b Result.t Choice.t) : Choice.bind t (fun t -> match t with Error e -> Choice.return (Error e) | Ok x -> f x ) -let simplify_then_link ~unsafe ~optimize link_state m = +let simplify_then_link ~unsafe ~optimize ~rac link_state m = let* m = match m with +<<<<<<< HEAD | Kind.Wat _ | Wasm _ -> Compile.Any.until_binary_validate ~unsafe m +======= + | Kind.Wat _ | Wasm _ -> Compile.Any.until_typecheck ~unsafe ~rac m +>>>>>>> 66d816d7 (framework for rac code generation) | Wast _ -> Error (`Msg "can't run concolic interpreter on a script") | Ocaml _ -> assert false in let* m = Cmd_utils.add_main_as_start m in let+ m, link_state = - Compile.Binary.until_link ~unsafe link_state ~optimize ~name:None m + Compile.Binary.until_link ~unsafe ~rac:false ~optimize ~name:None link_state + m in let module_to_run = Concolic.convert_module_to_run m in (link_state, module_to_run) -let simplify_then_link_files ~unsafe ~optimize filenames = +let simplify_then_link_files ~unsafe ~optimize ~rac filenames = let link_state = Link.empty_state in let link_state = Link.extern_module' link_state ~name:"symbolic" @@ -48,7 +53,7 @@ let simplify_then_link_files ~unsafe ~optimize filenames = let* link_state, modules_to_run = acc in let* m0dule = Parse.guess_from_file filename in let+ link_state, module_to_run = - simplify_then_link ~unsafe ~optimize link_state m0dule + simplify_then_link ~unsafe ~optimize ~rac link_state m0dule in (link_state, module_to_run :: modules_to_run) ) (Ok (link_state, [])) @@ -415,8 +420,8 @@ let run solver tree link_state modules_to_run = which are handled here. Most of the computations are done in the Result monad, hence the let*. *) let cmd profiling debug unsafe optimize _workers _no_stop_at_failure no_values - _deterministic_result_order _spec _fail_mode (workspace : Fpath.t) solver - files = + _deterministic_result_order rac _fail_mode (workspace : Fpath.t) solver files + = if profiling then Log.profiling_on := true; if debug then Log.debug_on := true; (* deterministic_result_order implies no_stop_at_failure *) @@ -424,7 +429,7 @@ let cmd profiling debug unsafe optimize _workers _no_stop_at_failure no_values let* _created_dir = Bos.OS.Dir.create ~path:true ~mode:0o755 workspace in let solver = Solver.fresh solver () in let* link_state, modules_to_run = - simplify_then_link_files ~unsafe ~optimize files + simplify_then_link_files ~unsafe ~optimize ~rac files in let tree = fresh_tree [] in let* result = run solver tree link_state modules_to_run in diff --git a/src/cmd/cmd_opt.ml b/src/cmd/cmd_opt.ml index 95ff24af6..d70838898 100644 --- a/src/cmd/cmd_opt.ml +++ b/src/cmd/cmd_opt.ml @@ -4,8 +4,8 @@ open Syntax -let optimize_file ~unsafe filename = - Compile.File.until_optimize ~unsafe ~optimize:true filename +let optimize_file ~unsafe ~rac filename = + Compile.File.until_optimize ~unsafe ~rac ~optimize:true filename let print_or_emit ~unsafe file outfile = let* m = optimize_file ~unsafe file in diff --git a/src/cmd/cmd_run.ml b/src/cmd/cmd_run.ml index 689dc2e65..abf51ce5b 100644 --- a/src/cmd/cmd_run.ml +++ b/src/cmd/cmd_run.ml @@ -4,15 +4,15 @@ open Syntax -let run_file ~unsafe ~optimize filename = +let run_file ~unsafe ~rac ~optimize filename = let name = None in let+ (_ : _ Link.state) = - Compile.File.until_interpret ~unsafe ~optimize ~name Link.empty_state + Compile.File.until_interpret ~unsafe ~rac ~optimize ~name Link.empty_state filename in () -let cmd profiling debug unsafe optimize files = +let cmd profiling debug unsafe rac optimize files = if profiling then Log.profiling_on := true; if debug then Log.debug_on := true; - list_iter (run_file ~unsafe ~optimize) files + list_iter (run_file ~unsafe ~rac ~optimize) files diff --git a/src/cmd/cmd_run.mli b/src/cmd/cmd_run.mli index 5cef2e0c3..63aec0acf 100644 --- a/src/cmd/cmd_run.mli +++ b/src/cmd/cmd_run.mli @@ -2,4 +2,4 @@ (* Copyright © 2021-2024 OCamlPro *) (* Written by the Owi programmers *) -val cmd : bool -> bool -> bool -> bool -> Fpath.t list -> unit Result.t +val cmd : bool -> bool -> bool -> bool -> bool -> Fpath.t list -> unit Result.t diff --git a/src/cmd/cmd_script.ml b/src/cmd/cmd_script.ml index 30048a92c..4bf1be2da 100644 --- a/src/cmd/cmd_script.ml +++ b/src/cmd/cmd_script.ml @@ -8,8 +8,8 @@ let run_file exec filename = let* script = Parse.Text.Script.from_file filename in exec script -let cmd profiling debug optimize files no_exhaustion = - let exec = Script.exec ~no_exhaustion ~optimize in +let cmd profiling debug rac optimize files no_exhaustion = + let exec = Script.exec ~rac ~no_exhaustion ~optimize in if profiling then Log.profiling_on := true; if debug then Log.debug_on := true; list_iter (run_file exec) files diff --git a/src/cmd/cmd_script.mli b/src/cmd/cmd_script.mli index fe2dd1058..60666d712 100644 --- a/src/cmd/cmd_script.mli +++ b/src/cmd/cmd_script.mli @@ -2,4 +2,4 @@ (* Copyright © 2021-2024 OCamlPro *) (* Written by the Owi programmers *) -val cmd : bool -> bool -> bool -> Fpath.t list -> bool -> unit Result.t +val cmd : bool -> bool -> bool -> bool -> Fpath.t list -> bool -> unit Result.t diff --git a/src/cmd/cmd_sym.ml b/src/cmd/cmd_sym.ml index 8960b2840..94cc37c94 100644 --- a/src/cmd/cmd_sym.ml +++ b/src/cmd/cmd_sym.ml @@ -35,7 +35,8 @@ let run_file ~unsafe ~optimize pc filename = let link_state = Lazy.force link_state in let*/ m, link_state = - Compile.Binary.until_link ~unsafe link_state ~optimize ~name:None m + Compile.Binary.until_link ~unsafe ~rac:false ~optimize ~name:None link_state + m in let m = Symbolic.convert_module_to_run m in let c = Interpret.SymbolicP.modul link_state.envs m in @@ -47,15 +48,14 @@ let run_file ~unsafe ~optimize pc filename = which are handled here. Most of the computations are done in the Result monad, hence the let*. *) let cmd profiling debug unsafe optimize workers no_stop_at_failure no_values - deterministic_result_order _spec fail_mode (workspace : Fpath.t) solver files - = + deterministic_result_order rac fail_mode (workspace : Fpath.t) solver files = if profiling then Log.profiling_on := true; if debug then Log.debug_on := true; (* deterministic_result_order implies no_stop_at_failure *) let no_stop_at_failure = deterministic_result_order || no_stop_at_failure in let* _created_dir = Bos.OS.Dir.create ~path:true ~mode:0o755 workspace in let pc = Choice.return (Ok ()) in - let result = List.fold_left (run_file ~unsafe ~optimize) pc files in + let result = List.fold_left (run_file ~unsafe ~optimize ~rac) pc files in let thread = Thread_with_memory.init () in let res_queue = Wq.make () in let path_count = ref 0 in diff --git a/src/cmd/cmd_validate.ml b/src/cmd/cmd_validate.ml index 53ca33445..cd6daa6b4 100644 --- a/src/cmd/cmd_validate.ml +++ b/src/cmd/cmd_validate.ml @@ -4,12 +4,16 @@ open Syntax -let validate filename = +let validate rac filename = let+ (_modul : Binary.modul) = +<<<<<<< HEAD Compile.File.until_binary_validate ~unsafe:false filename +======= + Compile.File.until_typecheck ~unsafe:false ~rac filename +>>>>>>> 66d816d7 (framework for rac code generation) in () -let cmd debug files = +let cmd debug rac files = if debug then Log.debug_on := true; - list_iter validate files + list_iter (validate rac) files diff --git a/src/cmd/cmd_validate.mli b/src/cmd/cmd_validate.mli index 433a95470..b26bccd2a 100644 --- a/src/cmd/cmd_validate.mli +++ b/src/cmd/cmd_validate.mli @@ -2,4 +2,4 @@ (* Copyright © 2021-2024 OCamlPro *) (* Written by the Owi programmers *) -val cmd : bool -> Fpath.t list -> unit Result.t +val cmd : bool -> bool -> Fpath.t list -> unit Result.t diff --git a/src/data_structures/indexed.ml b/src/data_structures/indexed.ml index 02b89f1b2..a16deb1df 100644 --- a/src/data_structures/indexed.ml +++ b/src/data_structures/indexed.ml @@ -21,3 +21,7 @@ let get_at i values = match List.find_opt (has_index i) values with | None -> None | Some { value; _ } -> Some value + +let rec to_assoc_list = function + | [] -> [] + | { index; value } :: l -> (index, value) :: to_assoc_list l diff --git a/src/data_structures/indexed.mli b/src/data_structures/indexed.mli index 14602cf80..146a98bd0 100644 --- a/src/data_structures/indexed.mli +++ b/src/data_structures/indexed.mli @@ -15,3 +15,5 @@ val return : int -> 'a -> 'a t val get_at : int -> 'a t list -> 'a option val has_index : int -> 'a t -> bool + +val to_assoc_list : 'a t list -> (int * 'a) list diff --git a/src/dune b/src/dune index fcd0cb281..b352e449d 100644 --- a/src/dune +++ b/src/dune @@ -24,6 +24,7 @@ cmd_validate cmd_wasm2wat cmd_wat2wasm + code_generator compile concolic concolic_choice diff --git a/src/script/script.ml b/src/script/script.ml index db8fa896a..39b75dd5e 100644 --- a/src/script/script.ml +++ b/src/script/script.ml @@ -141,7 +141,7 @@ let action (link_state : Concrete_value.Func.extern_func Link.state) = function let unsafe = false -let run ~no_exhaustion ~optimize script = +let run ~no_exhaustion ~rac ~optimize script = let state = Link.extern_module Link.empty_state ~name:"spectest_extern" Spectest.extern_m @@ -157,7 +157,8 @@ let run ~no_exhaustion ~optimize script = Log.debug0 "*** module@\n"; incr curr_module; let+ link_state = - Compile.Text.until_interpret link_state ~unsafe ~optimize ~name:None m + Compile.Text.until_interpret link_state ~unsafe ~rac ~optimize + ~name:None m in Log.debug_on := debug_on; link_state @@ -166,7 +167,8 @@ let run ~no_exhaustion ~optimize script = incr curr_module; let* m = Parse.Text.Inline_module.from_string m in let+ link_state = - Compile.Text.until_interpret link_state ~unsafe ~optimize ~name:None m + Compile.Text.until_interpret link_state ~unsafe ~rac ~optimize + ~name:None m in link_state | Text.Binary_module (id, m) -> @@ -175,15 +177,15 @@ let run ~no_exhaustion ~optimize script = let* m = Parse.Binary.Module.from_string m in let m = { m with id } in let+ link_state = - Compile.Binary.until_interpret link_state ~unsafe ~optimize ~name:None - m + Compile.Binary.until_interpret link_state ~unsafe ~rac ~optimize + ~name:None m in link_state | Assert (Assert_trap_module (m, expected)) -> Log.debug0 "*** assert_trap@\n"; incr curr_module; let* m, link_state = - Compile.Text.until_link link_state ~unsafe ~optimize ~name:None m + Compile.Text.until_link link_state ~unsafe ~rac ~optimize ~name:None m in let got = Interpret.Concrete.modul link_state.envs m in let+ () = check_error_result expected got in @@ -224,7 +226,7 @@ let run ~no_exhaustion ~optimize script = | Assert (Assert_invalid (m, expected)) -> Log.debug0 "*** assert_invalid@\n"; let got = - Compile.Text.until_link link_state ~unsafe ~optimize ~name:None m + Compile.Text.until_link link_state ~unsafe ~rac ~optimize ~name:None m in let+ () = check_error_result expected got in link_state @@ -236,14 +238,14 @@ let run ~no_exhaustion ~optimize script = | Assert (Assert_unlinkable (m, expected)) -> Log.debug0 "*** assert_unlinkable@\n"; let got = - Compile.Text.until_link link_state ~unsafe ~optimize ~name:None m + Compile.Text.until_link link_state ~unsafe ~rac ~optimize ~name:None m in let+ () = check_error_result expected got in link_state | Assert (Assert_malformed (m, expected)) -> Log.debug0 "*** assert_malformed@\n"; let got = - Compile.Text.until_link ~unsafe ~optimize ~name:None link_state m + Compile.Text.until_link ~unsafe ~rac ~optimize ~name:None link_state m in let+ () = check_error_result expected got in assert false @@ -286,6 +288,6 @@ let run ~no_exhaustion ~optimize script = link_state ) state script -let exec ~no_exhaustion ~optimize script = - let+ _link_state = run ~no_exhaustion ~optimize script in +let exec ~no_exhaustion ~rac ~optimize script = + let+ _link_state = run ~no_exhaustion ~rac ~optimize script in () diff --git a/src/script/script.mli b/src/script/script.mli index d3a86af8a..08788491e 100644 --- a/src/script/script.mli +++ b/src/script/script.mli @@ -5,4 +5,9 @@ (** Module to execute a full Wasm script. *) (** execute a Wasm script *) -val exec : no_exhaustion:bool -> optimize:bool -> Text.script -> unit Result.t +val exec : + no_exhaustion:bool + -> rac:bool + -> optimize:bool + -> Text.script + -> unit Result.t diff --git a/src/text_to_binary/rewrite.ml b/src/text_to_binary/rewrite.ml index 8b911fc67..e8ea2b5c5 100644 --- a/src/text_to_binary/rewrite.ml +++ b/src/text_to_binary/rewrite.ml @@ -376,14 +376,14 @@ let rec rewrite_term ~(binder_list : string option list) ~(modul : Binary.modul) binary indice Result.t = match ind with | Raw id -> Ok (Raw id) - | Text id -> find_raw_indice (`Unknown_binder ind) 0 id binder_list + | Text id -> find_raw_indice (`Spec_unknown_binder ind) 0 id binder_list in let find_param (func_param_list : string option list) (ind : text indice) : binary indice Result.t = match ind with | Raw id -> Ok (Raw id) - | Text id -> find_raw_indice (`Unknown_param ind) 0 id func_param_list + | Text id -> find_raw_indice (`Spec_unknown_param ind) 0 id func_param_list in let find_global (modul : Binary.modul) (ind : text indice) : @@ -411,7 +411,7 @@ let rec rewrite_term ~(binder_list : string option list) ~(modul : Binary.modul) | Ok ind, _, _ -> Ok (BinderVar ind) | _, Ok ind, _ -> Ok (ParamVar ind) | _, _, Ok ind -> Ok (GlobalVar ind) - | _, _, _ -> Error (`Unknown_variable ind) ) + | _, _, _ -> Error (`Spec_unknown_variable ind) ) | ParamVar ind -> let+ ind = find_param func_param_list ind in ParamVar ind @@ -428,7 +428,7 @@ let rec rewrite_term ~(binder_list : string option list) ~(modul : Binary.modul) let* tm1 = rewrite_term ~binder_list ~modul ~func_param_list tm1 in let+ tm2 = rewrite_term ~binder_list ~modul ~func_param_list tm2 in BinOp (b, tm1, tm2) - | Result -> Ok Result + | Result i -> Ok (Result i) let rec rewrite_prop ~(binder_list : string option list) ~(modul : Binary.modul) ~(func_param_list : string option list) : @@ -455,11 +455,15 @@ let rec rewrite_prop ~(binder_list : string option list) ~(modul : Binary.modul) let rewrite_contract (modul : Binary.modul) : text Contract.t -> binary Contract.t Result.t = fun { Contract.funcid; preconditions; postconditions } -> - let* func = get (`Unknown_func funcid) modul.func funcid in - let funcid = Raw (Indexed.get_index func) in + let (Raw i as funcid) = find modul.func funcid in + let* func = + match Indexed.get_at i modul.func.values with + | None -> Error (`Unknown_func funcid) + | Some v -> Ok v + in let func_param_list = let (Bt_raw (_, (params, _))) = - match Indexed.get func with + match func with | Local { type_f; _ } -> type_f | Imported { desc; _ } -> desc in diff --git a/src/utils/result.ml b/src/utils/result.ml index f4361e0ab..8eaf59aac 100644 --- a/src/utils/result.ml +++ b/src/utils/result.ml @@ -59,21 +59,22 @@ type err = | `Unknown_table of Types.text Types.indice | `Unknown_type of Types.text Types.indice | `Unsupported_file_extension of string - | `Annotation_id_incorrect of string - | `Invalid_int32 of string - | `Invalid_int64 of string - | `Invalid_float32 of string - | `Invalid_float64 of string - | `Invalid_indice of string - | `Invalid_text_indice of string + | `Spec_invalid_int32 of string + | `Spec_invalid_int64 of string + | `Spec_invalid_float32 of string + | `Spec_invalid_float64 of string + | `Spec_invalid_indice of string + | `Spec_invalid_text_indice of string | `Unknown_annotation_clause of Sexp.t | `Unknown_annotation_object of Sexp.t - | `Unknown_binder of Types.text Types.indice - | `Unknown_param of Types.text Types.indice - | `Unknown_variable of Types.text Types.indice - | `Unknown_binder_type of Sexp.t - | `Unknown_prop of Sexp.t - | `Unknown_term of Sexp.t + | `Spec_unknown_binder of Types.text Types.indice + | `Spec_unknown_param of Types.text Types.indice + | `Spec_unknown_variable of Types.text Types.indice + | `Spec_unknown_binder_type of Sexp.t + | `Spec_unknown_prop of Sexp.t + | `Spec_unknown_term of Sexp.t + | `Spec_type_error of string + | `Contract_unknown_func of Types.text Types.indice ] type 'a t = ('a, err) Prelude.Result.t @@ -139,21 +140,26 @@ let rec err_to_string = function | `Unknown_type id -> Fmt.str "unknown type %a" Types.pp_indice id | `Unsupported_file_extension ext -> Fmt.str "unsupported file_extension %S" ext - | `Annotation_id_incorrect annotid -> - Fmt.str "annotation id %S incorrect" annotid - | `Invalid_int32 i32 -> Fmt.str "invalid int32 %S" i32 - | `Invalid_int64 i64 -> Fmt.str "invalid int64 %S" i64 - | `Invalid_float32 f32 -> Fmt.str "invalid float32 %S" f32 - | `Invalid_float64 f64 -> Fmt.str "invalid float64 %S" f64 - | `Invalid_indice id -> Fmt.str "invalid indice %S" id - | `Invalid_text_indice id -> Fmt.str "invalid text indice %S" id + | `Spec_invalid_int32 i32 -> Fmt.str "spec: invalid int32 %S" i32 + | `Spec_invalid_int64 i64 -> Fmt.str "spec: invalid int64 %S" i64 + | `Spec_invalid_float32 f32 -> Fmt.str "spec: invalid float32 %S" f32 + | `Spec_invalid_float64 f64 -> Fmt.str "spec: invalid float64 %S" f64 + | `Spec_invalid_indice id -> Fmt.str "spec: invalid indice %S" id + | `Spec_invalid_text_indice id -> Fmt.str "spec: invalid text indice %S" id | `Unknown_annotation_clause s -> Fmt.str "unknown annotation clause %a" Sexp.pp_sexp s | `Unknown_annotation_object s -> Fmt.str "unknown annotation object %a" Sexp.pp_sexp s - | `Unknown_binder id -> Fmt.str "unknown binder %a" Types.pp_indice id - | `Unknown_param id -> Fmt.str "unknown param %a" Types.pp_indice id - | `Unknown_variable id -> Fmt.str "unknown variable %a" Types.pp_indice id - | `Unknown_binder_type s -> Fmt.str "unknown binder type %a" Sexp.pp_sexp s - | `Unknown_prop pr -> Fmt.str "unknown prop %a" Sexp.pp_sexp pr - | `Unknown_term tm -> Fmt.str "unknown term %a" Sexp.pp_sexp tm + | `Spec_unknown_binder id -> + Fmt.str "spec: unknown binder %a" Types.pp_indice id + | `Spec_unknown_param id -> + Fmt.str "spec: unknown param %a" Types.pp_indice id + | `Spec_unknown_variable id -> + Fmt.str "spec: unknown variable %a" Types.pp_indice id + | `Spec_unknown_binder_type s -> + Fmt.str "spec: unknown binder type %a" Sexp.pp_sexp s + | `Spec_unknown_prop pr -> Fmt.str "spec: unknown prop %a" Sexp.pp_sexp pr + | `Spec_unknown_term tm -> Fmt.str "spec: unknown term %a" Sexp.pp_sexp tm + | `Spec_type_error str -> Fmt.str "spec: %S type error" str + | `Contract_unknown_func id -> + Fmt.str "contract: unknown function %a" Types.pp_indice id diff --git a/src/utils/result.mli b/src/utils/result.mli index bbc69331b..41856833e 100644 --- a/src/utils/result.mli +++ b/src/utils/result.mli @@ -59,21 +59,22 @@ type err = | `Unknown_table of Types.text Types.indice | `Unknown_type of Types.text Types.indice | `Unsupported_file_extension of string - | `Annotation_id_incorrect of string - | `Invalid_int32 of string - | `Invalid_int64 of string - | `Invalid_float32 of string - | `Invalid_float64 of string - | `Invalid_indice of string - | `Invalid_text_indice of string + | `Spec_invalid_int32 of string + | `Spec_invalid_int64 of string + | `Spec_invalid_float32 of string + | `Spec_invalid_float64 of string + | `Spec_invalid_indice of string + | `Spec_invalid_text_indice of string | `Unknown_annotation_clause of Sexp.t | `Unknown_annotation_object of Sexp.t - | `Unknown_binder of Types.text Types.indice - | `Unknown_param of Types.text Types.indice - | `Unknown_variable of Types.text Types.indice - | `Unknown_binder_type of Sexp.t - | `Unknown_prop of Sexp.t - | `Unknown_term of Sexp.t + | `Spec_unknown_binder of Types.text Types.indice + | `Spec_unknown_param of Types.text Types.indice + | `Spec_unknown_variable of Types.text Types.indice + | `Spec_unknown_binder_type of Sexp.t + | `Spec_unknown_prop of Sexp.t + | `Spec_unknown_term of Sexp.t + | `Spec_type_error of string + | `Contract_unknown_func of Types.text Types.indice ] type 'a t = ('a, err) Prelude.Result.t diff --git a/src/utils/syntax.ml b/src/utils/syntax.ml index d02c5c9b9..5c773a06d 100644 --- a/src/utils/syntax.ml +++ b/src/utils/syntax.ml @@ -38,6 +38,20 @@ let list_map f l = l with Exit -> Option.get !err +let list_concat_map f l = + let err = ref None in + try + ok + @@ List.concat_map + (fun v -> + match f v with + | Error _e as e -> + err := Some e; + raise Exit + | Ok v -> v ) + l + with Exit -> Option.get !err + let list_fold_left f acc l = List.fold_left (fun acc v -> diff --git a/src/utils/syntax.mli b/src/utils/syntax.mli index 995712820..4a04a2734 100644 --- a/src/utils/syntax.mli +++ b/src/utils/syntax.mli @@ -22,6 +22,11 @@ val list_map : -> 'a list -> ('b list, 'err) Prelude.Result.t +val list_concat_map : + ('a -> ('b list, 'err) Prelude.Result.t) + -> 'a list + -> ('b list, 'err) Prelude.Result.t + val list_fold_left : ('a -> 'b -> ('a, 'err) Prelude.Result.t) -> 'a From 81b0bf5174efab25863dfb939178395bb0ea06f4 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Wed, 21 Aug 2024 11:44:49 +0200 Subject: [PATCH 33/51] fix some tests by adding proper exceptions --- src/ast/code_generator.ml | 11 +++++++++-- src/bin/owi.ml | 7 +++++-- src/parser/parse.ml | 6 ++++-- src/parser/text_lexer.ml | 26 ++++++++++++++++---------- src/parser/text_lexer.mli | 6 +++++- src/utils/result.ml | 8 +++++++- src/utils/result.mli | 3 +++ test/script/gc.t | 2 +- test/script/reference | 2 +- 9 files changed, 51 insertions(+), 20 deletions(-) diff --git a/src/ast/code_generator.ml b/src/ast/code_generator.ml index 5dc5e34c5..d54d4c3dc 100644 --- a/src/ast/code_generator.ml +++ b/src/ast/code_generator.ml @@ -49,6 +49,10 @@ let type_env (m : modul) (func_ty : binary param_type * binary result_type) method get_global_type (Raw i : binary indice) : binary val_type option = List.nth_opt global_types i + method get_binder_type_and_index (Raw _i : binary indice) + : (binary indice * binary val_type) option = + None (* TODO *) + method get_result_type (i : int) : binary val_type option = List.nth_opt result_types i @@ -183,7 +187,10 @@ let rec term_generate tenv term : (binary expr * binary val_type) Result.t = match tenv#get_global_type id with | Some t -> Ok ([ Global_get id ], t) | None -> Error (`Spec_type_error Fmt.(str "%a" pp_term term)) ) - | BinderVar _id -> Ok ([], Num_type I32) (* TODO : binder index calculation *) + | BinderVar id -> ( + match tenv#get_binder_type_and_index id with + | Some (id, t) -> Ok ([ Local_get id ], t) + | None -> Error (`Spec_type_error Fmt.(str "%a" pp_term term)) ) | UnOp (u, tm1) -> let* expr1, ty1 = term_generate tenv tm1 in unop_generate u expr1 ty1 @@ -280,7 +287,7 @@ let prop_generate tenv : binary prop -> binary expr Result.t = let* expr2 = prop_generate_aux pr2 in binconnect_generate b expr1 expr2 | Binder (_b, _bt, _, _pr1) -> - (* TODO : quantification checking *) + (* TODO : quantifier checking *) Ok [] in fun pr -> diff --git a/src/bin/owi.ml b/src/bin/owi.ml index 1db49dbc5..87f2285f3 100644 --- a/src/bin/owi.ml +++ b/src/bin/owi.ml @@ -123,8 +123,8 @@ let workspace = value & opt dir_file (Fpath.v "owi-out") & info [ "workspace" ] ~doc ) let rac = - let doc = "WEbAssembly Specification Language" in - Cmdliner.Arg.(value & flag & info [ "runtime-assertion-checking"; "r" ] ~doc) + let doc = "runtime assertion checking mode" in + Cmdliner.Arg.(value & flag & info [ "rac" ] ~doc) let copts_t = Cmdliner.Term.(const []) @@ -342,6 +342,7 @@ let exit_code = | `Incompatible_import_type -> 20 | `Inline_function_type -> 21 | `Invalid_result_arity -> 22 + | `Lexer_illegal_character _c -> 23 | `Lexer_unknown_operator _op -> 23 | `Malformed_utf8_encoding _txt -> 24 | `Memory_size_too_large -> 25 @@ -389,6 +390,8 @@ let exit_code = | `Spec_unknown_term _tm -> 69 | `Spec_type_error _str -> 70 | `Contract_unknown_func _id -> 71 + | `Empty_annotation_id -> 72 + | `Empty_identifier -> 73 end end | Error e -> ( diff --git a/src/parser/parse.ml b/src/parser/parse.ml index 09fe74d9c..860c29860 100644 --- a/src/parser/parse.ml +++ b/src/parser/parse.ml @@ -336,13 +336,15 @@ struct in try Ok (parser provider) with | Types.Parse_fail msg -> Error (`Parse_fail msg) + | Text_lexer.Empty_annotation_id -> Error `Empty_annotation_id + | Text_lexer.Empty_identifier -> Error `Empty_identifier | Text_lexer.Illegal_escape msg -> Error (`Illegal_escape msg) + | Text_lexer.Illegal_character msg -> Error (`Lexer_illegal_character msg) | Text_lexer.Unknown_operator msg -> Error (`Lexer_unknown_operator msg) - | Text_lexer.Unexpected_character msg -> - Error (`Lexer_unknown_operator msg) | Text_parser.Error -> let tok = Text_lexer.token buf |> token_to_string in Error (`Unexpected_token tok) + | Sedlexing.MalFormed -> Error (`Malformed_utf8_encoding "") let from_file filename = let open Syntax in diff --git a/src/parser/text_lexer.ml b/src/parser/text_lexer.ml index ba009afdf..5c7ec4caa 100644 --- a/src/parser/text_lexer.ml +++ b/src/parser/text_lexer.ml @@ -5,11 +5,19 @@ open Sedlexing open Text_parser +exception Empty_annotation_id + +exception Empty_identifier + +exception Illegal_character of string + exception Illegal_escape of string exception Unknown_operator of string -exception Unexpected_character of string +let illegal_character buf = + let tok = Utf8.lexeme buf in + raise @@ Illegal_character (Fmt.str "illegal character %S" tok) let illegal_escape buf = let tok = Utf8.lexeme buf in @@ -19,10 +27,6 @@ let unknown_operator buf = let tok = Utf8.lexeme buf in raise @@ Unknown_operator (Fmt.str "unknown operator %S" tok) -let unexpected_character buf = - let tok = Utf8.lexeme buf in - raise @@ Unexpected_character (Fmt.str "unexpected character `%S`" tok) - let mk_string buf s = let b = Buffer.create (String.length s) in let i = ref 0 in @@ -449,7 +453,7 @@ let rec token buf = let annotid = Utf8.lexeme buf in let annotid = String.sub annotid 3 (String.length annotid - 4) in let annotid = mk_string buf annotid in - if String.equal "" annotid then Log.err "empty annotation id" + if String.equal "" annotid then raise Empty_annotation_id else let items = Sexp.List (annot buf) in Annot.(record_annot annotid items); @@ -461,7 +465,7 @@ let rec token buf = let items = Sexp.List (annot buf) in Annot.(record_annot annotid items); token buf - | "(@" -> Log.err "empty annotation id" + | "(@" -> raise Empty_annotation_id (* 1 *) | "(" -> LPAR | ")" -> RPAR @@ -471,6 +475,7 @@ let rec token buf = let id = Utf8.lexeme buf in let id = String.sub id 1 (String.length id - 1) in ID id + | "$" -> raise Empty_identifier | name -> let name = Utf8.lexeme buf in let name = String.sub name 1 (String.length name - 2) in @@ -478,8 +483,8 @@ let rec token buf = NAME name | eof -> EOF (* | "" -> EOF *) - | any -> unexpected_character buf - | _ -> unexpected_character buf + | any -> unknown_operator buf + | _ -> unknown_operator buf and comment buf = match%sedlex buf with @@ -515,6 +520,7 @@ and annot buf = let annot_atom = Utf8.lexeme buf in Sexp.Atom annot_atom :: annot buf | eof -> Log.err "eof in annotation" - | _ -> unexpected_character buf + | any -> illegal_character buf + | _ -> illegal_character buf let lexer buf = Sedlexing.with_tokenizer token buf diff --git a/src/parser/text_lexer.mli b/src/parser/text_lexer.mli index 33fd53f74..9a6f6aef0 100644 --- a/src/parser/text_lexer.mli +++ b/src/parser/text_lexer.mli @@ -5,11 +5,15 @@ (** Module for Wasm lexing. *) (** lexing error exception *) +exception Empty_annotation_id + +exception Empty_identifier + exception Illegal_escape of string exception Unknown_operator of string -exception Unexpected_character of string +exception Illegal_character of string (** tokenizer *) val token : Sedlexing.lexbuf -> Text_parser.token diff --git a/src/utils/result.ml b/src/utils/result.ml index 8eaf59aac..a81d7c832 100644 --- a/src/utils/result.ml +++ b/src/utils/result.ml @@ -28,6 +28,7 @@ type err = | `Incompatible_import_type | `Inline_function_type | `Invalid_result_arity + | `Lexer_illegal_character of string | `Lexer_unknown_operator of string | `Malformed_utf8_encoding of string | `Memory_size_too_large @@ -75,6 +76,8 @@ type err = | `Spec_unknown_term of Sexp.t | `Spec_type_error of string | `Contract_unknown_func of Types.text Types.indice + | `Empty_annotation_id + | `Empty_identifier ] type 'a t = ('a, err) Prelude.Result.t @@ -107,7 +110,8 @@ let rec err_to_string = function | `Incompatible_import_type -> "incompatible import type" | `Inline_function_type -> "inline function type" | `Invalid_result_arity -> "invalid result arity" - | `Lexer_unknown_operator op -> Fmt.str "unknown operator %s" op + | `Lexer_illegal_character c -> Fmt.str "%s" c + | `Lexer_unknown_operator op -> Fmt.str "%s" op | `Malformed_utf8_encoding txt -> Fmt.str "malformed UTF-8 encoding %S" txt | `Memory_size_too_large -> "memory size must be at most 65536 pages (4GiB)" | `Msg msg -> msg @@ -163,3 +167,5 @@ let rec err_to_string = function | `Spec_type_error str -> Fmt.str "spec: %S type error" str | `Contract_unknown_func id -> Fmt.str "contract: unknown function %a" Types.pp_indice id + | `Empty_annotation_id -> Fmt.str "empty annotation id" + | `Empty_identifier -> Fmt.str "empty identifier" diff --git a/src/utils/result.mli b/src/utils/result.mli index 41856833e..b25aaeb5d 100644 --- a/src/utils/result.mli +++ b/src/utils/result.mli @@ -28,6 +28,7 @@ type err = | `Incompatible_import_type | `Inline_function_type | `Invalid_result_arity + | `Lexer_illegal_character of string | `Lexer_unknown_operator of string | `Malformed_utf8_encoding of string | `Memory_size_too_large @@ -75,6 +76,8 @@ type err = | `Spec_unknown_term of Sexp.t | `Spec_type_error of string | `Contract_unknown_func of Types.text Types.indice + | `Empty_annotation_id + | `Empty_identifier ] type 'a t = ('a, err) Prelude.Result.t diff --git a/test/script/gc.t b/test/script/gc.t index fd24894f8..c70b5be10 100644 --- a/test/script/gc.t +++ b/test/script/gc.t @@ -21,7 +21,7 @@ [23] $ owi script --no-exhaustion reference/proposals/gc/ref_eq.wast owi: internal error, uncaught exception: - File "src/ast/types.ml", line 923, characters 12-18: Assertion failed + File "src/ast/types.ml", line 930, characters 12-18: Assertion failed [125] $ owi script --no-exhaustion reference/proposals/gc/ref_test.wast diff --git a/test/script/reference b/test/script/reference index 9df2c8a23..5741d6c51 160000 --- a/test/script/reference +++ b/test/script/reference @@ -1 +1 @@ -Subproject commit 9df2c8a23c4d2f889c2c1a62e5fb9b744579efc5 +Subproject commit 5741d6c5172866174fde27c6b5447af757528d1a From ebf9a50ed739092fd825ba036fb24ce4d68a3442 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Wed, 21 Aug 2024 14:35:05 +0200 Subject: [PATCH 34/51] make rac a subcommand of owi --- src/ast/binary_encoder.mli | 1 - src/ast/code_generator.ml | 14 +++--- src/ast/code_generator.mli | 2 +- src/ast/compile.ml | 88 +++++++++++--------------------------- src/ast/compile.mli | 48 ++------------------- src/bin/owi.ml | 29 +++++++------ src/cmd/cmd_c.ml | 2 +- src/cmd/cmd_conc.ml | 18 +++----- src/cmd/cmd_conc.mli | 1 - src/cmd/cmd_opt.ml | 4 +- src/cmd/cmd_rac.ml | 28 ++++++++++++ src/cmd/cmd_rac.mli | 5 +++ src/cmd/cmd_run.ml | 8 ++-- src/cmd/cmd_run.mli | 2 +- src/cmd/cmd_script.ml | 4 +- src/cmd/cmd_script.mli | 2 +- src/cmd/cmd_sym.ml | 7 ++- src/cmd/cmd_sym.mli | 1 - src/cmd/cmd_validate.ml | 10 ++--- src/cmd/cmd_validate.mli | 2 +- src/dune | 1 + src/script/script.ml | 24 +++++------ src/script/script.mli | 7 +-- 23 files changed, 124 insertions(+), 184 deletions(-) create mode 100644 src/cmd/cmd_rac.ml create mode 100644 src/cmd/cmd_rac.mli diff --git a/src/ast/binary_encoder.mli b/src/ast/binary_encoder.mli index 1c3b68471..494008907 100644 --- a/src/ast/binary_encoder.mli +++ b/src/ast/binary_encoder.mli @@ -6,7 +6,6 @@ val convert : Fpath.t option -> Fpath.t -> unsafe:bool - -> rac:bool -> optimize:bool -> Text.modul -> (unit, Result.err) result diff --git a/src/ast/code_generator.ml b/src/ast/code_generator.ml index d54d4c3dc..30f1468b7 100644 --- a/src/ast/code_generator.ml +++ b/src/ast/code_generator.ml @@ -582,11 +582,9 @@ let add_owi_funcs (m : modul) : modul * (string * int) list = in update_func () -let generate (enabled : bool) (m : modul) : modul Result.t = - if not enabled then Ok m - else - let m, owi_funcs = add_owi_funcs m in - contracts_generate owi_funcs m - (List.filter_map - (function From_annot (Annot.Contract c) -> Some c | _ -> None) - m.custom ) +let generate (m : modul) : modul Result.t = + let m, owi_funcs = add_owi_funcs m in + contracts_generate owi_funcs m + (List.filter_map + (function From_annot (Annot.Contract c) -> Some c | _ -> None) + m.custom ) diff --git a/src/ast/code_generator.mli b/src/ast/code_generator.mli index 2f4eca1c1..1d7c48d81 100644 --- a/src/ast/code_generator.mli +++ b/src/ast/code_generator.mli @@ -2,4 +2,4 @@ (* Copyright © 2021-2024 OCamlPro *) (* Written by the Owi programmers *) -val generate : bool -> Binary.modul -> Binary.modul Result.t +val generate : Binary.modul -> Binary.modul Result.t diff --git a/src/ast/compile.ml b/src/ast/compile.ml index 330143cac..043e4c56b 100644 --- a/src/ast/compile.ml +++ b/src/ast/compile.ml @@ -20,132 +20,96 @@ module Text = struct let* m = until_assign ~unsafe m in Rewrite.modul m -<<<<<<< HEAD let until_binary_validate ~unsafe m = -======= - let until_typecheck ~unsafe ~rac m = ->>>>>>> 66d816d7 (framework for rac code generation) let* m = until_binary ~unsafe m in - let* m = Code_generator.generate rac m in if unsafe then Ok m else let+ () = Binary_validate.modul m in m -<<<<<<< HEAD let until_optimize ~unsafe ~optimize m = let+ m = until_binary_validate ~unsafe m in -======= - let until_optimize ~unsafe ~rac ~optimize m = - let+ m = until_typecheck ~unsafe ~rac m in ->>>>>>> 66d816d7 (framework for rac code generation) if optimize then Optimize.modul m else m - let until_link ~unsafe ~rac ~optimize ~name link_state m = - let* m = until_optimize ~unsafe ~rac ~optimize m in + let until_link ~unsafe ~optimize ~name link_state m = + let* m = until_optimize ~unsafe ~optimize m in Link.modul link_state ~name m - let until_interpret ~unsafe ~rac ~optimize ~name link_state m = - let* m, link_state = until_link ~unsafe ~rac ~optimize ~name link_state m in + let until_interpret ~unsafe ~optimize ~name link_state m = + let* m, link_state = until_link ~unsafe ~optimize ~name link_state m in let+ () = Interpret.Concrete.modul link_state.envs m in link_state end module Binary = struct -<<<<<<< HEAD let until_binary_validate ~unsafe m = -======= - let until_typecheck ~unsafe ~rac m = - let* m = Code_generator.generate rac m in ->>>>>>> 66d816d7 (framework for rac code generation) if unsafe then Ok m else let+ () = Binary_validate.modul m in m -<<<<<<< HEAD let until_optimize ~unsafe ~optimize m = let+ m = until_binary_validate ~unsafe m in -======= - let until_optimize ~unsafe ~rac ~optimize m = - let+ m = until_typecheck ~unsafe ~rac m in ->>>>>>> 66d816d7 (framework for rac code generation) if optimize then Optimize.modul m else m - let until_link ~unsafe ~rac ~optimize ~name link_state m = - let* m = until_optimize ~unsafe ~rac ~optimize m in + let until_link ~unsafe ~optimize ~name link_state m = + let* m = until_optimize ~unsafe ~optimize m in Link.modul link_state ~name m - let until_interpret ~unsafe ~rac ~optimize ~name link_state m = - let* m, link_state = until_link ~unsafe ~rac ~optimize ~name link_state m in + let until_interpret ~unsafe ~optimize ~name link_state m = + let* m, link_state = until_link ~unsafe ~optimize ~name link_state m in let+ () = Interpret.Concrete.modul link_state.envs m in link_state end module Any = struct -<<<<<<< HEAD let until_binary_validate ~unsafe = function | Kind.Wat m -> Text.until_binary_validate ~unsafe m | Wasm m -> Binary.until_binary_validate ~unsafe m -======= - let until_typecheck ~unsafe ~rac = function - | Kind.Wat m -> Text.until_typecheck ~unsafe ~rac m - | Wasm m -> Binary.until_typecheck ~unsafe ~rac m ->>>>>>> 66d816d7 (framework for rac code generation) | Wast _ | Ocaml _ -> assert false - let until_optimize ~unsafe ~rac ~optimize = function - | Kind.Wat m -> Text.until_optimize ~unsafe ~rac ~optimize m - | Wasm m -> Binary.until_optimize ~unsafe ~rac ~optimize m + let until_optimize ~unsafe ~optimize = function + | Kind.Wat m -> Text.until_optimize ~unsafe ~optimize m + | Wasm m -> Binary.until_optimize ~unsafe ~optimize m | Wast _ | Ocaml _ -> assert false - let until_link ~unsafe ~rac ~optimize ~name link_state = function - | Kind.Wat m -> Text.until_link ~unsafe ~rac ~optimize ~name link_state m - | Wasm m -> Binary.until_link ~unsafe ~rac ~optimize ~name link_state m + let until_link ~unsafe ~optimize ~name link_state = function + | Kind.Wat m -> Text.until_link ~unsafe ~optimize ~name link_state m + | Wasm m -> Binary.until_link ~unsafe ~optimize ~name link_state m | Wast _ | Ocaml _ -> assert false - let until_interpret ~unsafe ~rac ~optimize ~name link_state = function - | Kind.Wat m -> - Text.until_interpret ~unsafe ~rac ~optimize ~name link_state m - | Wasm m -> Binary.until_interpret ~unsafe ~rac ~optimize ~name link_state m + let until_interpret ~unsafe ~optimize ~name link_state = function + | Kind.Wat m -> Text.until_interpret ~unsafe ~optimize ~name link_state m + | Wasm m -> Binary.until_interpret ~unsafe ~optimize ~name link_state m | Wast _ | Ocaml _ -> assert false end module File = struct -<<<<<<< HEAD let until_binary_validate ~unsafe filename = let* m = Parse.guess_from_file filename in match m with | Kind.Wat m -> Text.until_binary_validate ~unsafe m | Wasm m -> Binary.until_binary_validate ~unsafe m -======= - let until_typecheck ~unsafe ~rac filename = - let* m = Parse.guess_from_file filename in - match m with - | Kind.Wat m -> Text.until_typecheck ~unsafe ~rac m - | Wasm m -> Binary.until_typecheck ~unsafe ~rac m ->>>>>>> 66d816d7 (framework for rac code generation) | Wast _ | Ocaml _ -> assert false - let until_optimize ~unsafe ~rac ~optimize filename = + let until_optimize ~unsafe ~optimize filename = let* m = Parse.guess_from_file filename in match m with - | Kind.Wat m -> Text.until_optimize ~unsafe ~rac ~optimize m - | Wasm m -> Binary.until_optimize ~unsafe ~rac ~optimize m + | Kind.Wat m -> Text.until_optimize ~unsafe ~optimize m + | Wasm m -> Binary.until_optimize ~unsafe ~optimize m | Wast _ | Ocaml _ -> assert false - let until_link ~unsafe ~rac ~optimize ~name link_state filename = + let until_link ~unsafe ~optimize ~name link_state filename = let* m = Parse.guess_from_file filename in match m with - | Kind.Wat m -> Text.until_link ~unsafe ~rac ~optimize ~name link_state m - | Wasm m -> Binary.until_link ~unsafe ~rac ~optimize ~name link_state m + | Kind.Wat m -> Text.until_link ~unsafe ~optimize ~name link_state m + | Wasm m -> Binary.until_link ~unsafe ~optimize ~name link_state m | Wast _ | Ocaml _ -> assert false - let until_interpret ~unsafe ~rac ~optimize ~name link_state filename = + let until_interpret ~unsafe ~optimize ~name link_state filename = let* m = Parse.guess_from_file filename in match m with - | Kind.Wat m -> - Text.until_interpret ~unsafe ~rac ~optimize ~name link_state m - | Wasm m -> Binary.until_interpret ~unsafe ~rac ~optimize ~name link_state m + | Kind.Wat m -> Text.until_interpret ~unsafe ~optimize ~name link_state m + | Wasm m -> Binary.until_interpret ~unsafe ~optimize ~name link_state m | Wast _ | Ocaml _ -> assert false end diff --git a/src/ast/compile.mli b/src/ast/compile.mli index a755336f6..0bfa84106 100644 --- a/src/ast/compile.mli +++ b/src/ast/compile.mli @@ -5,26 +5,16 @@ (** Utility functions to compile a module until a given step. *) module Any : sig -<<<<<<< HEAD val until_binary_validate : unsafe:bool -> 'extern_func Kind.t -> Binary.modul Result.t -======= - val until_typecheck : - unsafe:bool -> rac:bool -> 'extern_func Kind.t -> Binary.modul Result.t ->>>>>>> 66d816d7 (framework for rac code generation) val until_optimize : - unsafe:bool - -> rac:bool - -> optimize:bool - -> 'extern_func Kind.t - -> Binary.modul Result.t + unsafe:bool -> optimize:bool -> 'extern_func Kind.t -> Binary.modul Result.t (** compile a module with a given link state and produce a new link state and a runnable module *) val until_link : unsafe:bool - -> rac:bool -> optimize:bool -> name:string option -> 'extern_func Link.state @@ -35,7 +25,6 @@ module Any : sig link state *) val until_interpret : unsafe:bool - -> rac:bool -> optimize:bool -> name:string option -> Concrete_value.Func.extern_func Link.state @@ -44,21 +33,15 @@ module Any : sig end module File : sig -<<<<<<< HEAD val until_binary_validate : unsafe:bool -> Fpath.t -> Binary.modul Result.t -======= - val until_typecheck : - unsafe:bool -> rac:bool -> Fpath.t -> Binary.modul Result.t ->>>>>>> 66d816d7 (framework for rac code generation) val until_optimize : - unsafe:bool -> rac:bool -> optimize:bool -> Fpath.t -> Binary.modul Result.t + unsafe:bool -> optimize:bool -> Fpath.t -> Binary.modul Result.t (** compile a file with a given link state and produce a new link state and a runnable module *) val until_link : unsafe:bool - -> rac:bool -> optimize:bool -> name:string option -> 'extern_func Link.state @@ -69,7 +52,6 @@ module File : sig link state *) val until_interpret : unsafe:bool - -> rac:bool -> optimize:bool -> name:string option -> Concrete_value.Func.extern_func Link.state @@ -82,25 +64,15 @@ module Text : sig val until_binary : unsafe:bool -> Text.modul -> Binary.modul Result.t -<<<<<<< HEAD val until_binary_validate : unsafe:bool -> Text.modul -> Binary.modul Result.t -======= - val until_typecheck : - unsafe:bool -> rac:bool -> Text.modul -> Binary.modul Result.t ->>>>>>> 66d816d7 (framework for rac code generation) val until_optimize : - unsafe:bool - -> rac:bool - -> optimize:bool - -> Text.modul - -> Binary.modul Result.t + unsafe:bool -> optimize:bool -> Text.modul -> Binary.modul Result.t (** compile a module with a given link state and produce a new link state and a runnable module *) val until_link : unsafe:bool - -> rac:bool -> optimize:bool -> name:string option -> 'f Link.state @@ -111,7 +83,6 @@ module Text : sig link state *) val until_interpret : unsafe:bool - -> rac:bool -> optimize:bool -> name:string option -> Concrete_value.Func.extern_func Link.state @@ -120,26 +91,16 @@ module Text : sig end module Binary : sig -<<<<<<< HEAD val until_binary_validate : unsafe:bool -> Binary.modul -> Binary.modul Result.t -======= - val until_typecheck : - unsafe:bool -> rac:bool -> Binary.modul -> Binary.modul Result.t ->>>>>>> 66d816d7 (framework for rac code generation) val until_optimize : - unsafe:bool - -> rac:bool - -> optimize:bool - -> Binary.modul - -> Binary.modul Result.t + unsafe:bool -> optimize:bool -> Binary.modul -> Binary.modul Result.t (** compile a module with a given link state and produce a new link state and a runnable module *) val until_link : unsafe:bool - -> rac:bool -> optimize:bool -> name:string option -> 'f Link.state @@ -150,7 +111,6 @@ module Binary : sig link state *) val until_interpret : unsafe:bool - -> rac:bool -> optimize:bool -> name:string option -> Concrete_value.Func.extern_func Link.state diff --git a/src/bin/owi.ml b/src/bin/owi.ml index 87f2285f3..daf00c5cb 100644 --- a/src/bin/owi.ml +++ b/src/bin/owi.ml @@ -122,10 +122,6 @@ let workspace = Cmdliner.Arg.( value & opt dir_file (Fpath.v "owi-out") & info [ "workspace" ] ~doc ) -let rac = - let doc = "runtime assertion checking mode" in - Cmdliner.Arg.(value & flag & info [ "rac" ] ~doc) - let copts_t = Cmdliner.Term.(const []) let sdocs = Cmdliner.Manpage.s_common_options @@ -202,6 +198,15 @@ let opt_cmd = in Cmd.v info Term.(const Cmd_opt.cmd $ debug $ unsafe $ sourcefile $ outfile) +let rac_cmd = + let open Cmdliner in + let info = + let doc = "Perform runtime assertion checking" in + let man = [] @ shared_man in + Cmd.info "rac" ~version ~doc ~sdocs ~man + in + Cmd.v info Term.(const Cmd_rac.cmd $ unsafe $ files) + let run_cmd = let open Cmdliner in let info = @@ -210,8 +215,7 @@ let run_cmd = Cmd.info "run" ~version ~doc ~sdocs ~man in Cmd.v info - Term.( - const Cmd_run.cmd $ profiling $ debug $ unsafe $ rac $ optimize $ files ) + Term.(const Cmd_run.cmd $ profiling $ debug $ unsafe $ optimize $ files) let validate_cmd = let open Cmdliner in @@ -220,7 +224,7 @@ let validate_cmd = let man = [] @ shared_man in Cmd.info "validate" ~version ~doc ~sdocs ~man in - Cmd.v info Term.(const Cmd_validate.cmd $ debug $ rac $ files) + Cmd.v info Term.(const Cmd_validate.cmd $ debug $ files) let script_cmd = let open Cmdliner in @@ -231,7 +235,7 @@ let script_cmd = in Cmd.v info Term.( - const Cmd_script.cmd $ profiling $ debug $ rac $ optimize $ files + const Cmd_script.cmd $ profiling $ debug $ optimize $ files $ no_exhaustion ) let sym_cmd = @@ -244,8 +248,8 @@ let sym_cmd = Cmd.v info Term.( const Cmd_sym.cmd $ profiling $ debug $ unsafe $ optimize $ workers - $ no_stop_at_failure $ no_values $ deterministic_result_order $ rac - $ fail_mode $ workspace $ solver $ files ) + $ no_stop_at_failure $ no_values $ deterministic_result_order $ fail_mode + $ workspace $ solver $ files ) let conc_cmd = let open Cmdliner in @@ -257,8 +261,8 @@ let conc_cmd = Cmd.v info Term.( const Cmd_conc.cmd $ profiling $ debug $ unsafe $ optimize $ workers - $ no_stop_at_failure $ no_values $ deterministic_result_order $ rac - $ fail_mode $ workspace $ solver $ files ) + $ no_stop_at_failure $ no_values $ deterministic_result_order $ fail_mode + $ workspace $ solver $ files ) let wasm2wat_cmd = let open Cmdliner in @@ -300,6 +304,7 @@ let cli = [ c_cmd ; fmt_cmd ; opt_cmd + ; rac_cmd ; run_cmd ; script_cmd ; sym_cmd diff --git a/src/cmd/cmd_c.ml b/src/cmd/cmd_c.ml index 8fa8de721..e719a3dc4 100644 --- a/src/cmd/cmd_c.ml +++ b/src/cmd/cmd_c.ml @@ -196,4 +196,4 @@ let cmd debug arch property _testcomp workspace workers opt_lvl includes files let files = [ modul ] in (if concolic then Cmd_conc.cmd else Cmd_sym.cmd) profiling debug unsafe optimize workers no_stop_at_failure no_values - deterministic_result_order false fail_mode workspace solver files + deterministic_result_order fail_mode workspace solver files diff --git a/src/cmd/cmd_conc.ml b/src/cmd/cmd_conc.ml index 385fd532f..805a47ed1 100644 --- a/src/cmd/cmd_conc.ml +++ b/src/cmd/cmd_conc.ml @@ -16,26 +16,21 @@ let ( let** ) (t : 'a Result.t Choice.t) (f : 'a -> 'b Result.t Choice.t) : Choice.bind t (fun t -> match t with Error e -> Choice.return (Error e) | Ok x -> f x ) -let simplify_then_link ~unsafe ~optimize ~rac link_state m = +let simplify_then_link ~unsafe ~optimize link_state m = let* m = match m with -<<<<<<< HEAD | Kind.Wat _ | Wasm _ -> Compile.Any.until_binary_validate ~unsafe m -======= - | Kind.Wat _ | Wasm _ -> Compile.Any.until_typecheck ~unsafe ~rac m ->>>>>>> 66d816d7 (framework for rac code generation) | Wast _ -> Error (`Msg "can't run concolic interpreter on a script") | Ocaml _ -> assert false in let* m = Cmd_utils.add_main_as_start m in let+ m, link_state = - Compile.Binary.until_link ~unsafe ~rac:false ~optimize ~name:None link_state - m + Compile.Binary.until_link ~unsafe ~optimize ~name:None link_state m in let module_to_run = Concolic.convert_module_to_run m in (link_state, module_to_run) -let simplify_then_link_files ~unsafe ~optimize ~rac filenames = +let simplify_then_link_files ~unsafe ~optimize filenames = let link_state = Link.empty_state in let link_state = Link.extern_module' link_state ~name:"symbolic" @@ -53,7 +48,7 @@ let simplify_then_link_files ~unsafe ~optimize ~rac filenames = let* link_state, modules_to_run = acc in let* m0dule = Parse.guess_from_file filename in let+ link_state, module_to_run = - simplify_then_link ~unsafe ~optimize ~rac link_state m0dule + simplify_then_link ~unsafe ~optimize link_state m0dule in (link_state, module_to_run :: modules_to_run) ) (Ok (link_state, [])) @@ -420,8 +415,7 @@ let run solver tree link_state modules_to_run = which are handled here. Most of the computations are done in the Result monad, hence the let*. *) let cmd profiling debug unsafe optimize _workers _no_stop_at_failure no_values - _deterministic_result_order rac _fail_mode (workspace : Fpath.t) solver files - = + _deterministic_result_order _fail_mode (workspace : Fpath.t) solver files = if profiling then Log.profiling_on := true; if debug then Log.debug_on := true; (* deterministic_result_order implies no_stop_at_failure *) @@ -429,7 +423,7 @@ let cmd profiling debug unsafe optimize _workers _no_stop_at_failure no_values let* _created_dir = Bos.OS.Dir.create ~path:true ~mode:0o755 workspace in let solver = Solver.fresh solver () in let* link_state, modules_to_run = - simplify_then_link_files ~unsafe ~optimize ~rac files + simplify_then_link_files ~unsafe ~optimize files in let tree = fresh_tree [] in let* result = run solver tree link_state modules_to_run in diff --git a/src/cmd/cmd_conc.mli b/src/cmd/cmd_conc.mli index d80f29826..5d841000a 100644 --- a/src/cmd/cmd_conc.mli +++ b/src/cmd/cmd_conc.mli @@ -11,7 +11,6 @@ val cmd : -> bool -> bool -> bool - -> bool -> Cmd_sym.fail_mode -> Fpath.t -> Smtml.Solver_dispatcher.solver_type diff --git a/src/cmd/cmd_opt.ml b/src/cmd/cmd_opt.ml index d70838898..95ff24af6 100644 --- a/src/cmd/cmd_opt.ml +++ b/src/cmd/cmd_opt.ml @@ -4,8 +4,8 @@ open Syntax -let optimize_file ~unsafe ~rac filename = - Compile.File.until_optimize ~unsafe ~rac ~optimize:true filename +let optimize_file ~unsafe filename = + Compile.File.until_optimize ~unsafe ~optimize:true filename let print_or_emit ~unsafe file outfile = let* m = optimize_file ~unsafe file in diff --git a/src/cmd/cmd_rac.ml b/src/cmd/cmd_rac.ml new file mode 100644 index 000000000..a5210e947 --- /dev/null +++ b/src/cmd/cmd_rac.ml @@ -0,0 +1,28 @@ +(* SPDX-License-Identifier: AGPL-3.0-or-later *) +(* Copyright © 2021-2024 OCamlPro *) +(* Written by the Owi programmers *) + +open Syntax + +let cmd_one unsafe file = + let _dir, filename = Fpath.split_base file in + let filename, ext = Fpath.split_ext filename in + match ext with + | ".wat" -> + let* text_modul = Parse.Text.Module.from_file file in + let* binary_modul = Compile.Text.until_binary ~unsafe text_modul in + let+ instrumented_binary_modul = Code_generator.generate binary_modul in + let instrumented_text_modul = + Binary_to_text.modul instrumented_binary_modul + in + + let content = Fmt.str "%a" Text.pp_modul instrumented_text_modul in + let filename = Fpath.add_ext ".instrumented" filename in + let filename = Fpath.add_ext ".wat" filename in + let filename = Fpath.to_string filename in + let oc = Out_channel.open_bin filename in + Out_channel.output_string oc content; + Out_channel.close oc + | ext -> Error (`Unsupported_file_extension ext) + +let cmd unsafe files = list_iter (cmd_one unsafe) files diff --git a/src/cmd/cmd_rac.mli b/src/cmd/cmd_rac.mli new file mode 100644 index 000000000..433a95470 --- /dev/null +++ b/src/cmd/cmd_rac.mli @@ -0,0 +1,5 @@ +(* SPDX-License-Identifier: AGPL-3.0-or-later *) +(* Copyright © 2021-2024 OCamlPro *) +(* Written by the Owi programmers *) + +val cmd : bool -> Fpath.t list -> unit Result.t diff --git a/src/cmd/cmd_run.ml b/src/cmd/cmd_run.ml index abf51ce5b..689dc2e65 100644 --- a/src/cmd/cmd_run.ml +++ b/src/cmd/cmd_run.ml @@ -4,15 +4,15 @@ open Syntax -let run_file ~unsafe ~rac ~optimize filename = +let run_file ~unsafe ~optimize filename = let name = None in let+ (_ : _ Link.state) = - Compile.File.until_interpret ~unsafe ~rac ~optimize ~name Link.empty_state + Compile.File.until_interpret ~unsafe ~optimize ~name Link.empty_state filename in () -let cmd profiling debug unsafe rac optimize files = +let cmd profiling debug unsafe optimize files = if profiling then Log.profiling_on := true; if debug then Log.debug_on := true; - list_iter (run_file ~unsafe ~rac ~optimize) files + list_iter (run_file ~unsafe ~optimize) files diff --git a/src/cmd/cmd_run.mli b/src/cmd/cmd_run.mli index 63aec0acf..5cef2e0c3 100644 --- a/src/cmd/cmd_run.mli +++ b/src/cmd/cmd_run.mli @@ -2,4 +2,4 @@ (* Copyright © 2021-2024 OCamlPro *) (* Written by the Owi programmers *) -val cmd : bool -> bool -> bool -> bool -> bool -> Fpath.t list -> unit Result.t +val cmd : bool -> bool -> bool -> bool -> Fpath.t list -> unit Result.t diff --git a/src/cmd/cmd_script.ml b/src/cmd/cmd_script.ml index 4bf1be2da..30048a92c 100644 --- a/src/cmd/cmd_script.ml +++ b/src/cmd/cmd_script.ml @@ -8,8 +8,8 @@ let run_file exec filename = let* script = Parse.Text.Script.from_file filename in exec script -let cmd profiling debug rac optimize files no_exhaustion = - let exec = Script.exec ~rac ~no_exhaustion ~optimize in +let cmd profiling debug optimize files no_exhaustion = + let exec = Script.exec ~no_exhaustion ~optimize in if profiling then Log.profiling_on := true; if debug then Log.debug_on := true; list_iter (run_file exec) files diff --git a/src/cmd/cmd_script.mli b/src/cmd/cmd_script.mli index 60666d712..fe2dd1058 100644 --- a/src/cmd/cmd_script.mli +++ b/src/cmd/cmd_script.mli @@ -2,4 +2,4 @@ (* Copyright © 2021-2024 OCamlPro *) (* Written by the Owi programmers *) -val cmd : bool -> bool -> bool -> bool -> Fpath.t list -> bool -> unit Result.t +val cmd : bool -> bool -> bool -> Fpath.t list -> bool -> unit Result.t diff --git a/src/cmd/cmd_sym.ml b/src/cmd/cmd_sym.ml index 94cc37c94..8e445b41a 100644 --- a/src/cmd/cmd_sym.ml +++ b/src/cmd/cmd_sym.ml @@ -35,8 +35,7 @@ let run_file ~unsafe ~optimize pc filename = let link_state = Lazy.force link_state in let*/ m, link_state = - Compile.Binary.until_link ~unsafe ~rac:false ~optimize ~name:None link_state - m + Compile.Binary.until_link ~unsafe ~optimize ~name:None link_state m in let m = Symbolic.convert_module_to_run m in let c = Interpret.SymbolicP.modul link_state.envs m in @@ -48,14 +47,14 @@ let run_file ~unsafe ~optimize pc filename = which are handled here. Most of the computations are done in the Result monad, hence the let*. *) let cmd profiling debug unsafe optimize workers no_stop_at_failure no_values - deterministic_result_order rac fail_mode (workspace : Fpath.t) solver files = + deterministic_result_order fail_mode (workspace : Fpath.t) solver files = if profiling then Log.profiling_on := true; if debug then Log.debug_on := true; (* deterministic_result_order implies no_stop_at_failure *) let no_stop_at_failure = deterministic_result_order || no_stop_at_failure in let* _created_dir = Bos.OS.Dir.create ~path:true ~mode:0o755 workspace in let pc = Choice.return (Ok ()) in - let result = List.fold_left (run_file ~unsafe ~optimize ~rac) pc files in + let result = List.fold_left (run_file ~unsafe ~optimize) pc files in let thread = Thread_with_memory.init () in let res_queue = Wq.make () in let path_count = ref 0 in diff --git a/src/cmd/cmd_sym.mli b/src/cmd/cmd_sym.mli index abd26544f..938f1e343 100644 --- a/src/cmd/cmd_sym.mli +++ b/src/cmd/cmd_sym.mli @@ -17,7 +17,6 @@ val cmd : -> bool -> bool -> bool - -> bool -> fail_mode -> Fpath.t -> Smtml.Solver_dispatcher.solver_type diff --git a/src/cmd/cmd_validate.ml b/src/cmd/cmd_validate.ml index cd6daa6b4..53ca33445 100644 --- a/src/cmd/cmd_validate.ml +++ b/src/cmd/cmd_validate.ml @@ -4,16 +4,12 @@ open Syntax -let validate rac filename = +let validate filename = let+ (_modul : Binary.modul) = -<<<<<<< HEAD Compile.File.until_binary_validate ~unsafe:false filename -======= - Compile.File.until_typecheck ~unsafe:false ~rac filename ->>>>>>> 66d816d7 (framework for rac code generation) in () -let cmd debug rac files = +let cmd debug files = if debug then Log.debug_on := true; - list_iter (validate rac) files + list_iter validate files diff --git a/src/cmd/cmd_validate.mli b/src/cmd/cmd_validate.mli index b26bccd2a..433a95470 100644 --- a/src/cmd/cmd_validate.mli +++ b/src/cmd/cmd_validate.mli @@ -2,4 +2,4 @@ (* Copyright © 2021-2024 OCamlPro *) (* Written by the Owi programmers *) -val cmd : bool -> bool -> Fpath.t list -> unit Result.t +val cmd : bool -> Fpath.t list -> unit Result.t diff --git a/src/dune b/src/dune index b352e449d..b3ce4ec3b 100644 --- a/src/dune +++ b/src/dune @@ -17,6 +17,7 @@ cmd_c cmd_fmt cmd_opt + cmd_rac cmd_run cmd_script cmd_sym diff --git a/src/script/script.ml b/src/script/script.ml index 39b75dd5e..db8fa896a 100644 --- a/src/script/script.ml +++ b/src/script/script.ml @@ -141,7 +141,7 @@ let action (link_state : Concrete_value.Func.extern_func Link.state) = function let unsafe = false -let run ~no_exhaustion ~rac ~optimize script = +let run ~no_exhaustion ~optimize script = let state = Link.extern_module Link.empty_state ~name:"spectest_extern" Spectest.extern_m @@ -157,8 +157,7 @@ let run ~no_exhaustion ~rac ~optimize script = Log.debug0 "*** module@\n"; incr curr_module; let+ link_state = - Compile.Text.until_interpret link_state ~unsafe ~rac ~optimize - ~name:None m + Compile.Text.until_interpret link_state ~unsafe ~optimize ~name:None m in Log.debug_on := debug_on; link_state @@ -167,8 +166,7 @@ let run ~no_exhaustion ~rac ~optimize script = incr curr_module; let* m = Parse.Text.Inline_module.from_string m in let+ link_state = - Compile.Text.until_interpret link_state ~unsafe ~rac ~optimize - ~name:None m + Compile.Text.until_interpret link_state ~unsafe ~optimize ~name:None m in link_state | Text.Binary_module (id, m) -> @@ -177,15 +175,15 @@ let run ~no_exhaustion ~rac ~optimize script = let* m = Parse.Binary.Module.from_string m in let m = { m with id } in let+ link_state = - Compile.Binary.until_interpret link_state ~unsafe ~rac ~optimize - ~name:None m + Compile.Binary.until_interpret link_state ~unsafe ~optimize ~name:None + m in link_state | Assert (Assert_trap_module (m, expected)) -> Log.debug0 "*** assert_trap@\n"; incr curr_module; let* m, link_state = - Compile.Text.until_link link_state ~unsafe ~rac ~optimize ~name:None m + Compile.Text.until_link link_state ~unsafe ~optimize ~name:None m in let got = Interpret.Concrete.modul link_state.envs m in let+ () = check_error_result expected got in @@ -226,7 +224,7 @@ let run ~no_exhaustion ~rac ~optimize script = | Assert (Assert_invalid (m, expected)) -> Log.debug0 "*** assert_invalid@\n"; let got = - Compile.Text.until_link link_state ~unsafe ~rac ~optimize ~name:None m + Compile.Text.until_link link_state ~unsafe ~optimize ~name:None m in let+ () = check_error_result expected got in link_state @@ -238,14 +236,14 @@ let run ~no_exhaustion ~rac ~optimize script = | Assert (Assert_unlinkable (m, expected)) -> Log.debug0 "*** assert_unlinkable@\n"; let got = - Compile.Text.until_link link_state ~unsafe ~rac ~optimize ~name:None m + Compile.Text.until_link link_state ~unsafe ~optimize ~name:None m in let+ () = check_error_result expected got in link_state | Assert (Assert_malformed (m, expected)) -> Log.debug0 "*** assert_malformed@\n"; let got = - Compile.Text.until_link ~unsafe ~rac ~optimize ~name:None link_state m + Compile.Text.until_link ~unsafe ~optimize ~name:None link_state m in let+ () = check_error_result expected got in assert false @@ -288,6 +286,6 @@ let run ~no_exhaustion ~rac ~optimize script = link_state ) state script -let exec ~no_exhaustion ~rac ~optimize script = - let+ _link_state = run ~no_exhaustion ~rac ~optimize script in +let exec ~no_exhaustion ~optimize script = + let+ _link_state = run ~no_exhaustion ~optimize script in () diff --git a/src/script/script.mli b/src/script/script.mli index 08788491e..d3a86af8a 100644 --- a/src/script/script.mli +++ b/src/script/script.mli @@ -5,9 +5,4 @@ (** Module to execute a full Wasm script. *) (** execute a Wasm script *) -val exec : - no_exhaustion:bool - -> rac:bool - -> optimize:bool - -> Text.script - -> unit Result.t +val exec : no_exhaustion:bool -> optimize:bool -> Text.script -> unit Result.t From 4e9679512a392b70a515b1ddbda1cd405cbcdc55 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Wed, 21 Aug 2024 14:38:52 +0200 Subject: [PATCH 35/51] promote some tests --- example/README.md | 3 +++ test/help/help.t | 3 +++ test/script/gc.t | 16 ++++++++-------- 3 files changed, 14 insertions(+), 8 deletions(-) diff --git a/example/README.md b/example/README.md index 362e0eae8..6794930dc 100644 --- a/example/README.md +++ b/example/README.md @@ -41,6 +41,9 @@ COMMANDS opt [--debug] [--output=FILE] [--unsafe] [OPTION]… ARG Optimize a module + rac [--unsafe] [OPTION]… [ARG]… + Perform runtime assertion checking + run [OPTION]… [ARG]… Run the concrete interpreter diff --git a/test/help/help.t b/test/help/help.t index 8c2feab8b..f5f0e6009 100644 --- a/test/help/help.t +++ b/test/help/help.t @@ -19,6 +19,9 @@ no subcommand should print help opt [--debug] [--output=FILE] [--unsafe] [OPTION]… ARG Optimize a module + rac [--unsafe] [OPTION]… [ARG]… + Perform runtime assertion checking + run [OPTION]… [ARG]… Run the concrete interpreter diff --git a/test/script/gc.t b/test/script/gc.t index c70b5be10..7aa946edf 100644 --- a/test/script/gc.t +++ b/test/script/gc.t @@ -1,23 +1,23 @@ $ owi script --no-exhaustion reference/proposals/gc/array.wast - unknown operator unknown operator "array.get_s" + unknown operator "array.get_s" [23] $ owi script --no-exhaustion reference/proposals/gc/br_on_cast_fail.wast - unknown operator unknown operator "any.convert_extern" + unknown operator "any.convert_extern" [23] $ owi script --no-exhaustion reference/proposals/gc/br_on_cast.wast - unknown operator unknown operator "any.convert_extern" + unknown operator "any.convert_extern" [23] $ owi script --no-exhaustion reference/proposals/gc/call_ref.wast unknown type $ii [52] $ owi script --no-exhaustion reference/proposals/gc/extern.wast - unknown operator unknown operator "any.convert_extern" + unknown operator "any.convert_extern" [23] $ owi script --no-exhaustion reference/proposals/gc/i31.wast - unknown operator unknown operator "i31ref" + unknown operator "i31ref" [23] $ owi script --no-exhaustion reference/proposals/gc/ref_cast.wast - unknown operator unknown operator "any.convert_extern" + unknown operator "any.convert_extern" [23] $ owi script --no-exhaustion reference/proposals/gc/ref_eq.wast owi: internal error, uncaught exception: @@ -25,13 +25,13 @@ [125] $ owi script --no-exhaustion reference/proposals/gc/ref_test.wast - unknown operator unknown operator "any.convert_extern" + unknown operator "any.convert_extern" [23] $ owi script --no-exhaustion reference/proposals/gc/return_call_ref.wast unknown type $i64-i64 [52] $ owi script --no-exhaustion reference/proposals/gc/struct.wast - unknown operator unknown operator "struct.get_u" + unknown operator "struct.get_u" [23] $ owi script --no-exhaustion reference/proposals/gc/type-subtyping.wast unexpected token "ref" From 77d18842511126538f7ec505226819b1ceef9fc7 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Wed, 21 Aug 2024 16:04:22 +0200 Subject: [PATCH 36/51] add 'unclosed annotation', 'unclosed comment' and 'unclosed string' --- src/ast/code_generator.ml | 158 +++++++++++++++++--------------------- src/bin/owi.ml | 3 + src/parser/parse.ml | 3 + src/parser/text_lexer.ml | 22 ++++-- src/parser/text_lexer.mli | 10 ++- src/utils/result.ml | 6 ++ src/utils/result.mli | 3 + 7 files changed, 109 insertions(+), 96 deletions(-) diff --git a/src/ast/code_generator.ml b/src/ast/code_generator.ml index 30f1468b7..8389297de 100644 --- a/src/ast/code_generator.ml +++ b/src/ast/code_generator.ml @@ -7,73 +7,49 @@ open Binary open Spec open Syntax -let type_env (m : modul) (func_ty : binary param_type * binary result_type) - (owi_funcs : (string * int) list) = - object - val param_types : binary val_type list = List.map snd (fst func_ty) - - val global_types : binary val_type list = - let sorted_global_types = - List.sort - (fun x y -> compare (Indexed.get_index x) (Indexed.get_index y)) - m.global.values - in - List.map - (fun (x : (global, binary global_type) Runtime.t Indexed.t) -> - match Indexed.get x with - | Runtime.Local { typ = _, gt; _ } -> gt - | Runtime.Imported { desc = _, gt; _ } -> gt ) - sorted_global_types - - val result_types : binary val_type list = snd func_ty - - val param_number : int = List.length (fst func_ty) - - val result_number : int = List.length (snd func_ty) - - val owi_i32 : int = List.assoc "i32_symbol" owi_funcs - - val owi_i64 : int = List.assoc "i64_symbol" owi_funcs - - val owi_f32 : int = List.assoc "f32_symbol" owi_funcs - - val owi_f64 : int = List.assoc "f64_symbol" owi_funcs - - val owi_assume : int = List.assoc "assume" owi_funcs - - val owi_assert : int = List.assoc "assert" owi_funcs - - method get_param_type (Raw i : binary indice) : binary val_type option = - List.nth_opt param_types i - - method get_global_type (Raw i : binary indice) : binary val_type option = - List.nth_opt global_types i - - method get_binder_type_and_index (Raw _i : binary indice) - : (binary indice * binary val_type) option = - None (* TODO *) - - method get_result_type (i : int) : binary val_type option = - List.nth_opt result_types i - - method get_param_number : int = param_number - - method get_result_number : int = result_number - - method get_result_types : binary val_type list = result_types - - method get_owi_i32 : int = owi_i32 - - method get_owi_i64 : int = owi_i64 - - method get_owi_f32 : int = owi_f32 - - method get_owi_f64 : int = owi_f64 - - method get_owi_assume : int = owi_assume +type type_env = + { param_types : binary val_type list + ; global_types : binary val_type list + ; result_types : binary val_type list + ; owi_i32 : int + ; owi_i64 : int + ; owi_f32 : int + ; owi_f64 : int + ; owi_assume : int + ; owi_assert : int + } - method get_owi_assert : int = owi_assert - end +let build_type_env (m : modul) + (func_ty : binary param_type * binary result_type) + (owi_funcs : (string * int) list) : type_env = + let param_types = List.map snd (fst func_ty) in + let global_types (* would get simplified with #353 *) = + List.map + (fun (x : (global, binary global_type) Runtime.t Indexed.t) -> + match Indexed.get x with + | Runtime.Local { typ = _, gt; _ } -> gt + | Runtime.Imported { desc = _, gt; _ } -> gt ) + (List.sort + (fun x y -> compare (Indexed.get_index x) (Indexed.get_index y)) + m.global.values ) + in + let result_types = snd func_ty in + let owi_i32 = List.assoc "i32_symbol" owi_funcs in + let owi_i64 = List.assoc "i64_symbol" owi_funcs in + let owi_f32 = List.assoc "f32_symbol" owi_funcs in + let owi_f64 = List.assoc "f64_symbol" owi_funcs in + let owi_assume = List.assoc "assume" owi_funcs in + let owi_assert = List.assoc "assert" owi_funcs in + { param_types + ; global_types + ; result_types + ; owi_i32 + ; owi_i64 + ; owi_f32 + ; owi_f64 + ; owi_assume + ; owi_assert + } let prop_true = I32_const (Int32.of_int 1) @@ -173,22 +149,23 @@ let binop_generate (b : binop) (expr1 : binary expr) (ty1 : binary val_type) | _, _ -> Error (`Spec_type_error Fmt.(str "%a" pp_binop b)) ) | CustomBinOp _ -> Error (`Spec_type_error Fmt.(str "%a" pp_binop b)) -let rec term_generate tenv term : (binary expr * binary val_type) Result.t = +let rec term_generate tenv (term : binary term) : + (binary expr * binary val_type) Result.t = match term with | Int32 i32 -> Ok ([ I32_const i32 ], Num_type I32) | Int64 i64 -> Ok ([ I64_const i64 ], Num_type I64) | Float32 f32 -> Ok ([ F32_const f32 ], Num_type F32) | Float64 f64 -> Ok ([ F64_const f64 ], Num_type F64) - | ParamVar id -> ( - match tenv#get_param_type id with + | ParamVar (Raw i as id) -> ( + match List.nth_opt tenv.param_types i with | Some t -> Ok ([ Local_get id ], t) | None -> Error (`Spec_type_error Fmt.(str "%a" pp_term term)) ) - | GlobalVar id -> ( - match tenv#get_global_type id with + | GlobalVar (Raw i as id) -> ( + match List.nth_opt tenv.global_types i with | Some t -> Ok ([ Global_get id ], t) | None -> Error (`Spec_type_error Fmt.(str "%a" pp_term term)) ) - | BinderVar id -> ( - match tenv#get_binder_type_and_index id with + | BinderVar (Raw _i as _id) -> ( + match None with | Some (id, t) -> Ok ([ Local_get id ], t) | None -> Error (`Spec_type_error Fmt.(str "%a" pp_term term)) ) | UnOp (u, tm1) -> @@ -199,12 +176,12 @@ let rec term_generate tenv term : (binary expr * binary val_type) Result.t = let* expr2, ty2 = term_generate tenv tm2 in binop_generate b expr1 ty1 expr2 ty2 | Result (Some i) -> ( - match tenv#get_result_type i with - | Some t -> Ok ([ Local_get (Raw (tenv#get_param_number + i)) ], t) + match List.nth_opt tenv.result_types i with + | Some t -> Ok ([ Local_get (Raw (List.length tenv.param_types + i)) ], t) | None -> Error (`Spec_type_error Fmt.(str "%a" pp_term term)) ) | Result None -> ( - match tenv#get_result_type 0 with - | Some t -> Ok ([ Local_get (Raw tenv#get_param_number) ], t) + match List.nth_opt tenv.result_types 0 with + | Some t -> Ok ([ Local_get (Raw (List.length tenv.param_types)) ], t) | None -> Error (`Spec_type_error Fmt.(str "%a" pp_term term)) ) let binpred_generate (b : binpred) (expr1 : binary expr) (ty1 : binary val_type) @@ -286,13 +263,18 @@ let prop_generate tenv : binary prop -> binary expr Result.t = let* expr1 = prop_generate_aux pr1 in let* expr2 = prop_generate_aux pr2 in binconnect_generate b expr1 expr2 - | Binder (_b, _bt, _, _pr1) -> - (* TODO : quantifier checking *) - Ok [] + | Binder (_b, bt, _, _pr1) -> ( + match bt with + | I32 -> Ok [ Call (Raw tenv.owi_i32) ] + | I64 -> Ok [ Call (Raw tenv.owi_i64) ] + | F32 -> Ok [ Call (Raw tenv.owi_f32) ] + | F64 -> Ok [ Call (Raw tenv.owi_f64) ] ) + (* TODO : quantifier checking *) in fun pr -> let+ expr = prop_generate_aux pr in - expr @ [ Call (Raw tenv#get_owi_assert) ] + expr @ [ Call (Raw tenv.owi_assert); Call (Raw tenv.owi_assume) ] +(* add option *) let subst_index ?(subst_custom = false) (old_index : int) (index : int) (m : modul) : modul = @@ -426,22 +408,22 @@ let contract_generate (owi_funcs : (string * int) list) (m : modul) let index = List.length m.func.values in let id = Fmt.str "__rac_%s" old_id in - let tenv = type_env m old_type owi_funcs in + let tenv = build_type_env m old_type owi_funcs in let locals = List.mapi (fun i rt -> (Some Fmt.(str "__rac_res_%i" i), rt)) - tenv#get_result_types + tenv.result_types in let call = - List.init tenv#get_param_number (fun i -> Local_get (Raw i)) + List.init (List.length tenv.param_types) (fun i -> Local_get (Raw i)) @ [ Call (Raw old_index) ] - @ List.init tenv#get_result_number (fun i -> - Local_set (Raw (tenv#get_param_number + i)) ) + @ List.init (List.length tenv.result_types) (fun i -> + Local_set (Raw (List.length tenv.param_types + i)) ) in let return = - List.init tenv#get_result_number (fun i -> - Local_get (Raw (tenv#get_param_number + i)) ) + List.init (List.length tenv.result_types) (fun i -> + Local_get (Raw (List.length tenv.param_types + i)) ) in let* precond_checker = list_concat_map (prop_generate tenv) preconditions in let+ postcond_checker = list_concat_map (prop_generate tenv) postconditions in diff --git a/src/bin/owi.ml b/src/bin/owi.ml index daf00c5cb..258ccf1b2 100644 --- a/src/bin/owi.ml +++ b/src/bin/owi.ml @@ -397,6 +397,9 @@ let exit_code = | `Contract_unknown_func _id -> 71 | `Empty_annotation_id -> 72 | `Empty_identifier -> 73 + | `Unclosed_annotation -> 74 + | `Unclosed_comment -> 75 + | `Unclosed_string -> 76 end end | Error e -> ( diff --git a/src/parser/parse.ml b/src/parser/parse.ml index 860c29860..ffcf92da6 100644 --- a/src/parser/parse.ml +++ b/src/parser/parse.ml @@ -340,6 +340,9 @@ struct | Text_lexer.Empty_identifier -> Error `Empty_identifier | Text_lexer.Illegal_escape msg -> Error (`Illegal_escape msg) | Text_lexer.Illegal_character msg -> Error (`Lexer_illegal_character msg) + | Text_lexer.Unclosed_annotation -> Error `Unclosed_annotation + | Text_lexer.Unclosed_comment -> Error `Unclosed_comment + | Text_lexer.Unclosed_string -> Error `Unclosed_string | Text_lexer.Unknown_operator msg -> Error (`Lexer_unknown_operator msg) | Text_parser.Error -> let tok = Text_lexer.token buf |> token_to_string in diff --git a/src/parser/text_lexer.ml b/src/parser/text_lexer.ml index 5c7ec4caa..8d5d280f5 100644 --- a/src/parser/text_lexer.ml +++ b/src/parser/text_lexer.ml @@ -13,6 +13,12 @@ exception Illegal_character of string exception Illegal_escape of string +exception Unclosed_annotation + +exception Unclosed_comment + +exception Unclosed_string + exception Unknown_operator of string let illegal_character buf = @@ -111,10 +117,12 @@ let id_char = | '!' | '#' | '$' | '%' | '&' | '\'' | '*' | '+' | '-' | '.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '\\' | '^' | '_' | '`' | '|' | '~' )] -let name = [%sedlex.regexp? "\"", Star (Sub (any, "\"") | "\\\""), "\""] +let string_elem = [%sedlex.regexp? Sub (any, "\"") | "\\\""] + +let name = [%sedlex.regexp? "\"", Star string_elem, "\""] let operator = - [%sedlex.regexp? Plus ('0' .. '9' | 'a' .. 'z' | '.' | '_' | ':'), Star name] + [%sedlex.regexp? 'a' .. 'z', Plus ('0' .. '9' | 'a' .. 'z' | '.' | '_' | ':')] let id = [%sedlex.regexp? "$", Plus id_char] @@ -126,7 +134,7 @@ let bad_num = [%sedlex.regexp? num, Plus id] let annot_atom = [%sedlex.regexp? - num | Plus (id_char | name) | ',' | ';' | '[' | ']' | '{' | '}'] + Plus id_char | num | name | ',' | ';' | '[' | ']' | '{' | '}'] let keywords = let tbl = Hashtbl.create 512 in @@ -481,6 +489,7 @@ let rec token buf = let name = String.sub name 1 (String.length name - 2) in let name = mk_string buf name in NAME name + | "\"", Star string_elem -> raise Unclosed_string | eof -> EOF (* | "" -> EOF *) | any -> unknown_operator buf @@ -492,14 +501,14 @@ and comment buf = | "(;" -> comment buf; comment buf - | eof -> Log.err "eof in comment" + | eof -> raise Unclosed_comment | any -> comment buf | _ -> assert false and single_comment buf = match%sedlex buf with | newline -> () - | eof -> Log.err "eof in single line comment" + | eof -> raise Unclosed_comment | any -> single_comment buf | _ -> assert false @@ -519,7 +528,8 @@ and annot buf = | annot_atom -> let annot_atom = Utf8.lexeme buf in Sexp.Atom annot_atom :: annot buf - | eof -> Log.err "eof in annotation" + | "\"", Star string_elem -> raise Unclosed_string + | eof -> raise Unclosed_annotation | any -> illegal_character buf | _ -> illegal_character buf diff --git a/src/parser/text_lexer.mli b/src/parser/text_lexer.mli index 9a6f6aef0..ead822180 100644 --- a/src/parser/text_lexer.mli +++ b/src/parser/text_lexer.mli @@ -9,11 +9,17 @@ exception Empty_annotation_id exception Empty_identifier +exception Illegal_character of string + exception Illegal_escape of string -exception Unknown_operator of string +exception Unclosed_annotation -exception Illegal_character of string +exception Unclosed_comment + +exception Unclosed_string + +exception Unknown_operator of string (** tokenizer *) val token : Sedlexing.lexbuf -> Text_parser.token diff --git a/src/utils/result.ml b/src/utils/result.ml index a81d7c832..ab2d57024 100644 --- a/src/utils/result.ml +++ b/src/utils/result.ml @@ -78,6 +78,9 @@ type err = | `Contract_unknown_func of Types.text Types.indice | `Empty_annotation_id | `Empty_identifier + | `Unclosed_annotation + | `Unclosed_comment + | `Unclosed_string ] type 'a t = ('a, err) Prelude.Result.t @@ -169,3 +172,6 @@ let rec err_to_string = function Fmt.str "contract: unknown function %a" Types.pp_indice id | `Empty_annotation_id -> Fmt.str "empty annotation id" | `Empty_identifier -> Fmt.str "empty identifier" + | `Unclosed_annotation -> Fmt.str "unclosed annotation" + | `Unclosed_comment -> Fmt.str "unclosed comment" + | `Unclosed_string -> Fmt.str "unclosed string" diff --git a/src/utils/result.mli b/src/utils/result.mli index b25aaeb5d..90f63cf8c 100644 --- a/src/utils/result.mli +++ b/src/utils/result.mli @@ -78,6 +78,9 @@ type err = | `Contract_unknown_func of Types.text Types.indice | `Empty_annotation_id | `Empty_identifier + | `Unclosed_annotation + | `Unclosed_comment + | `Unclosed_string ] type 'a t = ('a, err) Prelude.Result.t From 9aceccf68040b54e819c94084a46af805454ac05 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Thu, 22 Aug 2024 12:38:15 +0200 Subject: [PATCH 37/51] accomodate binary module simplification --- src/ast/code_generator.ml | 308 ++++++++++++++++---------------- src/bin/owi.ml | 2 +- src/cmd/cmd_rac.ml | 17 +- src/cmd/cmd_rac.mli | 2 +- src/data_structures/indexed.ml | 4 - src/data_structures/indexed.mli | 2 - src/text_to_binary/rewrite.ml | 60 ++++--- 7 files changed, 199 insertions(+), 196 deletions(-) diff --git a/src/ast/code_generator.ml b/src/ast/code_generator.ml index 8389297de..de60df1ae 100644 --- a/src/ast/code_generator.ml +++ b/src/ast/code_generator.ml @@ -11,38 +11,83 @@ type type_env = { param_types : binary val_type list ; global_types : binary val_type list ; result_types : binary val_type list - ; owi_i32 : int - ; owi_i64 : int - ; owi_f32 : int - ; owi_f64 : int - ; owi_assume : int - ; owi_assert : int + ; result : int -> binary indice + ; owi_i32 : binary indice + ; owi_i64 : binary indice + ; owi_f32 : binary indice + ; owi_f64 : binary indice + ; owi_assume : binary indice + ; owi_assert : binary indice } let build_type_env (m : modul) (func_ty : binary param_type * binary result_type) - (owi_funcs : (string * int) list) : type_env = + (owi_funcs : (string * int) array) : type_env = let param_types = List.map snd (fst func_ty) in - let global_types (* would get simplified with #353 *) = + let global_types = List.map - (fun (x : (global, binary global_type) Runtime.t Indexed.t) -> - match Indexed.get x with + (fun (x : (global, binary global_type) Runtime.t) -> + match x with | Runtime.Local { typ = _, gt; _ } -> gt | Runtime.Imported { desc = _, gt; _ } -> gt ) - (List.sort - (fun x y -> compare (Indexed.get_index x) (Indexed.get_index y)) - m.global.values ) + (Array.to_list m.global) in let result_types = snd func_ty in - let owi_i32 = List.assoc "i32_symbol" owi_funcs in - let owi_i64 = List.assoc "i64_symbol" owi_funcs in - let owi_f32 = List.assoc "f32_symbol" owi_funcs in - let owi_f64 = List.assoc "f64_symbol" owi_funcs in - let owi_assume = List.assoc "assume" owi_funcs in - let owi_assert = List.assoc "assert" owi_funcs in + let result i = Raw (List.length param_types + i + 1) in + let owi_i32 = + match + Array.find_index + (fun (name, _) -> String.equal "i32_symbol" name) + owi_funcs + with + | Some i -> Raw i + | None -> assert false + in + let owi_i64 = + match + Array.find_index + (fun (name, _) -> String.equal "i64_symbol" name) + owi_funcs + with + | Some i -> Raw i + | None -> assert false + in + let owi_f32 = + match + Array.find_index + (fun (name, _) -> String.equal "f32_symbol" name) + owi_funcs + with + | Some i -> Raw i + | None -> assert false + in + let owi_f64 = + match + Array.find_index + (fun (name, _) -> String.equal "f64_symbol" name) + owi_funcs + with + | Some i -> Raw i + | None -> assert false + in + let owi_assume = + match + Array.find_index (fun (name, _) -> String.equal "assume" name) owi_funcs + with + | Some i -> Raw i + | None -> assert false + in + let owi_assert = + match + Array.find_index (fun (name, _) -> String.equal "assert" name) owi_funcs + with + | Some i -> Raw i + | None -> assert false + in { param_types ; global_types ; result_types + ; result ; owi_i32 ; owi_i64 ; owi_f32 @@ -177,11 +222,11 @@ let rec term_generate tenv (term : binary term) : binop_generate b expr1 ty1 expr2 ty2 | Result (Some i) -> ( match List.nth_opt tenv.result_types i with - | Some t -> Ok ([ Local_get (Raw (List.length tenv.param_types + i)) ], t) + | Some t -> Ok ([ Local_get (tenv.result i) ], t) | None -> Error (`Spec_type_error Fmt.(str "%a" pp_term term)) ) | Result None -> ( match List.nth_opt tenv.result_types 0 with - | Some t -> Ok ([ Local_get (Raw (List.length tenv.param_types)) ], t) + | Some t -> Ok ([ Local_get (tenv.result 0) ], t) | None -> Error (`Spec_type_error Fmt.(str "%a" pp_term term)) ) let binpred_generate (b : binpred) (expr1 : binary expr) (ty1 : binary val_type) @@ -265,16 +310,15 @@ let prop_generate tenv : binary prop -> binary expr Result.t = binconnect_generate b expr1 expr2 | Binder (_b, bt, _, _pr1) -> ( match bt with - | I32 -> Ok [ Call (Raw tenv.owi_i32) ] - | I64 -> Ok [ Call (Raw tenv.owi_i64) ] - | F32 -> Ok [ Call (Raw tenv.owi_f32) ] - | F64 -> Ok [ Call (Raw tenv.owi_f64) ] ) + | I32 -> Ok [ Call tenv.owi_i32 ] + | I64 -> Ok [ Call tenv.owi_i64 ] + | F32 -> Ok [ Call tenv.owi_f32 ] + | F64 -> Ok [ Call tenv.owi_f64 ] ) (* TODO : quantifier checking *) in fun pr -> let+ expr = prop_generate_aux pr in - expr @ [ Call (Raw tenv.owi_assert); Call (Raw tenv.owi_assume) ] -(* add option *) + expr @ [ Call tenv.owi_assert ] let subst_index ?(subst_custom = false) (old_index : int) (index : int) (m : modul) : modul = @@ -297,14 +341,7 @@ let subst_index ?(subst_custom = false) (old_index : int) (index : int) Runtime.Local { typ; init = subst_expr init; id } | Imported _ -> global in - let global = - { m.global with - values = - List.map - (fun v -> Indexed.(return (get_index v) (subst_global (get v)))) - m.global.values - } - in + let global = Array.map subst_global m.global in let subst_func (func : (binary func, binary block_type) Runtime.t) = match func with @@ -312,14 +349,7 @@ let subst_index ?(subst_custom = false) (old_index : int) (index : int) Runtime.Local { type_f; locals; body = subst_expr body; id } | Imported _ -> func in - let func = - { m.func with - values = - List.map - (fun v -> Indexed.(return (get_index v) (subst_func (get v)))) - m.func.values - } - in + let func = Array.map subst_func m.func in let subst_elem_mode = function | Elem_passive -> Elem_passive @@ -329,14 +359,7 @@ let subst_index ?(subst_custom = false) (old_index : int) (index : int) let subst_elem ({ id; typ; init; mode } : elem) = { id; typ; init = List.map subst_expr init; mode = subst_elem_mode mode } in - let elem = - { m.elem with - values = - List.map - (fun v -> Indexed.(return (get_index v) (subst_elem (get v)))) - m.elem.values - } - in + let elem = Array.map subst_elem m.elem in let subst_data_mode = function | Data_passive -> Data_passive @@ -345,14 +368,7 @@ let subst_index ?(subst_custom = false) (old_index : int) (index : int) let subst_data ({ id; init; mode } : data) = { id; init; mode = subst_data_mode mode } in - let data = - { m.data with - values = - List.map - (fun v -> Indexed.(return (get_index v) (subst_data (get v)))) - m.data.values - } - in + let data = Array.map subst_data m.data in let subst_export ({ name; id } : export) = { name; id = subst id } in let exports = @@ -390,59 +406,60 @@ let subst_index ?(subst_custom = false) (old_index : int) (index : int) ; custom } -let contract_generate (owi_funcs : (string * int) list) (m : modul) +let contract_generate (owi_funcs : (string * int) array) (m : modul) ({ funcid = Raw old_index; preconditions; postconditions } : binary Contract.t) : modul Result.t = + let func = m.func in + let func_num = Array.length func in let* old_id, Bt_raw (ty_index, old_type) = - match Indexed.get_at old_index m.func.values with - | Some (Runtime.Local { id; type_f; _ }) -> ( - match id with - | Some id -> Ok (id, type_f) - | None -> Ok (Fmt.str "func_%i" old_index, type_f) ) - | Some (Imported { modul; name; assigned_name; desc }) -> ( - match assigned_name with - | Some assigned_name -> Ok (assigned_name, desc) - | None -> Ok (Fmt.str "func_%s_%s_%i" modul name old_index, desc) ) - | None -> Error (`Contract_unknown_func (Raw old_index)) + if old_index >= func_num || old_index < 0 then + Error (`Contract_unknown_func (Raw old_index)) + else + match Array.get func old_index with + | Runtime.Local { id; type_f; _ } -> ( + match id with + | Some id -> Ok (id, type_f) + | None -> Ok (Fmt.str "func_%i" old_index, type_f) ) + | Imported { modul; name; assigned_name; desc } -> ( + match assigned_name with + | Some assigned_name -> Ok (assigned_name, desc) + | None -> Ok (Fmt.str "func_%s_%s_%i" modul name old_index, desc) ) in - let index = List.length m.func.values in let id = Fmt.str "__rac_%s" old_id in + let index = func_num in let tenv = build_type_env m old_type owi_funcs in let locals = List.mapi - (fun i rt -> (Some Fmt.(str "__rac_res_%i" i), rt)) + (fun i rt -> (Some Fmt.(str "__rac_res_%i" (i + 1)), rt)) tenv.result_types in let call = List.init (List.length tenv.param_types) (fun i -> Local_get (Raw i)) @ [ Call (Raw old_index) ] @ List.init (List.length tenv.result_types) (fun i -> - Local_set (Raw (List.length tenv.param_types + i)) ) + Local_set (tenv.result i) ) in let return = List.init (List.length tenv.result_types) (fun i -> - Local_get (Raw (List.length tenv.param_types + i)) ) + Local_get (tenv.result i) ) in let* precond_checker = list_concat_map (prop_generate tenv) preconditions in let+ postcond_checker = list_concat_map (prop_generate tenv) postconditions in let body = precond_checker @ call @ postcond_checker @ return in let m = subst_index old_index index m in - - let value = - Runtime.Local - { type_f = Bt_raw (ty_index, old_type); locals; body; id = Some id } - in let func = - { Named.values = Indexed.return index value :: m.func.values - ; named = String_map.add id index m.func.named - } + Array.append func + [| Runtime.Local + { type_f = Bt_raw (ty_index, old_type); locals; body; id = Some id } + |] in + { m with func } -let contracts_generate (owi_funcs : (string * int) list) (m : modul) +let contracts_generate (owi_funcs : (string * int) array) (m : modul) (contracts : binary Contract.t list) : modul Result.t = let rec join = function | ([] | [ _ ]) as l -> l @@ -454,111 +471,88 @@ let contracts_generate (owi_funcs : (string * int) list) (m : modul) let contracts = join (List.sort Contract.compare_funcid contracts) in list_fold_left (contract_generate owi_funcs) m contracts -let add_owi_funcs (m : modul) : modul * (string * int) list = - let owi_funcs : (string * binary func_type) list = - [ ("i32_symbol", ([], [ Num_type I32 ])) - ; ("i64_symbol", ([], [ Num_type I64 ])) - ; ("f32_symbol", ([], [ Num_type F32 ])) - ; ("f64_symbol", ([], [ Num_type F64 ])) - ; ("assume", ([ (None, Num_type I32) ], [])) - ; ("assert", ([ (None, Num_type I32) ], [])) - ] +let add_owi_funcs (m : modul) : modul * (string * int) array = + let owi_funcs : (string * binary func_type) array = + [| ("i32_symbol", ([], [ Num_type I32 ])) + ; ("i64_symbol", ([], [ Num_type I64 ])) + ; ("f32_symbol", ([], [ Num_type F32 ])) + ; ("f64_symbol", ([], [ Num_type F64 ])) + ; ("assume", ([ (None, Num_type I32) ], [])) + ; ("assert", ([ (None, Num_type I32) ], [])) + |] in (* update module field `types` *) - let update_types () : modul * (string * (binary func_type * int)) list = + let update_types () : modul * (string * (binary func_type * int)) array = let func_type2rec_type : binary func_type -> binary rec_type = fun ty -> [ (None, (Final, [], Def_func_t ty)) ] in - let owi_funcs : (string * (binary func_type * binary rec_type)) list = - List.map (fun (name, ty) -> (name, (ty, func_type2rec_type ty))) owi_funcs + let owi_funcs : (string * (binary func_type * binary rec_type)) array = + Array.map + (fun (name, ty) -> (name, (ty, func_type2rec_type ty))) + owi_funcs in - let values = m.types.values in - let values, owi_funcs = - List.fold_left_map - (fun values (name, (ft, rt)) -> - match - List.find_map - (fun (index, rt') -> - if rec_type_eq rt rt' then Some index else None ) - (Indexed.to_assoc_list values) - with - | Some index -> (values, (name, (ft, index))) + let types, owi_funcs = + Array.fold_left_map + (fun types (name, (owi_ft, owi_rt)) -> + match Array.find_index (fun rt -> rec_type_eq rt owi_rt) types with + | Some index -> (types, (name, (owi_ft, index))) | None -> - let index = List.length values in - (Indexed.return index rt :: values, (name, (ft, index))) ) - (List.rev values) owi_funcs + ( Array.append types [| owi_rt |] + , (name, (owi_ft, Array.length types)) ) ) + m.types owi_funcs in - let values = List.rev values in - ({ m with types = { values; named = m.types.named } }, owi_funcs) + ({ m with types }, owi_funcs) in let m, owi_funcs = update_types () in (* update module field `func` *) - let update_func () : modul * (string * int) list = + let update_func () : modul * (string * int) array = + let func = m.func in + let func_num = Array.length func in let imported, locals = - List.partition_map - (fun i -> - let v = Indexed.get i in - match v with - | Runtime.Imported _ -> Either.Left (Indexed.get_index i, v) - | Local _ -> Either.Right (Indexed.get_index i, v) ) - m.func.values + let i = + Option.fold ~none:func_num + ~some:(fun x -> x) + (Array.find_index + (function Runtime.Local _ -> true | Imported _ -> false) + func ) + in + (Array.sub func 0 i, Array.sub func i (func_num - i)) in - let imported_num = List.length imported in let owi_funcs = - List.mapi - (fun i (name, (ty, index)) -> + Array.map + (fun (name, (ft, index)) -> ( name - , ( { Imported.modul = "symbolic" - ; name - ; assigned_name = Some name - ; desc = Bt_raw (Some (Raw index), ty) - } - , imported_num + i ) ) ) + , { Imported.modul = "symbolic" + ; name + ; assigned_name = Some name + ; desc = Bt_raw (Some (Raw index), ft) + } ) ) owi_funcs in - let imported = - List.map - (fun (_, (f, index)) -> (index, Runtime.Imported f)) - (List.rev owi_funcs) - @ imported + Array.append imported + (Array.map (fun (_, f) -> Runtime.Imported f) owi_funcs) in - let subst_task, locals = - List.fold_left_map - (fun subst_task (old_index, f) -> - let index = old_index + List.length owi_funcs in - ((old_index, index) :: subst_task, (index, f)) ) - [] locals - in + let func = Array.append imported locals in + let m = { m with func } in - let values = - List.map (fun (index, f) -> Indexed.return index f) (imported @ locals) + let subst_task = + List.init (Array.length locals) (fun i -> (i, Array.length imported + i)) in - let named = - List.map - (fun (name, index) -> - if index < imported_num then (name, index) - else (name, index + List.length owi_funcs) ) - (String_map.to_list m.func.named) - in - let named = - String_map.of_list - (List.map (fun (name, (_, index)) -> (name, index)) owi_funcs @ named) - in - - let m = { m with func = { values; named } } in - let m = List.fold_left (fun m (old_index, index) -> subst_index ~subst_custom:true old_index index m ) m subst_task in + let owi_funcs = - List.map (fun (name, (_, index)) -> (name, index)) owi_funcs + Array.mapi + (fun i (name, _) -> (name, Array.length imported + i)) + owi_funcs in (m, owi_funcs) in diff --git a/src/bin/owi.ml b/src/bin/owi.ml index 258ccf1b2..723b3fc12 100644 --- a/src/bin/owi.ml +++ b/src/bin/owi.ml @@ -205,7 +205,7 @@ let rac_cmd = let man = [] @ shared_man in Cmd.info "rac" ~version ~doc ~sdocs ~man in - Cmd.v info Term.(const Cmd_rac.cmd $ unsafe $ files) + Cmd.v info Term.(const Cmd_rac.cmd $ debug $ unsafe $ files) let run_cmd = let open Cmdliner in diff --git a/src/cmd/cmd_rac.ml b/src/cmd/cmd_rac.ml index a5210e947..2af25234b 100644 --- a/src/cmd/cmd_rac.ml +++ b/src/cmd/cmd_rac.ml @@ -11,18 +11,19 @@ let cmd_one unsafe file = | ".wat" -> let* text_modul = Parse.Text.Module.from_file file in let* binary_modul = Compile.Text.until_binary ~unsafe text_modul in - let+ instrumented_binary_modul = Code_generator.generate binary_modul in + let* instrumented_binary_modul = Code_generator.generate binary_modul in let instrumented_text_modul = Binary_to_text.modul instrumented_binary_modul in - - let content = Fmt.str "%a" Text.pp_modul instrumented_text_modul in let filename = Fpath.add_ext ".instrumented" filename in let filename = Fpath.add_ext ".wat" filename in - let filename = Fpath.to_string filename in - let oc = Out_channel.open_bin filename in - Out_channel.output_string oc content; - Out_channel.close oc + let* () = + Binary_encoder.convert filename ~unsafe ~optimize:false + instrumented_text_modul + in + Bos.OS.File.writef filename "%a" Text.pp_modul instrumented_text_modul | ext -> Error (`Unsupported_file_extension ext) -let cmd unsafe files = list_iter (cmd_one unsafe) files +let cmd debug unsafe files = + if debug then Log.debug_on := true; + list_iter (cmd_one unsafe) files diff --git a/src/cmd/cmd_rac.mli b/src/cmd/cmd_rac.mli index 433a95470..b26bccd2a 100644 --- a/src/cmd/cmd_rac.mli +++ b/src/cmd/cmd_rac.mli @@ -2,4 +2,4 @@ (* Copyright © 2021-2024 OCamlPro *) (* Written by the Owi programmers *) -val cmd : bool -> Fpath.t list -> unit Result.t +val cmd : bool -> bool -> Fpath.t list -> unit Result.t diff --git a/src/data_structures/indexed.ml b/src/data_structures/indexed.ml index a16deb1df..02b89f1b2 100644 --- a/src/data_structures/indexed.ml +++ b/src/data_structures/indexed.ml @@ -21,7 +21,3 @@ let get_at i values = match List.find_opt (has_index i) values with | None -> None | Some { value; _ } -> Some value - -let rec to_assoc_list = function - | [] -> [] - | { index; value } :: l -> (index, value) :: to_assoc_list l diff --git a/src/data_structures/indexed.mli b/src/data_structures/indexed.mli index 146a98bd0..14602cf80 100644 --- a/src/data_structures/indexed.mli +++ b/src/data_structures/indexed.mli @@ -15,5 +15,3 @@ val return : int -> 'a -> 'a t val get_at : int -> 'a t list -> 'a option val has_index : int -> 'a t -> bool - -val to_assoc_list : 'a t list -> (int * 'a) list diff --git a/src/text_to_binary/rewrite.ml b/src/text_to_binary/rewrite.ml index e8ea2b5c5..170850fe1 100644 --- a/src/text_to_binary/rewrite.ml +++ b/src/text_to_binary/rewrite.ml @@ -361,7 +361,7 @@ let rewrite_types (_modul : Assigned.t) (t : binary str_type) : let t = [ (None, (Final, [], t)) ] in Ok t -let rec rewrite_term ~(binder_list : string option list) ~(modul : Binary.modul) +let rec rewrite_term ~(binder_list : string option list) ~(modul : Assigned.t) ~(func_param_list : string option list) : text Spec.term -> binary Spec.term Result.t = let rec find_raw_indice error acc id = function @@ -386,7 +386,7 @@ let rec rewrite_term ~(binder_list : string option list) ~(modul : Binary.modul) | Text id -> find_raw_indice (`Spec_unknown_param ind) 0 id func_param_list in - let find_global (modul : Binary.modul) (ind : text indice) : + let find_global (modul : Assigned.t) (ind : text indice) : binary indice Result.t = match ind with | Raw id -> Ok (Raw id) @@ -430,7 +430,7 @@ let rec rewrite_term ~(binder_list : string option list) ~(modul : Binary.modul) BinOp (b, tm1, tm2) | Result i -> Ok (Result i) -let rec rewrite_prop ~(binder_list : string option list) ~(modul : Binary.modul) +let rec rewrite_prop ~(binder_list : string option list) ~(modul : Assigned.t) ~(func_param_list : string option list) : text Spec.prop -> binary Spec.prop Result.t = let open Spec in @@ -452,22 +452,31 @@ let rec rewrite_prop ~(binder_list : string option list) ~(modul : Binary.modul) let+ pr1 = rewrite_prop ~binder_list ~modul ~func_param_list pr1 in Binder (b, bt, id_opt, pr1) -let rewrite_contract (modul : Binary.modul) : +let rewrite_contract (modul : Assigned.t) : text Contract.t -> binary Contract.t Result.t = fun { Contract.funcid; preconditions; postconditions } -> - let (Raw i as funcid) = find modul.func funcid in + let funcid = find modul.func funcid in let* func = + let (Raw i) = funcid in match Indexed.get_at i modul.func.values with - | None -> Error (`Unknown_func funcid) | Some v -> Ok v + | None -> Error (`Spec_invalid_indice (Int.to_string i)) in - let func_param_list = - let (Bt_raw (_, (params, _))) = - match func with - | Local { type_f; _ } -> type_f - | Imported { desc; _ } -> desc - in - List.map fst params + let func_bt = + match func with + | Local { type_f; _ } -> type_f + | Imported { desc; _ } -> desc + in + let* func_param_list = + match func_bt with + | Bt_ind ind -> ( + let (Raw i) = find modul.typ ind in + match Indexed.get_at i modul.typ.values with + | Some (Def_func_t (func_pt, _)) -> + Ok (List.map (fun (str_opt, _) -> str_opt) func_pt) + | _ -> Error (`Spec_invalid_indice (Int.to_string i)) ) + | Bt_raw (_, (func_pt, _)) -> + Ok (List.map (fun (str_opt, _) -> str_opt) func_pt) in let* preconditions = list_map @@ -481,14 +490,14 @@ let rewrite_contract (modul : Binary.modul) : in { Contract.funcid; preconditions; postconditions } -let rewrite_annot (modul : Binary.modul) : +let rewrite_annot (modul : Assigned.t) : text Annot.annot -> Binary.custom Result.t = function | Contract contract -> let+ contract = rewrite_contract modul contract in Binary.From_annot (Contract contract) | Annot annot -> ok @@ Binary.From_annot (Annot annot) -let rewrite_annots (modul : Binary.modul) : +let rewrite_annots (modul : Assigned.t) : text Annot.annot list -> Binary.custom list Result.t = list_map (rewrite_annot modul) @@ -520,6 +529,7 @@ let modul (modul : Assigned.t) : Binary.modul Result.t = let (Raw id) = find func id in Ok (Some id) in + let+ custom = rewrite_annots modul modul.annots in let id = modul.id in let mem = Named.to_array modul.mem in @@ -530,11 +540,15 @@ let modul (modul : Assigned.t) : Binary.modul Result.t = let data = Named.to_array data in let func = Named.to_array func in - let modul_without_annots : Binary.modul = - { id; mem; table; types; global; elem; data; exports; func; start; custom = [] } - in - - let+ custom = rewrite_annots modul_without_annots modul.annots in - - let modul : Binary.modul = { modul_without_annots with custom } in - modul + { Binary.id + ; mem + ; table + ; types + ; global + ; elem + ; data + ; exports + ; func + ; start + ; custom + } From 5046234eda69428c71e74aeefe3e61793e6c1020 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Thu, 22 Aug 2024 15:28:02 +0200 Subject: [PATCH 38/51] fix --- src/ast/code_generator.ml | 67 ++++++++++++++++------------------- src/text_to_binary/rewrite.ml | 6 ++-- 2 files changed, 33 insertions(+), 40 deletions(-) diff --git a/src/ast/code_generator.ml b/src/ast/code_generator.ml index de60df1ae..c3bfe4620 100644 --- a/src/ast/code_generator.ml +++ b/src/ast/code_generator.ml @@ -8,9 +8,9 @@ open Spec open Syntax type type_env = - { param_types : binary val_type list - ; global_types : binary val_type list - ; result_types : binary val_type list + { param_types : binary val_type array + ; global_types : binary val_type array + ; result_types : binary val_type array ; result : int -> binary indice ; owi_i32 : binary indice ; owi_i64 : binary indice @@ -23,17 +23,17 @@ type type_env = let build_type_env (m : modul) (func_ty : binary param_type * binary result_type) (owi_funcs : (string * int) array) : type_env = - let param_types = List.map snd (fst func_ty) in + let param_types = Array.of_list (List.map snd (fst func_ty)) in let global_types = - List.map + Array.map (fun (x : (global, binary global_type) Runtime.t) -> match x with | Runtime.Local { typ = _, gt; _ } -> gt | Runtime.Imported { desc = _, gt; _ } -> gt ) - (Array.to_list m.global) + m.global in - let result_types = snd func_ty in - let result i = Raw (List.length param_types + i + 1) in + let result_types = Array.of_list (snd func_ty) in + let result i = Raw (Array.length param_types + i) in let owi_i32 = match Array.find_index @@ -201,18 +201,15 @@ let rec term_generate tenv (term : binary term) : | Int64 i64 -> Ok ([ I64_const i64 ], Num_type I64) | Float32 f32 -> Ok ([ F32_const f32 ], Num_type F32) | Float64 f64 -> Ok ([ F64_const f64 ], Num_type F64) - | ParamVar (Raw i as id) -> ( - match List.nth_opt tenv.param_types i with - | Some t -> Ok ([ Local_get id ], t) - | None -> Error (`Spec_type_error Fmt.(str "%a" pp_term term)) ) - | GlobalVar (Raw i as id) -> ( - match List.nth_opt tenv.global_types i with - | Some t -> Ok ([ Global_get id ], t) - | None -> Error (`Spec_type_error Fmt.(str "%a" pp_term term)) ) - | BinderVar (Raw _i as _id) -> ( - match None with - | Some (id, t) -> Ok ([ Local_get id ], t) - | None -> Error (`Spec_type_error Fmt.(str "%a" pp_term term)) ) + | ParamVar (Raw i as id) -> + if i < 0 || i >= Array.length tenv.param_types then + Error (`Spec_invalid_indice (Int.to_string i)) + else Ok ([ Local_get id ], tenv.param_types.(i)) + | GlobalVar (Raw i as id) -> + if i < 0 || i >= Array.length tenv.global_types then + Error (`Spec_invalid_indice (Int.to_string i)) + else Ok ([ Global_get id ], tenv.global_types.(i)) + | BinderVar (Raw _i as _id) -> assert false | UnOp (u, tm1) -> let* expr1, ty1 = term_generate tenv tm1 in unop_generate u expr1 ty1 @@ -220,14 +217,13 @@ let rec term_generate tenv (term : binary term) : let* expr1, ty1 = term_generate tenv tm1 in let* expr2, ty2 = term_generate tenv tm2 in binop_generate b expr1 ty1 expr2 ty2 - | Result (Some i) -> ( - match List.nth_opt tenv.result_types i with - | Some t -> Ok ([ Local_get (tenv.result i) ], t) - | None -> Error (`Spec_type_error Fmt.(str "%a" pp_term term)) ) - | Result None -> ( - match List.nth_opt tenv.result_types 0 with - | Some t -> Ok ([ Local_get (tenv.result 0) ], t) - | None -> Error (`Spec_type_error Fmt.(str "%a" pp_term term)) ) + | Result (Some i) -> + if i < 0 || i >= Array.length tenv.result_types then + Error (`Spec_invalid_indice (Int.to_string i)) + else Ok ([ Local_get (Raw i) ], tenv.result_types.(i)) + | Result None -> + if Array.length tenv.result_types = 0 then Error (`Spec_invalid_indice "0") + else Ok ([ Local_get (Raw 0) ], tenv.result_types.(0)) let binpred_generate (b : binpred) (expr1 : binary expr) (ty1 : binary val_type) (expr2 : binary expr) (ty2 : binary val_type) : binary expr Result.t = @@ -412,10 +408,10 @@ let contract_generate (owi_funcs : (string * int) array) (m : modul) let func = m.func in let func_num = Array.length func in let* old_id, Bt_raw (ty_index, old_type) = - if old_index >= func_num || old_index < 0 then + if old_index < 0 || old_index >= func_num then Error (`Contract_unknown_func (Raw old_index)) else - match Array.get func old_index with + match func.(old_index) with | Runtime.Local { id; type_f; _ } -> ( match id with | Some id -> Ok (id, type_f) @@ -433,16 +429,16 @@ let contract_generate (owi_funcs : (string * int) array) (m : modul) let locals = List.mapi (fun i rt -> (Some Fmt.(str "__rac_res_%i" (i + 1)), rt)) - tenv.result_types + (Array.to_list tenv.result_types) in let call = - List.init (List.length tenv.param_types) (fun i -> Local_get (Raw i)) + List.init (Array.length tenv.param_types) (fun i -> Local_get (Raw i)) @ [ Call (Raw old_index) ] - @ List.init (List.length tenv.result_types) (fun i -> + @ List.init (Array.length tenv.result_types) (fun i -> Local_set (tenv.result i) ) in let return = - List.init (List.length tenv.result_types) (fun i -> + List.init (Array.length tenv.result_types) (fun i -> Local_get (tenv.result i) ) in let* precond_checker = list_concat_map (prop_generate tenv) preconditions in @@ -512,8 +508,7 @@ let add_owi_funcs (m : modul) : modul * (string * int) array = let func_num = Array.length func in let imported, locals = let i = - Option.fold ~none:func_num - ~some:(fun x -> x) + Option.fold ~none:func_num ~some:Fun.id (Array.find_index (function Runtime.Local _ -> true | Imported _ -> false) func ) diff --git a/src/text_to_binary/rewrite.ml b/src/text_to_binary/rewrite.ml index 170850fe1..8f59eb831 100644 --- a/src/text_to_binary/rewrite.ml +++ b/src/text_to_binary/rewrite.ml @@ -472,11 +472,9 @@ let rewrite_contract (modul : Assigned.t) : | Bt_ind ind -> ( let (Raw i) = find modul.typ ind in match Indexed.get_at i modul.typ.values with - | Some (Def_func_t (func_pt, _)) -> - Ok (List.map (fun (str_opt, _) -> str_opt) func_pt) + | Some (Def_func_t (func_pt, _)) -> Ok (List.map fst func_pt) | _ -> Error (`Spec_invalid_indice (Int.to_string i)) ) - | Bt_raw (_, (func_pt, _)) -> - Ok (List.map (fun (str_opt, _) -> str_opt) func_pt) + | Bt_raw (_, (func_pt, _)) -> Ok (List.map fst func_pt) in let* preconditions = list_map From 4c1795b09bae344ddae1763b14c5e452085e3111 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Mon, 26 Aug 2024 13:15:43 +0200 Subject: [PATCH 39/51] add bounded quantification --- src/annot/contract.ml | 2 + src/ast/code_generator.ml | 290 +++++++++++++++++++++++++++++++------- src/bin/owi.ml | 1 + src/parser/text_lexer.ml | 5 +- src/utils/result.ml | 2 + src/utils/result.mli | 1 + src/utils/syntax.ml | 10 ++ src/utils/syntax.mli | 6 + 8 files changed, 265 insertions(+), 52 deletions(-) diff --git a/src/annot/contract.ml b/src/annot/contract.ml index 4c69d2ddd..9a8b05878 100644 --- a/src/annot/contract.ml +++ b/src/annot/contract.ml @@ -48,5 +48,7 @@ let parse_contract = in let* funcid = parse_indice funcid in let+ preconditions, postconditions = list_fold_left aux ([], []) conds in + let preconditions = List.rev preconditions in + let postconditions = List.rev postconditions in { funcid; preconditions; postconditions } | annot -> Error (`Unknown_annotation_object annot) diff --git a/src/ast/code_generator.ml b/src/ast/code_generator.ml index c3bfe4620..6c00c0116 100644 --- a/src/ast/code_generator.ml +++ b/src/ast/code_generator.ml @@ -9,21 +9,27 @@ open Syntax type type_env = { param_types : binary val_type array + ; binder_types : binary val_type array ; global_types : binary val_type array ; result_types : binary val_type array + ; binder : int -> binary indice ; result : int -> binary indice - ; owi_i32 : binary indice - ; owi_i64 : binary indice - ; owi_f32 : binary indice - ; owi_f64 : binary indice - ; owi_assume : binary indice + ; copy : binary expr + ; void_to_i32 : binary indice + ; i32_to_i32 : binary indice + ; _owi_i32 : binary indice + ; _owi_i64 : binary indice + ; _owi_f32 : binary indice + ; _owi_f64 : binary indice + ; _owi_assume : binary indice ; owi_assert : binary indice } let build_type_env (m : modul) (func_ty : binary param_type * binary result_type) - (owi_funcs : (string * int) array) : type_env = + (owi_funcs : (string * int) array) : type_env * modul = let param_types = Array.of_list (List.map snd (fst func_ty)) in + let binder_types = [||] in let global_types = Array.map (fun (x : (global, binary global_type) Runtime.t) -> @@ -33,8 +39,37 @@ let build_type_env (m : modul) m.global in let result_types = Array.of_list (snd func_ty) in - let result i = Raw (Array.length param_types + i) in - let owi_i32 = + let binder i = + Raw (Array.length param_types + Array.length result_types + i) + in + let result i = Raw (Array.length param_types + i + 1) in + let copy = + [ Local_tee (Raw (Array.length param_types)) + ; Local_get (Raw (Array.length param_types)) + ] + in + + let void_to_i32 = + [ (None, (Final, [], Def_func_t ([], [ Num_type I32 ]))) ] + in + let i32_to_i32 = + [ ( None + , (Final, [], Def_func_t ([ (None, Num_type I32) ], [ Num_type I32 ])) ) + ] + in + let types = m.types in + let types, void_to_i32 = + match Array.find_index (rec_type_eq void_to_i32) types with + | Some i -> (types, Raw i) + | None -> (Array.append types [| void_to_i32 |], Raw (Array.length types)) + in + let types, i32_to_i32 = + match Array.find_index (rec_type_eq i32_to_i32) types with + | Some i -> (types, Raw i) + | None -> (Array.append types [| i32_to_i32 |], Raw (Array.length types)) + in + + let _owi_i32 = match Array.find_index (fun (name, _) -> String.equal "i32_symbol" name) @@ -43,7 +78,7 @@ let build_type_env (m : modul) | Some i -> Raw i | None -> assert false in - let owi_i64 = + let _owi_i64 = match Array.find_index (fun (name, _) -> String.equal "i64_symbol" name) @@ -52,7 +87,7 @@ let build_type_env (m : modul) | Some i -> Raw i | None -> assert false in - let owi_f32 = + let _owi_f32 = match Array.find_index (fun (name, _) -> String.equal "f32_symbol" name) @@ -61,7 +96,7 @@ let build_type_env (m : modul) | Some i -> Raw i | None -> assert false in - let owi_f64 = + let _owi_f64 = match Array.find_index (fun (name, _) -> String.equal "f64_symbol" name) @@ -70,7 +105,7 @@ let build_type_env (m : modul) | Some i -> Raw i | None -> assert false in - let owi_assume = + let _owi_assume = match Array.find_index (fun (name, _) -> String.equal "assume" name) owi_funcs with @@ -84,17 +119,23 @@ let build_type_env (m : modul) | Some i -> Raw i | None -> assert false in - { param_types - ; global_types - ; result_types - ; result - ; owi_i32 - ; owi_i64 - ; owi_f32 - ; owi_f64 - ; owi_assume - ; owi_assert - } + ( { param_types + ; binder_types + ; global_types + ; result_types + ; binder + ; result + ; copy + ; void_to_i32 + ; i32_to_i32 + ; _owi_i32 + ; _owi_i64 + ; _owi_f32 + ; _owi_f64 + ; _owi_assume + ; owi_assert + } + , { m with types } ) let prop_true = I32_const (Int32.of_int 1) @@ -209,7 +250,10 @@ let rec term_generate tenv (term : binary term) : if i < 0 || i >= Array.length tenv.global_types then Error (`Spec_invalid_indice (Int.to_string i)) else Ok ([ Global_get id ], tenv.global_types.(i)) - | BinderVar (Raw _i as _id) -> assert false + | BinderVar (Raw i) -> + if i < 0 || i >= Array.length tenv.binder_types then + Error (`Spec_invalid_indice (Int.to_string i)) + else Ok ([ Local_get (tenv.binder i) ], tenv.binder_types.(i)) | UnOp (u, tm1) -> let* expr1, ty1 = term_generate tenv tm1 in unop_generate u expr1 ty1 @@ -289,32 +333,161 @@ let binconnect_generate (b : binconnect) (expr1 : binary expr) (None, Some bt, expr2, (prop_true :: expr2) @ [ I_binop (S32, Xor) ]) ] ) -let prop_generate tenv : binary prop -> binary expr Result.t = - let rec prop_generate_aux = function - | Const true -> Ok [ prop_true ] - | Const false -> Ok [ prop_false ] +let bounded_quantification : + binary prop + -> (binder * binder_type * binary term * binary term * binary prop) Result.t = + function + | Binder (b, ((I32 | I64) as bt), _, pr1) -> ( + match pr1 with + | BinConnect + ( Imply + , BinConnect + ( And + , BinPred (Ge, BinderVar (Raw 0), tm1) + , BinPred (Le, BinderVar (Raw 0), tm2) ) + , pr2 ) -> + Ok (b, bt, tm1, tm2, pr2) + | _ -> Error `Unbounded_quantification ) + | _ -> Error `Unbounded_quantification + +let prop_generate tenv : binary prop -> (type_env * binary expr) Result.t = + let rec prop_generate_aux tenv = function + | Const true -> Ok (tenv, [ prop_true ]) + | Const false -> Ok (tenv, [ prop_false ]) | BinPred (b, tm1, tm2) -> let* expr1, ty1 = term_generate tenv tm1 in let* expr2, ty2 = term_generate tenv tm2 in - binpred_generate b expr1 ty1 expr2 ty2 + let+ expr = binpred_generate b expr1 ty1 expr2 ty2 in + (tenv, expr) | UnConnect (u, pr1) -> - let* expr1 = prop_generate_aux pr1 in - unconnect_generate u expr1 + let* tenv1, expr1 = prop_generate_aux tenv pr1 in + let+ expr = unconnect_generate u expr1 in + (tenv1, expr) | BinConnect (b, pr1, pr2) -> - let* expr1 = prop_generate_aux pr1 in - let* expr2 = prop_generate_aux pr2 in - binconnect_generate b expr1 expr2 - | Binder (_b, bt, _, _pr1) -> ( - match bt with - | I32 -> Ok [ Call tenv.owi_i32 ] - | I64 -> Ok [ Call tenv.owi_i64 ] - | F32 -> Ok [ Call tenv.owi_f32 ] - | F64 -> Ok [ Call tenv.owi_f64 ] ) - (* TODO : quantifier checking *) + let* tenv1, expr1 = prop_generate_aux tenv pr1 in + let* tenv2, expr2 = prop_generate_aux tenv1 pr2 in + let+ expr = binconnect_generate b expr1 expr2 in + (tenv2, expr) + | Binder _ as pr1 -> + let* b, bt, lower, upper, pr2 = bounded_quantification pr1 in + let* lower, lower_ty = term_generate tenv lower in + let* upper, upper_ty = term_generate tenv upper in + if val_type_eq lower_ty upper_ty && val_type_eq (Num_type bt) lower_ty + then + let tenv = + { tenv with + binder_types = Array.append [| Num_type bt |] tenv.binder_types + ; binder = + (fun i -> + let (Raw i) = tenv.binder i in + Raw (i + 1) ) + } + in + let+ tenv, expr1 = prop_generate_aux tenv pr2 in + match b with + | Forall -> + let init = lower @ [ Local_set (tenv.binder 0); prop_true ] in + let incr = + match bt with + | I32 -> + [ Local_get (tenv.binder 0) + ; I32_const (Int32.of_int 1) + ; I_binop (S32, Add) + ; Local_set (tenv.binder 0) + ] + | I64 -> + [ Local_get (tenv.binder 0) + ; I64_const (Int64.of_int 1) + ; I_binop (S64, Add) + ; Local_set (tenv.binder 0) + ] + | _ -> assert false + in + let check_smaller = + match bt with + | I32 -> + [ Local_get (tenv.binder 0) ] @ upper @ [ I_relop (S32, Le S) ] + | I64 -> + [ Local_get (tenv.binder 0) ] @ upper @ [ I_relop (S64, Le S) ] + | _ -> assert false + in + let loop_body = + expr1 + @ [ I_binop (S32, And) ] + @ tenv.copy + @ [ I32_const (Int32.of_int 1); I_binop (S32, Xor); Br_if (Raw 1) ] + @ incr @ check_smaller @ [ Br_if (Raw 0) ] + in + let loop = + [ Loop + ( Some "__rac_loop" + , Some + (Bt_raw + ( Some tenv.i32_to_i32 + , ([ (None, Num_type I32) ], [ Num_type I32 ]) ) ) + , loop_body ) + ] + in + ( tenv + , [ Block + ( Some "__rac_forall" + , Some (Bt_raw (Some tenv.void_to_i32, ([], [ Num_type I32 ]))) + , init @ loop ) + ] ) + | Exists -> + let init = lower @ [ Local_set (tenv.binder 0); prop_false ] in + let incr = + match bt with + | I32 -> + [ Local_get (tenv.binder 0) + ; I32_const (Int32.of_int 1) + ; I_binop (S32, Add) + ; Local_set (tenv.binder 0) + ] + | I64 -> + [ Local_get (tenv.binder 0) + ; I64_const (Int64.of_int 1) + ; I_binop (S64, Add) + ; Local_set (tenv.binder 0) + ] + | _ -> assert false + in + let check_smaller = + match bt with + | I32 -> + [ Local_get (tenv.binder 0) ] @ upper @ [ I_relop (S32, Le S) ] + | I64 -> + [ Local_get (tenv.binder 0) ] @ upper @ [ I_relop (S64, Le S) ] + | _ -> assert false + in + let loop_body = + expr1 + @ [ I_binop (S32, Or) ] + @ tenv.copy + @ [ I32_const (Int32.of_int 1); I_binop (S32, Xor); Br_if (Raw 1) ] + @ incr @ check_smaller @ [ Br_if (Raw 0) ] + in + let loop = + [ Loop + ( Some "__rac_loop" + , Some + (Bt_raw + ( Some tenv.i32_to_i32 + , ([ (None, Num_type I32) ], [ Num_type I32 ]) ) ) + , loop_body ) + ] + in + ( tenv + , [ Block + ( Some "__rac_exists" + , Some (Bt_raw (Some tenv.void_to_i32, ([], [ Num_type I32 ]))) + , init @ loop ) + ] ) + else Error `Unbounded_quantification in fun pr -> - let+ expr = prop_generate_aux pr in - expr @ [ Call tenv.owi_assert ] + let+ tenv, expr = prop_generate_aux tenv pr in + (tenv, expr @ [ Call tenv.owi_assert ]) let subst_index ?(subst_custom = false) (old_index : int) (index : int) (m : modul) : modul = @@ -402,6 +575,12 @@ let subst_index ?(subst_custom = false) (old_index : int) (index : int) ; custom } +let rec binder_locals = function + | UnConnect (_, pr1) -> binder_locals pr1 + | BinConnect (_, pr1, pr2) -> binder_locals pr1 @ binder_locals pr2 + | Binder (_, bt, _, pr1) -> Num_type bt :: binder_locals pr1 + | _ -> [] + let contract_generate (owi_funcs : (string * int) array) (m : modul) ({ funcid = Raw old_index; preconditions; postconditions } : binary Contract.t) : modul Result.t = @@ -424,12 +603,16 @@ let contract_generate (owi_funcs : (string * int) array) (m : modul) let id = Fmt.str "__rac_%s" old_id in let index = func_num in - let tenv = build_type_env m old_type owi_funcs in + let tenv, m = build_type_env m old_type owi_funcs in let locals = - List.mapi - (fun i rt -> (Some Fmt.(str "__rac_res_%i" (i + 1)), rt)) - (Array.to_list tenv.result_types) + [ (Some "__rac_temp", Num_type I32) ] + @ List.mapi + (fun i t -> (Some Fmt.(str "__rac_res_%i" i), t)) + (Array.to_list tenv.result_types) + @ List.mapi + (fun i t -> (Some Fmt.(str "__rac_binder_%i" i), t)) + (List.concat (List.map binder_locals (preconditions @ postconditions))) in let call = List.init (Array.length tenv.param_types) (fun i -> Local_get (Raw i)) @@ -441,8 +624,17 @@ let contract_generate (owi_funcs : (string * int) array) (m : modul) List.init (Array.length tenv.result_types) (fun i -> Local_get (tenv.result i) ) in - let* precond_checker = list_concat_map (prop_generate tenv) preconditions in - let+ postcond_checker = list_concat_map (prop_generate tenv) postconditions in + + let* tenv, precond_checker = + list_fold_left_map prop_generate tenv preconditions + in + let precond_checker = List.concat precond_checker in + + let+ _tenv, postcond_checker = + list_fold_left_map prop_generate tenv postconditions + in + let postcond_checker = List.concat postcond_checker in + let body = precond_checker @ call @ postcond_checker @ return in let m = subst_index old_index index m in diff --git a/src/bin/owi.ml b/src/bin/owi.ml index 723b3fc12..b87733c56 100644 --- a/src/bin/owi.ml +++ b/src/bin/owi.ml @@ -400,6 +400,7 @@ let exit_code = | `Unclosed_annotation -> 74 | `Unclosed_comment -> 75 | `Unclosed_string -> 76 + | `Unbounded_quantification -> 77 end end | Error e -> ( diff --git a/src/parser/text_lexer.ml b/src/parser/text_lexer.ml index 8d5d280f5..e9daa85ec 100644 --- a/src/parser/text_lexer.ml +++ b/src/parser/text_lexer.ml @@ -525,12 +525,11 @@ and annot buf = let items = annot buf in Sexp.List items :: annot buf | ")" -> [] + | "\"", Star string_elem -> raise Unclosed_string + | eof -> raise Unclosed_annotation | annot_atom -> let annot_atom = Utf8.lexeme buf in Sexp.Atom annot_atom :: annot buf - | "\"", Star string_elem -> raise Unclosed_string - | eof -> raise Unclosed_annotation - | any -> illegal_character buf | _ -> illegal_character buf let lexer buf = Sedlexing.with_tokenizer token buf diff --git a/src/utils/result.ml b/src/utils/result.ml index ab2d57024..7d53086f4 100644 --- a/src/utils/result.ml +++ b/src/utils/result.ml @@ -81,6 +81,7 @@ type err = | `Unclosed_annotation | `Unclosed_comment | `Unclosed_string + | `Unbounded_quantification ] type 'a t = ('a, err) Prelude.Result.t @@ -175,3 +176,4 @@ let rec err_to_string = function | `Unclosed_annotation -> Fmt.str "unclosed annotation" | `Unclosed_comment -> Fmt.str "unclosed comment" | `Unclosed_string -> Fmt.str "unclosed string" + | `Unbounded_quantification -> Fmt.str "unbounded quantification" diff --git a/src/utils/result.mli b/src/utils/result.mli index 90f63cf8c..acf6dde9c 100644 --- a/src/utils/result.mli +++ b/src/utils/result.mli @@ -81,6 +81,7 @@ type err = | `Unclosed_annotation | `Unclosed_comment | `Unclosed_string + | `Unbounded_quantification ] type 'a t = ('a, err) Prelude.Result.t diff --git a/src/utils/syntax.ml b/src/utils/syntax.ml index 5c773a06d..82ba5391c 100644 --- a/src/utils/syntax.ml +++ b/src/utils/syntax.ml @@ -59,6 +59,16 @@ let list_fold_left f acc l = f acc v ) (Ok acc) l +let list_fold_left_map f acc l = + let+ acc, l = + list_fold_left + (fun (acc, l) v -> + let+ acc, x = f acc v in + (acc, x :: l) ) + (acc, []) l + in + (acc, List.rev l) + let array_iter f a = let err = ref None in try diff --git a/src/utils/syntax.mli b/src/utils/syntax.mli index 4a04a2734..f52bcb18d 100644 --- a/src/utils/syntax.mli +++ b/src/utils/syntax.mli @@ -33,6 +33,12 @@ val list_fold_left : -> 'b list -> ('a, 'err) Prelude.Result.t +val list_fold_left_map : + ('a -> 'b -> ('a * 'c, 'err) Prelude.Result.t) + -> 'a + -> 'b list + -> ('a * 'c list, 'err) Prelude.Result.t + val array_iter : ('a -> (unit, 'err) Prelude.Result.t) -> 'a array From dbdd1a2478b6ead856ce7dcab82436f768614b6c Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Tue, 27 Aug 2024 14:12:47 +0200 Subject: [PATCH 40/51] fix operator tests --- src/parser/text_lexer.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parser/text_lexer.ml b/src/parser/text_lexer.ml index e9daa85ec..8ffb6f530 100644 --- a/src/parser/text_lexer.ml +++ b/src/parser/text_lexer.ml @@ -122,7 +122,7 @@ let string_elem = [%sedlex.regexp? Sub (any, "\"") | "\\\""] let name = [%sedlex.regexp? "\"", Star string_elem, "\""] let operator = - [%sedlex.regexp? 'a' .. 'z', Plus ('0' .. '9' | 'a' .. 'z' | '.' | '_' | ':')] + [%sedlex.regexp? Plus ('0' .. '9' | 'a' .. 'z' | '.' | '_' | ':'), Star name] let id = [%sedlex.regexp? "$", Plus id_char] From 873d937e2ccad6c7e35c84b22d46973734812195 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Tue, 27 Aug 2024 14:19:11 +0200 Subject: [PATCH 41/51] add rac tests --- example/README.md | 2 +- src/text_to_binary/grouped.ml | 3 +- test/c/eacsl/ghost/global.t | 4 +- test/help/help.t | 2 +- test/weasel/dune | 2 + test/weasel/forall.t | 1233 +++++++++++++++++++++++++++++++++ test/weasel/forall.wat | 7 + test/weasel/plus.t | 8 + test/weasel/plus.wat | 12 + 9 files changed, 1268 insertions(+), 5 deletions(-) create mode 100644 test/weasel/dune create mode 100644 test/weasel/forall.t create mode 100644 test/weasel/forall.wat create mode 100644 test/weasel/plus.t create mode 100644 test/weasel/plus.wat diff --git a/example/README.md b/example/README.md index 6794930dc..06571a564 100644 --- a/example/README.md +++ b/example/README.md @@ -41,7 +41,7 @@ COMMANDS opt [--debug] [--output=FILE] [--unsafe] [OPTION]… ARG Optimize a module - rac [--unsafe] [OPTION]… [ARG]… + rac [--debug] [--unsafe] [OPTION]… [ARG]… Perform runtime assertion checking run [OPTION]… [ARG]… diff --git a/src/text_to_binary/grouped.ml b/src/text_to_binary/grouped.ml index 1018f2852..edaff1d01 100644 --- a/src/text_to_binary/grouped.ml +++ b/src/text_to_binary/grouped.ml @@ -215,6 +215,7 @@ let add_field curr (fields : t) = function let of_symbolic { Text.fields; id; annots } = Log.debug0 "grouping ...@\n"; - let+ modul = list_fold_left (add_field (init_curr ())) (empty_module id) fields + let+ modul = + list_fold_left (add_field (init_curr ())) (empty_module id) fields in { modul with annots } diff --git a/test/c/eacsl/ghost/global.t b/test/c/eacsl/ghost/global.t index b77da08d7..b7a22ccd2 100644 --- a/test/c/eacsl/ghost/global.t +++ b/test/c/eacsl/ghost/global.t @@ -3,5 +3,5 @@ Model: (model (symbol_0 (i32 20))) - Reached problem! - [13] + Reached problem!Segmentation fault (core dumped) + [139] diff --git a/test/help/help.t b/test/help/help.t index f5f0e6009..c050819df 100644 --- a/test/help/help.t +++ b/test/help/help.t @@ -19,7 +19,7 @@ no subcommand should print help opt [--debug] [--output=FILE] [--unsafe] [OPTION]… ARG Optimize a module - rac [--unsafe] [OPTION]… [ARG]… + rac [--debug] [--unsafe] [OPTION]… [ARG]… Perform runtime assertion checking run [OPTION]… [ARG]… diff --git a/test/weasel/dune b/test/weasel/dune new file mode 100644 index 000000000..0302df14c --- /dev/null +++ b/test/weasel/dune @@ -0,0 +1,2 @@ +(cram + (deps %{bin:owi} forall.wat plus.wat)) diff --git a/test/weasel/forall.t b/test/weasel/forall.t new file mode 100644 index 000000000..7c8762278 --- /dev/null +++ b/test/weasel/forall.t @@ -0,0 +1,1233 @@ + $ owi rac forall.wat + $ owi sym forall.instrumented.wat --debug + parsing ... + checking ... + grouping ... + assigning ... + rewriting ... + typechecking ... + typechecking ... + linking ... + interpreting ... + stack : [ ] + running instr: call 7 + calling func : func __rac_start + stack : [ ] + running instr: (block $__rac_forall (result i32) + i32.const 1 + local.set 1 + i32.const 1 + (loop $__rac_loop (param i32) (result i32) + local.get 1 + i32.const 100 + i32.le_s + i32.and + local.tee 0 + local.get 0 + i32.const 1 + i32.xor + br_if 1 + local.get 1 + i32.const 1 + i32.add + local.set 1 + local.get 1 + i32.const 10 + i32.le_s + br_if 0)) + stack : [ ] + running instr: i32.const 1 + stack : [ (i32 1) ] + running instr: local.set 1 + stack : [ ] + running instr: i32.const 1 + stack : [ (i32 1) ] + running instr: (loop $__rac_loop (param i32) (result i32) + local.get 1 + i32.const 100 + i32.le_s + i32.and + local.tee 0 + local.get 0 + i32.const 1 + i32.xor + br_if 1 + local.get 1 + i32.const 1 + i32.add + local.set 1 + local.get 1 + i32.const 10 + i32.le_s + br_if 0) + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 1) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 2) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 2) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 2) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 2) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 2) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 2) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 2) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 3) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 3) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 3) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 3) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 3) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 3) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 3) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 4) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 4) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 4) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 4) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 4) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 4) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 4) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 5) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 5) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 5) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 5) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 5) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 5) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 5) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 6) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 6) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 6) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 6) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 6) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 6) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 6) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 7) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 7) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 7) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 7) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 7) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 7) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 7) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 8) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 8) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 8) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 8) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 8) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 8) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 8) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 9) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 9) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 9) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 9) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 9) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 9) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 9) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 10) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 10) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 10) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 10) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 10) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 10) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 10) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 11) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 11) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 11) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + stack : [ (i32 1) ] + stack : [ (i32 1) ] + running instr: call 5 + stack : [ ] + running instr: call 6 + calling func : func start + stack : [ ] + stack : [ ] + stack : [ ] + All OK + $ owi sym forall.instrumented.wasm --debug + typechecking ... + typechecking ... + linking ... + interpreting ... + stack : [ ] + running instr: call 7 + calling func : func anonymous + stack : [ ] + running instr: (block (result i32) + i32.const 1 + local.set 1 + i32.const 1 + (loop (param i32) (result i32) + local.get 1 + i32.const 100 + i32.le_s + i32.and + local.tee 0 + local.get 0 + i32.const 1 + i32.xor + br_if 1 + local.get 1 + i32.const 1 + i32.add + local.set 1 + local.get 1 + i32.const 10 + i32.le_s + br_if 0)) + stack : [ ] + running instr: i32.const 1 + stack : [ (i32 1) ] + running instr: local.set 1 + stack : [ ] + running instr: i32.const 1 + stack : [ (i32 1) ] + running instr: (loop (param i32) (result i32) + local.get 1 + i32.const 100 + i32.le_s + i32.and + local.tee 0 + local.get 0 + i32.const 1 + i32.xor + br_if 1 + local.get 1 + i32.const 1 + i32.add + local.set 1 + local.get 1 + i32.const 10 + i32.le_s + br_if 0) + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 1) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 2) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 2) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 2) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 2) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 2) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 2) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 2) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 3) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 3) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 3) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 3) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 3) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 3) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 3) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 4) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 4) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 4) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 4) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 4) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 4) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 4) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 5) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 5) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 5) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 5) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 5) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 5) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 5) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 6) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 6) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 6) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 6) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 6) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 6) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 6) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 7) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 7) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 7) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 7) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 7) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 7) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 7) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 8) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 8) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 8) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 8) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 8) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 8) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 8) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 9) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 9) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 9) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 9) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 9) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 9) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 9) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 10) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 10) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 10) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 10) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 10) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 10) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 10) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 11) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 11) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 11) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + stack : [ (i32 1) ] + stack : [ (i32 1) ] + running instr: call 5 + stack : [ ] + running instr: call 6 + calling func : func anonymous + stack : [ ] + stack : [ ] + stack : [ ] + All OK + $ owi wasm2wat forall.instrumented.wasm > forall.instrumented2.wat + $ owi sym forall.instrumented2.wat --debug + parsing ... + checking ... + grouping ... + assigning ... + rewriting ... + typechecking ... + typechecking ... + linking ... + interpreting ... + stack : [ ] + running instr: call 7 + calling func : func anonymous + stack : [ ] + running instr: (block (result i32) + i32.const 1 + local.set 1 + i32.const 1 + (loop (param i32) (result i32) + local.get 1 + i32.const 100 + i32.le_s + i32.and + local.tee 0 + local.get 0 + i32.const 1 + i32.xor + br_if 1 + local.get 1 + i32.const 1 + i32.add + local.set 1 + local.get 1 + i32.const 10 + i32.le_s + br_if 0)) + stack : [ ] + running instr: i32.const 1 + stack : [ (i32 1) ] + running instr: local.set 1 + stack : [ ] + running instr: i32.const 1 + stack : [ (i32 1) ] + running instr: (loop (param i32) (result i32) + local.get 1 + i32.const 100 + i32.le_s + i32.and + local.tee 0 + local.get 0 + i32.const 1 + i32.xor + br_if 1 + local.get 1 + i32.const 1 + i32.add + local.set 1 + local.get 1 + i32.const 10 + i32.le_s + br_if 0) + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 1) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 2) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 2) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 2) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 2) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 2) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 2) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 2) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 3) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 3) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 3) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 3) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 3) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 3) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 3) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 4) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 4) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 4) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 4) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 4) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 4) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 4) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 5) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 5) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 5) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 5) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 5) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 5) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 5) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 6) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 6) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 6) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 6) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 6) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 6) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 6) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 7) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 7) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 7) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 7) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 7) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 7) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 7) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 8) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 8) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 8) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 8) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 8) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 8) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 8) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 9) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 9) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 9) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 9) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 9) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 9) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 9) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 10) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 10) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 10) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 10) ; (i32 1) ] + running instr: i32.const 100 + stack : [ (i32 100) ; (i32 10) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.and + stack : [ (i32 1) ] + running instr: local.tee 0 + stack : [ (i32 1) ] + running instr: local.get 0 + stack : [ (i32 1) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 1) ; (i32 1) ] + running instr: i32.xor + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 10) ; (i32 1) ] + running instr: i32.const 1 + stack : [ (i32 1) ; (i32 10) ; (i32 1) ] + running instr: i32.add + stack : [ (i32 11) ; (i32 1) ] + running instr: local.set 1 + stack : [ (i32 1) ] + running instr: local.get 1 + stack : [ (i32 11) ; (i32 1) ] + running instr: i32.const 10 + stack : [ (i32 10) ; (i32 11) ; (i32 1) ] + running instr: i32.le_s + stack : [ (i32 0) ; (i32 1) ] + running instr: br_if 0 + stack : [ (i32 1) ] + stack : [ (i32 1) ] + stack : [ (i32 1) ] + running instr: call 5 + stack : [ ] + running instr: call 6 + calling func : func anonymous + stack : [ ] + stack : [ ] + stack : [ ] + All OK diff --git a/test/weasel/forall.wat b/test/weasel/forall.wat new file mode 100644 index 000000000..83f33d359 --- /dev/null +++ b/test/weasel/forall.wat @@ -0,0 +1,7 @@ +(module + (@contract $start + (requires (forall i32 $x (==> (&& (>= $x 1) (<= $x 10)) (<= $x 100)))) + ) + (func $start) + (start $start) +) diff --git a/test/weasel/plus.t b/test/weasel/plus.t new file mode 100644 index 000000000..2fa06f9a3 --- /dev/null +++ b/test/weasel/plus.t @@ -0,0 +1,8 @@ + $ owi rac plus.wat + $ owi sym plus.instrumented.wat + All OK + $ owi sym plus.instrumented.wasm + All OK + $ owi wasm2wat plus.instrumented.wasm > plus.instrumented2.wat + $ owi sym plus.instrumented2.wat + All OK diff --git a/test/weasel/plus.wat b/test/weasel/plus.wat new file mode 100644 index 000000000..67075d328 --- /dev/null +++ b/test/weasel/plus.wat @@ -0,0 +1,12 @@ +(module + (@contract $plus_three + (ensures (= result (+ $x 3))) + ) + (func $plus_three + (param $x i32) (result i32) + (i32.add (i32.const 3) (local.get $x))) + (func $start + (call $plus_three (i32.const 42)) + drop) + (start $start) +) From 4d547f680915fee858a5ee2b110214441dd743e5 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Tue, 27 Aug 2024 15:06:28 +0200 Subject: [PATCH 42/51] rename rac to instrument --- example/README.md | 7 ++++--- src/ast/code_generator.ml | 16 ++++++++-------- src/bin/owi.ml | 13 ++++++++----- src/cmd/{cmd_rac.ml => cmd_instrument.ml} | 0 src/cmd/{cmd_rac.mli => cmd_instrument.mli} | 0 src/dune | 2 +- test/c/eacsl/ghost/global.t | 4 ++-- test/help/help.t | 3 --- test/weasel/forall.t | 10 +++++----- test/weasel/plus.t | 2 +- 10 files changed, 29 insertions(+), 28 deletions(-) rename src/cmd/{cmd_rac.ml => cmd_instrument.ml} (100%) rename src/cmd/{cmd_rac.mli => cmd_instrument.mli} (100%) diff --git a/example/README.md b/example/README.md index 06571a564..9c3c773de 100644 --- a/example/README.md +++ b/example/README.md @@ -38,12 +38,13 @@ COMMANDS fmt [--inplace] [OPTION]… [ARG]… Format a .wat or .wast file + instrument [--debug] [--unsafe] [OPTION]… [ARG]… + Generate an instrumented file with runtime assertion checking + coming from Weasel specifications + opt [--debug] [--output=FILE] [--unsafe] [OPTION]… ARG Optimize a module - rac [--debug] [--unsafe] [OPTION]… [ARG]… - Perform runtime assertion checking - run [OPTION]… [ARG]… Run the concrete interpreter diff --git a/src/ast/code_generator.ml b/src/ast/code_generator.ml index 6c00c0116..34ea4561b 100644 --- a/src/ast/code_generator.ml +++ b/src/ast/code_generator.ml @@ -420,7 +420,7 @@ let prop_generate tenv : binary prop -> (type_env * binary expr) Result.t = in let loop = [ Loop - ( Some "__rac_loop" + ( Some "__weasel_loop" , Some (Bt_raw ( Some tenv.i32_to_i32 @@ -430,7 +430,7 @@ let prop_generate tenv : binary prop -> (type_env * binary expr) Result.t = in ( tenv , [ Block - ( Some "__rac_forall" + ( Some "__weasel_forall" , Some (Bt_raw (Some tenv.void_to_i32, ([], [ Num_type I32 ]))) , init @ loop ) ] ) @@ -469,7 +469,7 @@ let prop_generate tenv : binary prop -> (type_env * binary expr) Result.t = in let loop = [ Loop - ( Some "__rac_loop" + ( Some "__weasel_loop" , Some (Bt_raw ( Some tenv.i32_to_i32 @@ -479,7 +479,7 @@ let prop_generate tenv : binary prop -> (type_env * binary expr) Result.t = in ( tenv , [ Block - ( Some "__rac_exists" + ( Some "__weasel_exists" , Some (Bt_raw (Some tenv.void_to_i32, ([], [ Num_type I32 ]))) , init @ loop ) ] ) @@ -600,18 +600,18 @@ let contract_generate (owi_funcs : (string * int) array) (m : modul) | Some assigned_name -> Ok (assigned_name, desc) | None -> Ok (Fmt.str "func_%s_%s_%i" modul name old_index, desc) ) in - let id = Fmt.str "__rac_%s" old_id in + let id = Fmt.str "__weasel_%s" old_id in let index = func_num in let tenv, m = build_type_env m old_type owi_funcs in let locals = - [ (Some "__rac_temp", Num_type I32) ] + [ (Some "__weasel_temp", Num_type I32) ] @ List.mapi - (fun i t -> (Some Fmt.(str "__rac_res_%i" i), t)) + (fun i t -> (Some Fmt.(str "__weasel_res_%i" i), t)) (Array.to_list tenv.result_types) @ List.mapi - (fun i t -> (Some Fmt.(str "__rac_binder_%i" i), t)) + (fun i t -> (Some Fmt.(str "__weasel_binder_%i" i), t)) (List.concat (List.map binder_locals (preconditions @ postconditions))) in let call = diff --git a/src/bin/owi.ml b/src/bin/owi.ml index b87733c56..fda567ad7 100644 --- a/src/bin/owi.ml +++ b/src/bin/owi.ml @@ -198,14 +198,17 @@ let opt_cmd = in Cmd.v info Term.(const Cmd_opt.cmd $ debug $ unsafe $ sourcefile $ outfile) -let rac_cmd = +let instrument_cmd = let open Cmdliner in let info = - let doc = "Perform runtime assertion checking" in + let doc = + "Generate an instrumented file with runtime assertion checking coming \ + from Weasel specifications" + in let man = [] @ shared_man in - Cmd.info "rac" ~version ~doc ~sdocs ~man + Cmd.info "instrument" ~version ~doc ~sdocs ~man in - Cmd.v info Term.(const Cmd_rac.cmd $ debug $ unsafe $ files) + Cmd.v info Term.(const Cmd_instrument.cmd $ debug $ unsafe $ files) let run_cmd = let open Cmdliner in @@ -304,7 +307,7 @@ let cli = [ c_cmd ; fmt_cmd ; opt_cmd - ; rac_cmd + ; instrument_cmd ; run_cmd ; script_cmd ; sym_cmd diff --git a/src/cmd/cmd_rac.ml b/src/cmd/cmd_instrument.ml similarity index 100% rename from src/cmd/cmd_rac.ml rename to src/cmd/cmd_instrument.ml diff --git a/src/cmd/cmd_rac.mli b/src/cmd/cmd_instrument.mli similarity index 100% rename from src/cmd/cmd_rac.mli rename to src/cmd/cmd_instrument.mli diff --git a/src/dune b/src/dune index b3ce4ec3b..9490b7f47 100644 --- a/src/dune +++ b/src/dune @@ -16,8 +16,8 @@ cmd_utils cmd_c cmd_fmt + cmd_instrument cmd_opt - cmd_rac cmd_run cmd_script cmd_sym diff --git a/test/c/eacsl/ghost/global.t b/test/c/eacsl/ghost/global.t index b7a22ccd2..b77da08d7 100644 --- a/test/c/eacsl/ghost/global.t +++ b/test/c/eacsl/ghost/global.t @@ -3,5 +3,5 @@ Model: (model (symbol_0 (i32 20))) - Reached problem!Segmentation fault (core dumped) - [139] + Reached problem! + [13] diff --git a/test/help/help.t b/test/help/help.t index c050819df..8c2feab8b 100644 --- a/test/help/help.t +++ b/test/help/help.t @@ -19,9 +19,6 @@ no subcommand should print help opt [--debug] [--output=FILE] [--unsafe] [OPTION]… ARG Optimize a module - rac [--debug] [--unsafe] [OPTION]… [ARG]… - Perform runtime assertion checking - run [OPTION]… [ARG]… Run the concrete interpreter diff --git a/test/weasel/forall.t b/test/weasel/forall.t index 7c8762278..ced67a9df 100644 --- a/test/weasel/forall.t +++ b/test/weasel/forall.t @@ -1,4 +1,4 @@ - $ owi rac forall.wat + $ owi instrument forall.wat $ owi sym forall.instrumented.wat --debug parsing ... checking ... @@ -11,13 +11,13 @@ interpreting ... stack : [ ] running instr: call 7 - calling func : func __rac_start + calling func : func __weasel_start stack : [ ] - running instr: (block $__rac_forall (result i32) + running instr: (block $__weasel_forall (result i32) i32.const 1 local.set 1 i32.const 1 - (loop $__rac_loop (param i32) (result i32) + (loop $__weasel_loop (param i32) (result i32) local.get 1 i32.const 100 i32.le_s @@ -42,7 +42,7 @@ stack : [ ] running instr: i32.const 1 stack : [ (i32 1) ] - running instr: (loop $__rac_loop (param i32) (result i32) + running instr: (loop $__weasel_loop (param i32) (result i32) local.get 1 i32.const 100 i32.le_s diff --git a/test/weasel/plus.t b/test/weasel/plus.t index 2fa06f9a3..df96461d3 100644 --- a/test/weasel/plus.t +++ b/test/weasel/plus.t @@ -1,4 +1,4 @@ - $ owi rac plus.wat + $ owi instrument plus.wat $ owi sym plus.instrumented.wat All OK $ owi sym plus.instrumented.wasm From 711790c959c4f3df167eac3473f4fac4b8f00897 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Tue, 27 Aug 2024 15:30:49 +0200 Subject: [PATCH 43/51] add option `--symbolic` to `owi instrument` --- src/ast/code_generator.ml | 106 +++++++++---------------------------- src/ast/code_generator.mli | 2 +- src/bin/owi.ml | 6 ++- src/cmd/cmd_instrument.ml | 10 ++-- src/cmd/cmd_instrument.mli | 2 +- 5 files changed, 38 insertions(+), 88 deletions(-) diff --git a/src/ast/code_generator.ml b/src/ast/code_generator.ml index 34ea4561b..0a276b4e6 100644 --- a/src/ast/code_generator.ml +++ b/src/ast/code_generator.ml @@ -17,11 +17,6 @@ type type_env = ; copy : binary expr ; void_to_i32 : binary indice ; i32_to_i32 : binary indice - ; _owi_i32 : binary indice - ; _owi_i64 : binary indice - ; _owi_f32 : binary indice - ; _owi_f64 : binary indice - ; _owi_assume : binary indice ; owi_assert : binary indice } @@ -68,50 +63,6 @@ let build_type_env (m : modul) | Some i -> (types, Raw i) | None -> (Array.append types [| i32_to_i32 |], Raw (Array.length types)) in - - let _owi_i32 = - match - Array.find_index - (fun (name, _) -> String.equal "i32_symbol" name) - owi_funcs - with - | Some i -> Raw i - | None -> assert false - in - let _owi_i64 = - match - Array.find_index - (fun (name, _) -> String.equal "i64_symbol" name) - owi_funcs - with - | Some i -> Raw i - | None -> assert false - in - let _owi_f32 = - match - Array.find_index - (fun (name, _) -> String.equal "f32_symbol" name) - owi_funcs - with - | Some i -> Raw i - | None -> assert false - in - let _owi_f64 = - match - Array.find_index - (fun (name, _) -> String.equal "f64_symbol" name) - owi_funcs - with - | Some i -> Raw i - | None -> assert false - in - let _owi_assume = - match - Array.find_index (fun (name, _) -> String.equal "assume" name) owi_funcs - with - | Some i -> Raw i - | None -> assert false - in let owi_assert = match Array.find_index (fun (name, _) -> String.equal "assert" name) owi_funcs @@ -128,11 +79,6 @@ let build_type_env (m : modul) ; copy ; void_to_i32 ; i32_to_i32 - ; _owi_i32 - ; _owi_i64 - ; _owi_f32 - ; _owi_f64 - ; _owi_assume ; owi_assert } , { m with types } ) @@ -489,9 +435,11 @@ let prop_generate tenv : binary prop -> (type_env * binary expr) Result.t = let+ tenv, expr = prop_generate_aux tenv pr in (tenv, expr @ [ Call tenv.owi_assert ]) -let subst_index ?(subst_custom = false) (old_index : int) (index : int) +let subst_index ?(subst_custom = false) (subst_task : (int * int) list) (m : modul) : modul = - let subst i = if i = old_index then index else i in + let subst i = + match List.assoc_opt i subst_task with Some j -> j | None -> i + in let rec subst_instr (instr : binary instr) : binary instr = match instr with | Ref_func (Raw i) -> Ref_func (Raw (subst i)) @@ -584,16 +532,15 @@ let rec binder_locals = function let contract_generate (owi_funcs : (string * int) array) (m : modul) ({ funcid = Raw old_index; preconditions; postconditions } : binary Contract.t) : modul Result.t = - let func = m.func in - let func_num = Array.length func in + let func_num = Array.length m.func in let* old_id, Bt_raw (ty_index, old_type) = if old_index < 0 || old_index >= func_num then Error (`Contract_unknown_func (Raw old_index)) else - match func.(old_index) with + match m.func.(old_index) with | Runtime.Local { id; type_f; _ } -> ( match id with - | Some id -> Ok (id, type_f) + | Some name -> Ok (name, type_f) | None -> Ok (Fmt.str "func_%i" old_index, type_f) ) | Imported { modul; name; assigned_name; desc } -> ( match assigned_name with @@ -637,9 +584,9 @@ let contract_generate (owi_funcs : (string * int) array) (m : modul) let body = precond_checker @ call @ postcond_checker @ return in - let m = subst_index old_index index m in + let m = subst_index [ (old_index, index) ] m in let func = - Array.append func + Array.append m.func [| Runtime.Local { type_f = Bt_raw (ty_index, old_type); locals; body; id = Some id } |] @@ -659,17 +606,8 @@ let contracts_generate (owi_funcs : (string * int) array) (m : modul) let contracts = join (List.sort Contract.compare_funcid contracts) in list_fold_left (contract_generate owi_funcs) m contracts -let add_owi_funcs (m : modul) : modul * (string * int) array = - let owi_funcs : (string * binary func_type) array = - [| ("i32_symbol", ([], [ Num_type I32 ])) - ; ("i64_symbol", ([], [ Num_type I64 ])) - ; ("f32_symbol", ([], [ Num_type F32 ])) - ; ("f64_symbol", ([], [ Num_type F64 ])) - ; ("assume", ([ (None, Num_type I32) ], [])) - ; ("assert", ([ (None, Num_type I32) ], [])) - |] - in - +let add_owi_funcs (owi_funcs : (string * binary func_type) array) (m : modul) : + modul * (string * int) array = (* update module field `types` *) let update_types () : modul * (string * (binary func_type * int)) array = let func_type2rec_type : binary func_type -> binary rec_type = @@ -729,12 +667,7 @@ let add_owi_funcs (m : modul) : modul * (string * int) array = let subst_task = List.init (Array.length locals) (fun i -> (i, Array.length imported + i)) in - let m = - List.fold_left - (fun m (old_index, index) -> - subst_index ~subst_custom:true old_index index m ) - m subst_task - in + let m = subst_index ~subst_custom:true subst_task m in let owi_funcs = Array.mapi @@ -745,8 +678,19 @@ let add_owi_funcs (m : modul) : modul * (string * int) array = in update_func () -let generate (m : modul) : modul Result.t = - let m, owi_funcs = add_owi_funcs m in +let generate (symbolic : bool) (m : modul) : modul Result.t = + let owi_funcs = + if symbolic then + [| ("i32_symbol", ([], [ Num_type I32 ])) + ; ("i64_symbol", ([], [ Num_type I64 ])) + ; ("f32_symbol", ([], [ Num_type F32 ])) + ; ("f64_symbol", ([], [ Num_type F64 ])) + ; ("assume", ([ (None, Num_type I32) ], [])) + ; ("assert", ([ (None, Num_type I32) ], [])) + |] + else [| ("assert", ([ (None, Num_type I32) ], [])) |] + in + let m, owi_funcs = add_owi_funcs owi_funcs m in contracts_generate owi_funcs m (List.filter_map (function From_annot (Annot.Contract c) -> Some c | _ -> None) diff --git a/src/ast/code_generator.mli b/src/ast/code_generator.mli index 1d7c48d81..2f4eca1c1 100644 --- a/src/ast/code_generator.mli +++ b/src/ast/code_generator.mli @@ -2,4 +2,4 @@ (* Copyright © 2021-2024 OCamlPro *) (* Written by the Owi programmers *) -val generate : Binary.modul -> Binary.modul Result.t +val generate : bool -> Binary.modul -> Binary.modul Result.t diff --git a/src/bin/owi.ml b/src/bin/owi.ml index fda567ad7..43924f473 100644 --- a/src/bin/owi.ml +++ b/src/bin/owi.ml @@ -103,6 +103,10 @@ let solver = & opt solver_conv Smtml.Solver_dispatcher.Z3_solver & info [ "solver"; "s" ] ~doc ) +let symbolic = + let doc = "generate instrumented module that depends on symbolic execution" in + Cmdliner.Arg.(value & flag & info [ "symbolic" ] ~doc) + let unsafe = let doc = "skip typechecking pass" in Cmdliner.Arg.(value & flag & info [ "unsafe"; "u" ] ~doc) @@ -208,7 +212,7 @@ let instrument_cmd = let man = [] @ shared_man in Cmd.info "instrument" ~version ~doc ~sdocs ~man in - Cmd.v info Term.(const Cmd_instrument.cmd $ debug $ unsafe $ files) + Cmd.v info Term.(const Cmd_instrument.cmd $ debug $ unsafe $ symbolic $ files) let run_cmd = let open Cmdliner in diff --git a/src/cmd/cmd_instrument.ml b/src/cmd/cmd_instrument.ml index 2af25234b..bf124b7d4 100644 --- a/src/cmd/cmd_instrument.ml +++ b/src/cmd/cmd_instrument.ml @@ -4,14 +4,16 @@ open Syntax -let cmd_one unsafe file = +let cmd_one unsafe symbolic file = let _dir, filename = Fpath.split_base file in let filename, ext = Fpath.split_ext filename in match ext with | ".wat" -> let* text_modul = Parse.Text.Module.from_file file in let* binary_modul = Compile.Text.until_binary ~unsafe text_modul in - let* instrumented_binary_modul = Code_generator.generate binary_modul in + let* instrumented_binary_modul = + Code_generator.generate symbolic binary_modul + in let instrumented_text_modul = Binary_to_text.modul instrumented_binary_modul in @@ -24,6 +26,6 @@ let cmd_one unsafe file = Bos.OS.File.writef filename "%a" Text.pp_modul instrumented_text_modul | ext -> Error (`Unsupported_file_extension ext) -let cmd debug unsafe files = +let cmd debug unsafe symbolic files = if debug then Log.debug_on := true; - list_iter (cmd_one unsafe) files + list_iter (cmd_one unsafe symbolic) files diff --git a/src/cmd/cmd_instrument.mli b/src/cmd/cmd_instrument.mli index b26bccd2a..96aaaceb4 100644 --- a/src/cmd/cmd_instrument.mli +++ b/src/cmd/cmd_instrument.mli @@ -2,4 +2,4 @@ (* Copyright © 2021-2024 OCamlPro *) (* Written by the Owi programmers *) -val cmd : bool -> bool -> Fpath.t list -> unit Result.t +val cmd : bool -> bool -> bool -> Fpath.t list -> unit Result.t From 3517a43d61dd8d3fe0642ec5bf1b6287679c09ef Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Tue, 27 Aug 2024 16:43:35 +0200 Subject: [PATCH 44/51] add options --rac and --srac --- example/README.md | 2 +- example/conc/README.md | 6 + example/define_host_function/README.md | 8 +- example/define_host_function/extern.ml | 4 +- example/define_host_function/extern_mem.ml | 4 +- .../life_game/life_console.ml | 8 +- .../life_game/life_graphics.ml | 8 +- example/lib/README.md | 2 +- example/run/README.md | 3 + example/sym/README.md | 6 + src/ast/binary_encoder.ml | 4 +- src/ast/code_generator.ml | 4 +- src/ast/compile.ml | 61 +- src/ast/compile.mli | 48 +- src/bin/owi.ml | 23 +- src/cmd/cmd_c.ml | 4 +- src/cmd/cmd_conc.ml | 16 +- src/cmd/cmd_conc.mli | 2 + src/cmd/cmd_instrument.ml | 3 +- src/cmd/cmd_opt.ml | 3 +- src/cmd/cmd_run.ml | 10 +- src/cmd/cmd_run.mli | 2 +- src/cmd/cmd_sym.ml | 13 +- src/cmd/cmd_sym.mli | 2 + src/cmd/cmd_validate.ml | 3 +- src/script/script.ml | 22 +- test/fmt/print_simplified.ml | 4 +- test/fuzz/interprets.ml | 12 +- test/help/help.t | 4 + test/weasel/dune | 2 +- test/weasel/forall.t | 525 ++++-------------- test/weasel/plus.t | 188 ++++++- test/weasel/sum.t | 272 +++++++++ test/weasel/sum.wat | 18 + 34 files changed, 775 insertions(+), 521 deletions(-) create mode 100644 test/weasel/sum.t create mode 100644 test/weasel/sum.wat diff --git a/example/README.md b/example/README.md index 9c3c773de..5c6dc10bc 100644 --- a/example/README.md +++ b/example/README.md @@ -38,7 +38,7 @@ COMMANDS fmt [--inplace] [OPTION]… [ARG]… Format a .wat or .wast file - instrument [--debug] [--unsafe] [OPTION]… [ARG]… + instrument [--debug] [--symbolic] [--unsafe] [OPTION]… [ARG]… Generate an instrumented file with runtime assertion checking coming from Weasel specifications diff --git a/example/conc/README.md b/example/conc/README.md index 4fa958b67..e13a4e543 100644 --- a/example/conc/README.md +++ b/example/conc/README.md @@ -71,9 +71,15 @@ OPTIONS -p, --profiling profiling mode + --rac + runtime assertion checking mode + -s VAL, --solver=VAL (absent=Z3) SMT solver to use + --srac + symbolic runtime assertion checking mode + -u, --unsafe skip typechecking pass diff --git a/example/define_host_function/README.md b/example/define_host_function/README.md index 5545e78fb..1d9146659 100644 --- a/example/define_host_function/README.md +++ b/example/define_host_function/README.md @@ -85,8 +85,8 @@ let pure_wasm_module = (* our pure wasm module, linked with `sausage` *) let module_to_run, link_state = match - Compile.Text.until_link link_state ~unsafe:false ~optimize:true ~name:None - pure_wasm_module + Compile.Text.until_link link_state ~unsafe:false ~rac:false ~srac:false + ~optimize:true ~name:None pure_wasm_module with | Error _ -> assert false | Ok v -> v @@ -203,8 +203,8 @@ let pure_wasm_module = (* our pure wasm module, linked with `chorizo` *) let module_to_run, link_state = match - Compile.Text.until_link link_state ~unsafe:false ~optimize:true ~name:None - pure_wasm_module + Compile.Text.until_link link_state ~unsafe:false ~rac:false ~srac:false + ~optimize:true ~name:None pure_wasm_module with | Error _ -> assert false | Ok v -> v diff --git a/example/define_host_function/extern.ml b/example/define_host_function/extern.ml index 8d4caccb0..b31dde79e 100644 --- a/example/define_host_function/extern.ml +++ b/example/define_host_function/extern.ml @@ -39,8 +39,8 @@ let pure_wasm_module = (* our pure wasm module, linked with `sausage` *) let module_to_run, link_state = match - Compile.Text.until_link link_state ~unsafe:false ~optimize:true ~name:None - pure_wasm_module + Compile.Text.until_link link_state ~unsafe:false ~rac:false ~srac:false + ~optimize:true ~name:None pure_wasm_module with | Error _ -> assert false | Ok v -> v diff --git a/example/define_host_function/extern_mem.ml b/example/define_host_function/extern_mem.ml index 911a777f4..3204df3c5 100644 --- a/example/define_host_function/extern_mem.ml +++ b/example/define_host_function/extern_mem.ml @@ -38,8 +38,8 @@ let pure_wasm_module = (* our pure wasm module, linked with `chorizo` *) let module_to_run, link_state = match - Compile.Text.until_link link_state ~unsafe:false ~optimize:true ~name:None - pure_wasm_module + Compile.Text.until_link link_state ~unsafe:false ~rac:false ~srac:false + ~optimize:true ~name:None pure_wasm_module with | Error _ -> assert false | Ok v -> v diff --git a/example/define_host_function/life_game/life_console.ml b/example/define_host_function/life_game/life_console.ml index ef59c52a0..a97b1c6c7 100644 --- a/example/define_host_function/life_game/life_console.ml +++ b/example/define_host_function/life_game/life_console.ml @@ -64,8 +64,8 @@ let pure_wasm_module_1 = (* our first pure wasm module, linked with `life_ext` *) let module_to_run, link_state = match - Compile.Text.until_link link_state ~unsafe:false ~optimize:true - ~name:(Some "life") pure_wasm_module_1 + Compile.Text.until_link link_state ~unsafe:false ~rac:false ~srac:false + ~optimize:true ~name:(Some "life") pure_wasm_module_1 with | Error _ -> assert false | Ok (m, state) -> (m, state) @@ -85,8 +85,8 @@ let pure_wasm_module_2 = (* our second pure wasm module, linked with `life_ext` and `life` interpreted before *) let module_to_run, link_state = match - Compile.Text.until_link link_state ~unsafe:false ~optimize:true ~name:None - pure_wasm_module_2 + Compile.Text.until_link link_state ~unsafe:false ~rac:false ~srac:false + ~optimize:true ~name:None pure_wasm_module_2 with | Error _ -> assert false | Ok (m, state) -> (m, state) diff --git a/example/define_host_function/life_game/life_graphics.ml b/example/define_host_function/life_game/life_graphics.ml index dcfd61892..ba5ea580b 100644 --- a/example/define_host_function/life_game/life_graphics.ml +++ b/example/define_host_function/life_game/life_graphics.ml @@ -76,8 +76,8 @@ let pure_wasm_module_1 = (* our first pure wasm module, linked with `life_ext` *) let module_to_run, link_state = match - Compile.Text.until_link link_state ~unsafe:false ~optimize:true - ~name:(Some "life") pure_wasm_module_1 + Compile.Text.until_link link_state ~unsafe:false ~rac:false ~srac:false + ~optimize:true ~name:(Some "life") pure_wasm_module_1 with | Error _ -> assert false | Ok (m, state) -> (m, state) @@ -97,8 +97,8 @@ let pure_wasm_module_2 = (* our second pure wasm module, linked with `life_ext` and `life` interpreted before *) let module_to_run, link_state = match - Compile.Text.until_link link_state ~unsafe:false ~optimize:true ~name:None - pure_wasm_module_2 + Compile.Text.until_link link_state ~unsafe:false ~rac:false ~srac:false + ~optimize:true ~name:None pure_wasm_module_2 with | Error _ -> assert false | Ok (m, state) -> (m, state) diff --git a/example/lib/README.md b/example/lib/README.md index 77b6b7d79..265066908 100644 --- a/example/lib/README.md +++ b/example/lib/README.md @@ -16,7 +16,7 @@ val filename : Fpath.t = val m : Text.modul = ... # let module_to_run, link_state = - match Compile.Text.until_link Link.empty_state ~unsafe:false ~optimize:false ~name:None m with + match Compile.Text.until_link Link.empty_state ~unsafe:false ~rac:false ~srac:false ~optimize:false ~name:None m with | Ok v -> v | Error _ -> assert false;; val module_to_run : '_weak1 Link.module_to_run = diff --git a/example/run/README.md b/example/run/README.md index 781d3b20e..7a549eb66 100644 --- a/example/run/README.md +++ b/example/run/README.md @@ -70,6 +70,9 @@ OPTIONS -p, --profiling profiling mode + --rac + runtime assertion checking mode + -u, --unsafe skip typechecking pass diff --git a/example/sym/README.md b/example/sym/README.md index 40b9c9ca5..892c77eb0 100644 --- a/example/sym/README.md +++ b/example/sym/README.md @@ -75,9 +75,15 @@ OPTIONS -p, --profiling profiling mode + --rac + runtime assertion checking mode + -s VAL, --solver=VAL (absent=Z3) SMT solver to use + --srac + symbolic runtime assertion checking mode + -u, --unsafe skip typechecking pass diff --git a/src/ast/binary_encoder.ml b/src/ast/binary_encoder.ml index 360b9629e..f029c525b 100644 --- a/src/ast/binary_encoder.ml +++ b/src/ast/binary_encoder.ml @@ -767,6 +767,8 @@ let write_file outfile filename content = let convert (outfile : Fpath.t option) (filename : Fpath.t) ~unsafe ~optimize m = Log.debug0 "bin encoding ...@\n"; - let* m = Compile.Text.until_optimize ~unsafe ~optimize m in + let* m = + Compile.Text.until_optimize ~unsafe ~rac:false ~srac:false ~optimize m + in let content = encode m in write_file outfile filename content diff --git a/src/ast/code_generator.ml b/src/ast/code_generator.ml index 0a276b4e6..81ecb7663 100644 --- a/src/ast/code_generator.ml +++ b/src/ast/code_generator.ml @@ -210,10 +210,10 @@ let rec term_generate tenv (term : binary term) : | Result (Some i) -> if i < 0 || i >= Array.length tenv.result_types then Error (`Spec_invalid_indice (Int.to_string i)) - else Ok ([ Local_get (Raw i) ], tenv.result_types.(i)) + else Ok ([ Local_get (tenv.result i) ], tenv.result_types.(i)) | Result None -> if Array.length tenv.result_types = 0 then Error (`Spec_invalid_indice "0") - else Ok ([ Local_get (Raw 0) ], tenv.result_types.(0)) + else Ok ([ Local_get (tenv.result 0) ], tenv.result_types.(0)) let binpred_generate (b : binpred) (expr1 : binary expr) (ty1 : binary val_type) (expr2 : binary expr) (ty2 : binary val_type) : binary expr Result.t = diff --git a/src/ast/compile.ml b/src/ast/compile.ml index 043e4c56b..52a32d129 100644 --- a/src/ast/compile.ml +++ b/src/ast/compile.ml @@ -16,27 +16,32 @@ module Text = struct let* m = until_group ~unsafe m in Assigned.of_grouped m - let until_binary ~unsafe m = + let until_binary ~unsafe ~rac ~srac m = let* m = until_assign ~unsafe m in - Rewrite.modul m + let* m = Rewrite.modul m in + if srac then Code_generator.generate true m + else if rac then Code_generator.generate false m + else Ok m - let until_binary_validate ~unsafe m = - let* m = until_binary ~unsafe m in + let until_binary_validate ~unsafe ~rac ~srac m = + let* m = until_binary ~unsafe ~rac ~srac m in if unsafe then Ok m else let+ () = Binary_validate.modul m in m - let until_optimize ~unsafe ~optimize m = - let+ m = until_binary_validate ~unsafe m in + let until_optimize ~unsafe ~rac ~srac ~optimize m = + let+ m = until_binary_validate ~unsafe ~rac ~srac m in if optimize then Optimize.modul m else m - let until_link ~unsafe ~optimize ~name link_state m = - let* m = until_optimize ~unsafe ~optimize m in + let until_link ~unsafe ~rac ~srac ~optimize ~name link_state m = + let* m = until_optimize ~unsafe ~rac ~srac ~optimize m in Link.modul link_state ~name m - let until_interpret ~unsafe ~optimize ~name link_state m = - let* m, link_state = until_link ~unsafe ~optimize ~name link_state m in + let until_interpret ~unsafe ~rac ~srac ~optimize ~name link_state m = + let* m, link_state = + until_link ~unsafe ~rac ~srac ~optimize ~name link_state m + in let+ () = Interpret.Concrete.modul link_state.envs m in link_state end @@ -63,53 +68,57 @@ module Binary = struct end module Any = struct - let until_binary_validate ~unsafe = function - | Kind.Wat m -> Text.until_binary_validate ~unsafe m + let until_binary_validate ~unsafe ~rac ~srac = function + | Kind.Wat m -> Text.until_binary_validate ~unsafe ~rac ~srac m | Wasm m -> Binary.until_binary_validate ~unsafe m | Wast _ | Ocaml _ -> assert false - let until_optimize ~unsafe ~optimize = function - | Kind.Wat m -> Text.until_optimize ~unsafe ~optimize m + let until_optimize ~unsafe ~rac ~srac ~optimize = function + | Kind.Wat m -> Text.until_optimize ~unsafe ~rac ~srac ~optimize m | Wasm m -> Binary.until_optimize ~unsafe ~optimize m | Wast _ | Ocaml _ -> assert false - let until_link ~unsafe ~optimize ~name link_state = function - | Kind.Wat m -> Text.until_link ~unsafe ~optimize ~name link_state m + let until_link ~unsafe ~rac ~srac ~optimize ~name link_state = function + | Kind.Wat m -> + Text.until_link ~unsafe ~rac ~srac ~optimize ~name link_state m | Wasm m -> Binary.until_link ~unsafe ~optimize ~name link_state m | Wast _ | Ocaml _ -> assert false - let until_interpret ~unsafe ~optimize ~name link_state = function - | Kind.Wat m -> Text.until_interpret ~unsafe ~optimize ~name link_state m + let until_interpret ~unsafe ~rac ~srac ~optimize ~name link_state = function + | Kind.Wat m -> + Text.until_interpret ~unsafe ~rac ~srac ~optimize ~name link_state m | Wasm m -> Binary.until_interpret ~unsafe ~optimize ~name link_state m | Wast _ | Ocaml _ -> assert false end module File = struct - let until_binary_validate ~unsafe filename = + let until_binary_validate ~unsafe ~rac ~srac filename = let* m = Parse.guess_from_file filename in match m with - | Kind.Wat m -> Text.until_binary_validate ~unsafe m + | Kind.Wat m -> Text.until_binary_validate ~unsafe ~rac ~srac m | Wasm m -> Binary.until_binary_validate ~unsafe m | Wast _ | Ocaml _ -> assert false - let until_optimize ~unsafe ~optimize filename = + let until_optimize ~unsafe ~rac ~srac ~optimize filename = let* m = Parse.guess_from_file filename in match m with - | Kind.Wat m -> Text.until_optimize ~unsafe ~optimize m + | Kind.Wat m -> Text.until_optimize ~unsafe ~rac ~srac ~optimize m | Wasm m -> Binary.until_optimize ~unsafe ~optimize m | Wast _ | Ocaml _ -> assert false - let until_link ~unsafe ~optimize ~name link_state filename = + let until_link ~unsafe ~rac ~srac ~optimize ~name link_state filename = let* m = Parse.guess_from_file filename in match m with - | Kind.Wat m -> Text.until_link ~unsafe ~optimize ~name link_state m + | Kind.Wat m -> + Text.until_link ~unsafe ~rac ~srac ~optimize ~name link_state m | Wasm m -> Binary.until_link ~unsafe ~optimize ~name link_state m | Wast _ | Ocaml _ -> assert false - let until_interpret ~unsafe ~optimize ~name link_state filename = + let until_interpret ~unsafe ~rac ~srac ~optimize ~name link_state filename = let* m = Parse.guess_from_file filename in match m with - | Kind.Wat m -> Text.until_interpret ~unsafe ~optimize ~name link_state m + | Kind.Wat m -> + Text.until_interpret ~unsafe ~rac ~srac ~optimize ~name link_state m | Wasm m -> Binary.until_interpret ~unsafe ~optimize ~name link_state m | Wast _ | Ocaml _ -> assert false end diff --git a/src/ast/compile.mli b/src/ast/compile.mli index 0bfa84106..5227df55b 100644 --- a/src/ast/compile.mli +++ b/src/ast/compile.mli @@ -6,15 +6,26 @@ module Any : sig val until_binary_validate : - unsafe:bool -> 'extern_func Kind.t -> Binary.modul Result.t + unsafe:bool + -> rac:bool + -> srac:bool + -> 'extern_func Kind.t + -> Binary.modul Result.t val until_optimize : - unsafe:bool -> optimize:bool -> 'extern_func Kind.t -> Binary.modul Result.t + unsafe:bool + -> rac:bool + -> srac:bool + -> optimize:bool + -> 'extern_func Kind.t + -> Binary.modul Result.t (** compile a module with a given link state and produce a new link state and a runnable module *) val until_link : unsafe:bool + -> rac:bool + -> srac:bool -> optimize:bool -> name:string option -> 'extern_func Link.state @@ -25,6 +36,8 @@ module Any : sig link state *) val until_interpret : unsafe:bool + -> rac:bool + -> srac:bool -> optimize:bool -> name:string option -> Concrete_value.Func.extern_func Link.state @@ -33,15 +46,23 @@ module Any : sig end module File : sig - val until_binary_validate : unsafe:bool -> Fpath.t -> Binary.modul Result.t + val until_binary_validate : + unsafe:bool -> rac:bool -> srac:bool -> Fpath.t -> Binary.modul Result.t val until_optimize : - unsafe:bool -> optimize:bool -> Fpath.t -> Binary.modul Result.t + unsafe:bool + -> rac:bool + -> srac:bool + -> optimize:bool + -> Fpath.t + -> Binary.modul Result.t (** compile a file with a given link state and produce a new link state and a runnable module *) val until_link : unsafe:bool + -> rac:bool + -> srac:bool -> optimize:bool -> name:string option -> 'extern_func Link.state @@ -52,6 +73,8 @@ module File : sig link state *) val until_interpret : unsafe:bool + -> rac:bool + -> srac:bool -> optimize:bool -> name:string option -> Concrete_value.Func.extern_func Link.state @@ -62,17 +85,26 @@ end module Text : sig val until_text_validate : unsafe:bool -> Text.modul -> Text.modul Result.t - val until_binary : unsafe:bool -> Text.modul -> Binary.modul Result.t + val until_binary : + unsafe:bool -> rac:bool -> srac:bool -> Text.modul -> Binary.modul Result.t - val until_binary_validate : unsafe:bool -> Text.modul -> Binary.modul Result.t + val until_binary_validate : + unsafe:bool -> rac:bool -> srac:bool -> Text.modul -> Binary.modul Result.t val until_optimize : - unsafe:bool -> optimize:bool -> Text.modul -> Binary.modul Result.t + unsafe:bool + -> rac:bool + -> srac:bool + -> optimize:bool + -> Text.modul + -> Binary.modul Result.t (** compile a module with a given link state and produce a new link state and a runnable module *) val until_link : unsafe:bool + -> rac:bool + -> srac:bool -> optimize:bool -> name:string option -> 'f Link.state @@ -83,6 +115,8 @@ module Text : sig link state *) val until_interpret : unsafe:bool + -> rac:bool + -> srac:bool -> optimize:bool -> name:string option -> Concrete_value.Func.extern_func Link.state diff --git a/src/bin/owi.ml b/src/bin/owi.ml index 43924f473..53ae9342e 100644 --- a/src/bin/owi.ml +++ b/src/bin/owi.ml @@ -88,6 +88,14 @@ let profiling = let doc = "profiling mode" in Cmdliner.Arg.(value & flag & info [ "profiling"; "p" ] ~doc) +let rac = + let doc = "runtime assertion checking mode" in + Cmdliner.Arg.(value & flag & info [ "rac" ] ~doc) + +let srac = + let doc = "symbolic runtime assertion checking mode" in + Cmdliner.Arg.(value & flag & info [ "srac" ] ~doc) + let eacsl = let doc = "e-acsl mode, refer to \ @@ -222,7 +230,8 @@ let run_cmd = Cmd.info "run" ~version ~doc ~sdocs ~man in Cmd.v info - Term.(const Cmd_run.cmd $ profiling $ debug $ unsafe $ optimize $ files) + Term.( + const Cmd_run.cmd $ profiling $ debug $ unsafe $ rac $ optimize $ files ) let validate_cmd = let open Cmdliner in @@ -254,9 +263,9 @@ let sym_cmd = in Cmd.v info Term.( - const Cmd_sym.cmd $ profiling $ debug $ unsafe $ optimize $ workers - $ no_stop_at_failure $ no_values $ deterministic_result_order $ fail_mode - $ workspace $ solver $ files ) + const Cmd_sym.cmd $ profiling $ debug $ unsafe $ rac $ srac $ optimize + $ workers $ no_stop_at_failure $ no_values $ deterministic_result_order + $ fail_mode $ workspace $ solver $ files ) let conc_cmd = let open Cmdliner in @@ -267,9 +276,9 @@ let conc_cmd = in Cmd.v info Term.( - const Cmd_conc.cmd $ profiling $ debug $ unsafe $ optimize $ workers - $ no_stop_at_failure $ no_values $ deterministic_result_order $ fail_mode - $ workspace $ solver $ files ) + const Cmd_conc.cmd $ profiling $ debug $ unsafe $ rac $ srac $ optimize + $ workers $ no_stop_at_failure $ no_values $ deterministic_result_order + $ fail_mode $ workspace $ solver $ files ) let wasm2wat_cmd = let open Cmdliner in diff --git a/src/cmd/cmd_c.ml b/src/cmd/cmd_c.ml index e719a3dc4..623ba1064 100644 --- a/src/cmd/cmd_c.ml +++ b/src/cmd/cmd_c.ml @@ -195,5 +195,5 @@ let cmd debug arch property _testcomp workspace workers opt_lvl includes files let workspace = Fpath.(workspace / "test-suite") in let files = [ modul ] in (if concolic then Cmd_conc.cmd else Cmd_sym.cmd) - profiling debug unsafe optimize workers no_stop_at_failure no_values - deterministic_result_order fail_mode workspace solver files + profiling debug unsafe false false optimize workers no_stop_at_failure + no_values deterministic_result_order fail_mode workspace solver files diff --git a/src/cmd/cmd_conc.ml b/src/cmd/cmd_conc.ml index 805a47ed1..b7c8630fc 100644 --- a/src/cmd/cmd_conc.ml +++ b/src/cmd/cmd_conc.ml @@ -16,10 +16,11 @@ let ( let** ) (t : 'a Result.t Choice.t) (f : 'a -> 'b Result.t Choice.t) : Choice.bind t (fun t -> match t with Error e -> Choice.return (Error e) | Ok x -> f x ) -let simplify_then_link ~unsafe ~optimize link_state m = +let simplify_then_link ~unsafe ~rac ~srac ~optimize link_state m = let* m = match m with - | Kind.Wat _ | Wasm _ -> Compile.Any.until_binary_validate ~unsafe m + | Kind.Wat _ | Wasm _ -> + Compile.Any.until_binary_validate ~unsafe ~rac ~srac m | Wast _ -> Error (`Msg "can't run concolic interpreter on a script") | Ocaml _ -> assert false in @@ -30,7 +31,7 @@ let simplify_then_link ~unsafe ~optimize link_state m = let module_to_run = Concolic.convert_module_to_run m in (link_state, module_to_run) -let simplify_then_link_files ~unsafe ~optimize filenames = +let simplify_then_link_files ~unsafe ~rac ~srac ~optimize filenames = let link_state = Link.empty_state in let link_state = Link.extern_module' link_state ~name:"symbolic" @@ -48,7 +49,7 @@ let simplify_then_link_files ~unsafe ~optimize filenames = let* link_state, modules_to_run = acc in let* m0dule = Parse.guess_from_file filename in let+ link_state, module_to_run = - simplify_then_link ~unsafe ~optimize link_state m0dule + simplify_then_link ~unsafe ~rac ~srac ~optimize link_state m0dule in (link_state, module_to_run :: modules_to_run) ) (Ok (link_state, [])) @@ -414,8 +415,9 @@ let run solver tree link_state modules_to_run = during evaluation (OS, syntax error, etc.), except for Trap and Assert, which are handled here. Most of the computations are done in the Result monad, hence the let*. *) -let cmd profiling debug unsafe optimize _workers _no_stop_at_failure no_values - _deterministic_result_order _fail_mode (workspace : Fpath.t) solver files = +let cmd profiling debug unsafe rac srac optimize _workers _no_stop_at_failure + no_values _deterministic_result_order _fail_mode (workspace : Fpath.t) solver + files = if profiling then Log.profiling_on := true; if debug then Log.debug_on := true; (* deterministic_result_order implies no_stop_at_failure *) @@ -423,7 +425,7 @@ let cmd profiling debug unsafe optimize _workers _no_stop_at_failure no_values let* _created_dir = Bos.OS.Dir.create ~path:true ~mode:0o755 workspace in let solver = Solver.fresh solver () in let* link_state, modules_to_run = - simplify_then_link_files ~unsafe ~optimize files + simplify_then_link_files ~unsafe ~rac ~srac ~optimize files in let tree = fresh_tree [] in let* result = run solver tree link_state modules_to_run in diff --git a/src/cmd/cmd_conc.mli b/src/cmd/cmd_conc.mli index 5d841000a..4173bca0c 100644 --- a/src/cmd/cmd_conc.mli +++ b/src/cmd/cmd_conc.mli @@ -7,6 +7,8 @@ val cmd : -> bool -> bool -> bool + -> bool + -> bool -> int -> bool -> bool diff --git a/src/cmd/cmd_instrument.ml b/src/cmd/cmd_instrument.ml index bf124b7d4..6138489a7 100644 --- a/src/cmd/cmd_instrument.ml +++ b/src/cmd/cmd_instrument.ml @@ -10,9 +10,8 @@ let cmd_one unsafe symbolic file = match ext with | ".wat" -> let* text_modul = Parse.Text.Module.from_file file in - let* binary_modul = Compile.Text.until_binary ~unsafe text_modul in let* instrumented_binary_modul = - Code_generator.generate symbolic binary_modul + Compile.Text.until_binary ~unsafe ~rac:true ~srac:symbolic text_modul in let instrumented_text_modul = Binary_to_text.modul instrumented_binary_modul diff --git a/src/cmd/cmd_opt.ml b/src/cmd/cmd_opt.ml index 95ff24af6..df5ea1114 100644 --- a/src/cmd/cmd_opt.ml +++ b/src/cmd/cmd_opt.ml @@ -5,7 +5,8 @@ open Syntax let optimize_file ~unsafe filename = - Compile.File.until_optimize ~unsafe ~optimize:true filename + Compile.File.until_optimize ~unsafe ~rac:false ~srac:false ~optimize:true + filename let print_or_emit ~unsafe file outfile = let* m = optimize_file ~unsafe file in diff --git a/src/cmd/cmd_run.ml b/src/cmd/cmd_run.ml index 689dc2e65..3f159327d 100644 --- a/src/cmd/cmd_run.ml +++ b/src/cmd/cmd_run.ml @@ -4,15 +4,15 @@ open Syntax -let run_file ~unsafe ~optimize filename = +let run_file ~unsafe ~rac ~optimize filename = let name = None in let+ (_ : _ Link.state) = - Compile.File.until_interpret ~unsafe ~optimize ~name Link.empty_state - filename + Compile.File.until_interpret ~unsafe ~rac ~srac:false ~optimize ~name + Link.empty_state filename in () -let cmd profiling debug unsafe optimize files = +let cmd profiling debug unsafe rac optimize files = if profiling then Log.profiling_on := true; if debug then Log.debug_on := true; - list_iter (run_file ~unsafe ~optimize) files + list_iter (run_file ~unsafe ~rac ~optimize) files diff --git a/src/cmd/cmd_run.mli b/src/cmd/cmd_run.mli index 5cef2e0c3..63aec0acf 100644 --- a/src/cmd/cmd_run.mli +++ b/src/cmd/cmd_run.mli @@ -2,4 +2,4 @@ (* Copyright © 2021-2024 OCamlPro *) (* Written by the Owi programmers *) -val cmd : bool -> bool -> bool -> bool -> Fpath.t list -> unit Result.t +val cmd : bool -> bool -> bool -> bool -> bool -> Fpath.t list -> unit Result.t diff --git a/src/cmd/cmd_sym.ml b/src/cmd/cmd_sym.ml index 8e445b41a..2ed266e53 100644 --- a/src/cmd/cmd_sym.ml +++ b/src/cmd/cmd_sym.ml @@ -29,8 +29,8 @@ let link_state = Link.extern_module' link_state ~name:"summaries" ~func_typ Symbolic_wasm_ffi.summaries_extern_module ) -let run_file ~unsafe ~optimize pc filename = - let*/ m = Compile.File.until_binary_validate ~unsafe filename in +let run_file ~unsafe ~rac ~srac ~optimize pc filename = + let*/ m = Compile.File.until_binary_validate ~unsafe ~rac ~srac filename in let*/ m = Cmd_utils.add_main_as_start m in let link_state = Lazy.force link_state in @@ -46,15 +46,18 @@ let run_file ~unsafe ~optimize pc filename = during evaluation (OS, syntax error, etc.), except for Trap and Assert, which are handled here. Most of the computations are done in the Result monad, hence the let*. *) -let cmd profiling debug unsafe optimize workers no_stop_at_failure no_values - deterministic_result_order fail_mode (workspace : Fpath.t) solver files = +let cmd profiling debug unsafe rac srac optimize workers no_stop_at_failure + no_values deterministic_result_order fail_mode (workspace : Fpath.t) solver + files = if profiling then Log.profiling_on := true; if debug then Log.debug_on := true; (* deterministic_result_order implies no_stop_at_failure *) let no_stop_at_failure = deterministic_result_order || no_stop_at_failure in let* _created_dir = Bos.OS.Dir.create ~path:true ~mode:0o755 workspace in let pc = Choice.return (Ok ()) in - let result = List.fold_left (run_file ~unsafe ~optimize) pc files in + let result = + List.fold_left (run_file ~unsafe ~rac ~srac ~optimize) pc files + in let thread = Thread_with_memory.init () in let res_queue = Wq.make () in let path_count = ref 0 in diff --git a/src/cmd/cmd_sym.mli b/src/cmd/cmd_sym.mli index 938f1e343..f12b4768a 100644 --- a/src/cmd/cmd_sym.mli +++ b/src/cmd/cmd_sym.mli @@ -13,6 +13,8 @@ val cmd : -> bool -> bool -> bool + -> bool + -> bool -> int -> bool -> bool diff --git a/src/cmd/cmd_validate.ml b/src/cmd/cmd_validate.ml index 53ca33445..f5c12a614 100644 --- a/src/cmd/cmd_validate.ml +++ b/src/cmd/cmd_validate.ml @@ -6,7 +6,8 @@ open Syntax let validate filename = let+ (_modul : Binary.modul) = - Compile.File.until_binary_validate ~unsafe:false filename + Compile.File.until_binary_validate ~unsafe:false ~rac:false ~srac:false + filename in () diff --git a/src/script/script.ml b/src/script/script.ml index db8fa896a..3175dc5f5 100644 --- a/src/script/script.ml +++ b/src/script/script.ml @@ -157,7 +157,8 @@ let run ~no_exhaustion ~optimize script = Log.debug0 "*** module@\n"; incr curr_module; let+ link_state = - Compile.Text.until_interpret link_state ~unsafe ~optimize ~name:None m + Compile.Text.until_interpret link_state ~unsafe ~rac:false ~srac:false + ~optimize ~name:None m in Log.debug_on := debug_on; link_state @@ -166,7 +167,8 @@ let run ~no_exhaustion ~optimize script = incr curr_module; let* m = Parse.Text.Inline_module.from_string m in let+ link_state = - Compile.Text.until_interpret link_state ~unsafe ~optimize ~name:None m + Compile.Text.until_interpret link_state ~unsafe ~rac:false ~srac:false + ~optimize ~name:None m in link_state | Text.Binary_module (id, m) -> @@ -183,7 +185,8 @@ let run ~no_exhaustion ~optimize script = Log.debug0 "*** assert_trap@\n"; incr curr_module; let* m, link_state = - Compile.Text.until_link link_state ~unsafe ~optimize ~name:None m + Compile.Text.until_link link_state ~unsafe ~rac:false ~srac:false + ~optimize ~name:None m in let got = Interpret.Concrete.modul link_state.envs m in let+ () = check_error_result expected got in @@ -201,7 +204,9 @@ let run ~no_exhaustion ~optimize script = match got with | Error got -> check_error ~expected ~got | Ok [ Text_module m ] -> - let got = Compile.Text.until_binary ~unsafe m in + let got = + Compile.Text.until_binary ~unsafe ~rac:false ~srac:false m + in check_error_result expected got | _ -> assert false in @@ -224,7 +229,8 @@ let run ~no_exhaustion ~optimize script = | Assert (Assert_invalid (m, expected)) -> Log.debug0 "*** assert_invalid@\n"; let got = - Compile.Text.until_link link_state ~unsafe ~optimize ~name:None m + Compile.Text.until_link link_state ~unsafe ~rac:false ~srac:false + ~optimize ~name:None m in let+ () = check_error_result expected got in link_state @@ -236,14 +242,16 @@ let run ~no_exhaustion ~optimize script = | Assert (Assert_unlinkable (m, expected)) -> Log.debug0 "*** assert_unlinkable@\n"; let got = - Compile.Text.until_link link_state ~unsafe ~optimize ~name:None m + Compile.Text.until_link link_state ~unsafe ~rac:false ~srac:false + ~optimize ~name:None m in let+ () = check_error_result expected got in link_state | Assert (Assert_malformed (m, expected)) -> Log.debug0 "*** assert_malformed@\n"; let got = - Compile.Text.until_link ~unsafe ~optimize ~name:None link_state m + Compile.Text.until_link ~unsafe ~optimize ~rac:false ~srac:false + ~name:None link_state m in let+ () = check_error_result expected got in assert false diff --git a/test/fmt/print_simplified.ml b/test/fmt/print_simplified.ml index f23391c5f..97730129c 100644 --- a/test/fmt/print_simplified.ml +++ b/test/fmt/print_simplified.ml @@ -12,7 +12,7 @@ let m = | Error _ -> assert false let m = - match Compile.Text.until_binary ~unsafe:false m with + match Compile.Text.until_binary ~unsafe:false ~rac:false ~srac:false m with | Ok m -> Binary_to_text.modul m | Error _ -> assert false @@ -24,7 +24,7 @@ let m = | Error _ -> assert false let m = - match Compile.Text.until_binary ~unsafe:false m with + match Compile.Text.until_binary ~unsafe:false ~rac:false ~srac:false m with | Ok m -> Binary_to_text.modul m | Error _ -> assert false diff --git a/test/fuzz/interprets.ml b/test/fuzz/interprets.ml index 80859a26a..06174cfcb 100644 --- a/test/fuzz/interprets.ml +++ b/test/fuzz/interprets.ml @@ -37,7 +37,9 @@ module Owi_unoptimized : INTERPRET = struct let of_symbolic = Fun.id let run modul = - let* simplified = Compile.Text.until_binary ~unsafe:false modul in + let* simplified = + Compile.Text.until_binary ~unsafe:false ~rac:false ~srac:false modul + in let* () = Binary_validate.modul simplified in let* regular, link_state = Link.modul Link.empty_state ~name:None simplified @@ -54,7 +56,9 @@ module Owi_optimized : INTERPRET = struct let of_symbolic = Fun.id let run modul = - let* simplified = Compile.Text.until_binary ~unsafe:false modul in + let* simplified = + Compile.Text.until_binary ~unsafe:false ~rac:false ~srac:false modul + in let* () = Binary_validate.modul simplified in let simplified = Optimize.modul simplified in let* regular, link_state = @@ -74,7 +78,9 @@ module Owi_symbolic : INTERPRET = struct let dummy_workers_count = 42 let run modul : unit Result.t = - let* simplified = Compile.Text.until_binary ~unsafe:false modul in + let* simplified = + Compile.Text.until_binary ~unsafe:false ~rac:false ~srac:false modul + in let* () = Binary_validate.modul simplified in let* regular, link_state = Link.modul Link.empty_state ~name:None simplified diff --git a/test/help/help.t b/test/help/help.t index 8c2feab8b..3ea92ba12 100644 --- a/test/help/help.t +++ b/test/help/help.t @@ -16,6 +16,10 @@ no subcommand should print help fmt [--inplace] [OPTION]… [ARG]… Format a .wat or .wast file + instrument [--debug] [--symbolic] [--unsafe] [OPTION]… [ARG]… + Generate an instrumented file with runtime assertion checking + coming from Weasel specifications + opt [--debug] [--output=FILE] [--unsafe] [OPTION]… ARG Optimize a module diff --git a/test/weasel/dune b/test/weasel/dune index 0302df14c..d929f1550 100644 --- a/test/weasel/dune +++ b/test/weasel/dune @@ -1,2 +1,2 @@ (cram - (deps %{bin:owi} forall.wat plus.wat)) + (deps %{bin:owi} forall.wat plus.wat sum.wat)) diff --git a/test/weasel/forall.t b/test/weasel/forall.t index ced67a9df..9cdda9a4d 100644 --- a/test/weasel/forall.t +++ b/test/weasel/forall.t @@ -1,6 +1,97 @@ $ owi instrument forall.wat - $ owi sym forall.instrumented.wat --debug + $ cat forall.instrumented.wat + (module + (import "symbolic" "assert" (func $assert (param i32))) + (type (sub final (func))) + (type (sub final (func (param i32)))) + (type (sub final (func (result i32)))) + (type (sub final (func (param i32) (result i32)))) + (func $start + + ) + (func $__weasel_start (local $__weasel_temp i32) (local $__weasel_binder_0 i32) + (block $__weasel_forall (result i32) + i32.const 1 + local.set 1 + i32.const 1 + (loop $__weasel_loop (param i32) (result i32) + local.get 1 + i32.const 100 + i32.le_s + i32.and + local.tee 0 + local.get 0 + i32.const 1 + i32.xor + br_if 1 + local.get 1 + i32.const 1 + i32.add + local.set 1 + local.get 1 + i32.const 10 + i32.le_s + br_if 0)) + call 0 + call 1 + ) + (start 2) + ) + $ owi instrument forall.wat --symbolic + $ cat forall.instrumented.wat + (module + (import "symbolic" "i32_symbol" (func $i32_symbol (result i32))) + (import "symbolic" "i64_symbol" (func $i64_symbol (result i64))) + (import "symbolic" "f32_symbol" (func $f32_symbol (result f32))) + (import "symbolic" "f64_symbol" (func $f64_symbol (result f64))) + (import "symbolic" "assume" (func $assume (param i32))) + (import "symbolic" "assert" (func $assert (param i32))) + (type (sub final (func))) + (type (sub final (func (result i32)))) + (type (sub final (func (result i64)))) + (type (sub final (func (result f32)))) + (type (sub final (func (result f64)))) + (type (sub final (func (param i32)))) + (type (sub final (func (param i32) (result i32)))) + (func $start + + ) + (func $__weasel_start (local $__weasel_temp i32) (local $__weasel_binder_0 i32) + (block $__weasel_forall (result i32) + i32.const 1 + local.set 1 + i32.const 1 + (loop $__weasel_loop (param i32) (result i32) + local.get 1 + i32.const 100 + i32.le_s + i32.and + local.tee 0 + local.get 0 + i32.const 1 + i32.xor + br_if 1 + local.get 1 + i32.const 1 + i32.add + local.set 1 + local.get 1 + i32.const 10 + i32.le_s + br_if 0)) + call 5 + call 6 + ) + (start 7) + ) + $ owi sym forall.wat --rac --debug parsing ... + Contract of function $start + Preconditions: + (∀ $x:i32 + (⇒ (∧ (≥ $x (i32 1)) (≤ $x (i32 10))) (≤ $x (i32 100)))) + Postconditions: + checking ... grouping ... assigning ... @@ -10,7 +101,7 @@ linking ... interpreting ... stack : [ ] - running instr: call 7 + running instr: call 2 calling func : func __weasel_start stack : [ ] running instr: (block $__weasel_forall (result i32) @@ -403,424 +494,22 @@ stack : [ (i32 1) ] stack : [ (i32 1) ] stack : [ (i32 1) ] - running instr: call 5 + running instr: call 0 stack : [ ] - running instr: call 6 + running instr: call 1 calling func : func start stack : [ ] stack : [ ] stack : [ ] All OK - $ owi sym forall.instrumented.wasm --debug - typechecking ... - typechecking ... - linking ... - interpreting ... - stack : [ ] - running instr: call 7 - calling func : func anonymous - stack : [ ] - running instr: (block (result i32) - i32.const 1 - local.set 1 - i32.const 1 - (loop (param i32) (result i32) - local.get 1 - i32.const 100 - i32.le_s - i32.and - local.tee 0 - local.get 0 - i32.const 1 - i32.xor - br_if 1 - local.get 1 - i32.const 1 - i32.add - local.set 1 - local.get 1 - i32.const 10 - i32.le_s - br_if 0)) - stack : [ ] - running instr: i32.const 1 - stack : [ (i32 1) ] - running instr: local.set 1 - stack : [ ] - running instr: i32.const 1 - stack : [ (i32 1) ] - running instr: (loop (param i32) (result i32) - local.get 1 - i32.const 100 - i32.le_s - i32.and - local.tee 0 - local.get 0 - i32.const 1 - i32.xor - br_if 1 - local.get 1 - i32.const 1 - i32.add - local.set 1 - local.get 1 - i32.const 10 - i32.le_s - br_if 0) - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.const 100 - stack : [ (i32 100) ; (i32 1) ; (i32 1) ] - running instr: i32.le_s - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.and - stack : [ (i32 1) ] - running instr: local.tee 0 - stack : [ (i32 1) ] - running instr: local.get 0 - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.const 1 - stack : [ (i32 1) ; (i32 1) ; (i32 1) ] - running instr: i32.xor - stack : [ (i32 0) ; (i32 1) ] - running instr: br_if 1 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.const 1 - stack : [ (i32 1) ; (i32 1) ; (i32 1) ] - running instr: i32.add - stack : [ (i32 2) ; (i32 1) ] - running instr: local.set 1 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 2) ; (i32 1) ] - running instr: i32.const 10 - stack : [ (i32 10) ; (i32 2) ; (i32 1) ] - running instr: i32.le_s - stack : [ (i32 1) ; (i32 1) ] - running instr: br_if 0 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 2) ; (i32 1) ] - running instr: i32.const 100 - stack : [ (i32 100) ; (i32 2) ; (i32 1) ] - running instr: i32.le_s - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.and - stack : [ (i32 1) ] - running instr: local.tee 0 - stack : [ (i32 1) ] - running instr: local.get 0 - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.const 1 - stack : [ (i32 1) ; (i32 1) ; (i32 1) ] - running instr: i32.xor - stack : [ (i32 0) ; (i32 1) ] - running instr: br_if 1 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 2) ; (i32 1) ] - running instr: i32.const 1 - stack : [ (i32 1) ; (i32 2) ; (i32 1) ] - running instr: i32.add - stack : [ (i32 3) ; (i32 1) ] - running instr: local.set 1 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 3) ; (i32 1) ] - running instr: i32.const 10 - stack : [ (i32 10) ; (i32 3) ; (i32 1) ] - running instr: i32.le_s - stack : [ (i32 1) ; (i32 1) ] - running instr: br_if 0 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 3) ; (i32 1) ] - running instr: i32.const 100 - stack : [ (i32 100) ; (i32 3) ; (i32 1) ] - running instr: i32.le_s - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.and - stack : [ (i32 1) ] - running instr: local.tee 0 - stack : [ (i32 1) ] - running instr: local.get 0 - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.const 1 - stack : [ (i32 1) ; (i32 1) ; (i32 1) ] - running instr: i32.xor - stack : [ (i32 0) ; (i32 1) ] - running instr: br_if 1 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 3) ; (i32 1) ] - running instr: i32.const 1 - stack : [ (i32 1) ; (i32 3) ; (i32 1) ] - running instr: i32.add - stack : [ (i32 4) ; (i32 1) ] - running instr: local.set 1 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 4) ; (i32 1) ] - running instr: i32.const 10 - stack : [ (i32 10) ; (i32 4) ; (i32 1) ] - running instr: i32.le_s - stack : [ (i32 1) ; (i32 1) ] - running instr: br_if 0 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 4) ; (i32 1) ] - running instr: i32.const 100 - stack : [ (i32 100) ; (i32 4) ; (i32 1) ] - running instr: i32.le_s - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.and - stack : [ (i32 1) ] - running instr: local.tee 0 - stack : [ (i32 1) ] - running instr: local.get 0 - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.const 1 - stack : [ (i32 1) ; (i32 1) ; (i32 1) ] - running instr: i32.xor - stack : [ (i32 0) ; (i32 1) ] - running instr: br_if 1 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 4) ; (i32 1) ] - running instr: i32.const 1 - stack : [ (i32 1) ; (i32 4) ; (i32 1) ] - running instr: i32.add - stack : [ (i32 5) ; (i32 1) ] - running instr: local.set 1 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 5) ; (i32 1) ] - running instr: i32.const 10 - stack : [ (i32 10) ; (i32 5) ; (i32 1) ] - running instr: i32.le_s - stack : [ (i32 1) ; (i32 1) ] - running instr: br_if 0 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 5) ; (i32 1) ] - running instr: i32.const 100 - stack : [ (i32 100) ; (i32 5) ; (i32 1) ] - running instr: i32.le_s - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.and - stack : [ (i32 1) ] - running instr: local.tee 0 - stack : [ (i32 1) ] - running instr: local.get 0 - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.const 1 - stack : [ (i32 1) ; (i32 1) ; (i32 1) ] - running instr: i32.xor - stack : [ (i32 0) ; (i32 1) ] - running instr: br_if 1 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 5) ; (i32 1) ] - running instr: i32.const 1 - stack : [ (i32 1) ; (i32 5) ; (i32 1) ] - running instr: i32.add - stack : [ (i32 6) ; (i32 1) ] - running instr: local.set 1 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 6) ; (i32 1) ] - running instr: i32.const 10 - stack : [ (i32 10) ; (i32 6) ; (i32 1) ] - running instr: i32.le_s - stack : [ (i32 1) ; (i32 1) ] - running instr: br_if 0 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 6) ; (i32 1) ] - running instr: i32.const 100 - stack : [ (i32 100) ; (i32 6) ; (i32 1) ] - running instr: i32.le_s - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.and - stack : [ (i32 1) ] - running instr: local.tee 0 - stack : [ (i32 1) ] - running instr: local.get 0 - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.const 1 - stack : [ (i32 1) ; (i32 1) ; (i32 1) ] - running instr: i32.xor - stack : [ (i32 0) ; (i32 1) ] - running instr: br_if 1 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 6) ; (i32 1) ] - running instr: i32.const 1 - stack : [ (i32 1) ; (i32 6) ; (i32 1) ] - running instr: i32.add - stack : [ (i32 7) ; (i32 1) ] - running instr: local.set 1 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 7) ; (i32 1) ] - running instr: i32.const 10 - stack : [ (i32 10) ; (i32 7) ; (i32 1) ] - running instr: i32.le_s - stack : [ (i32 1) ; (i32 1) ] - running instr: br_if 0 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 7) ; (i32 1) ] - running instr: i32.const 100 - stack : [ (i32 100) ; (i32 7) ; (i32 1) ] - running instr: i32.le_s - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.and - stack : [ (i32 1) ] - running instr: local.tee 0 - stack : [ (i32 1) ] - running instr: local.get 0 - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.const 1 - stack : [ (i32 1) ; (i32 1) ; (i32 1) ] - running instr: i32.xor - stack : [ (i32 0) ; (i32 1) ] - running instr: br_if 1 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 7) ; (i32 1) ] - running instr: i32.const 1 - stack : [ (i32 1) ; (i32 7) ; (i32 1) ] - running instr: i32.add - stack : [ (i32 8) ; (i32 1) ] - running instr: local.set 1 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 8) ; (i32 1) ] - running instr: i32.const 10 - stack : [ (i32 10) ; (i32 8) ; (i32 1) ] - running instr: i32.le_s - stack : [ (i32 1) ; (i32 1) ] - running instr: br_if 0 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 8) ; (i32 1) ] - running instr: i32.const 100 - stack : [ (i32 100) ; (i32 8) ; (i32 1) ] - running instr: i32.le_s - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.and - stack : [ (i32 1) ] - running instr: local.tee 0 - stack : [ (i32 1) ] - running instr: local.get 0 - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.const 1 - stack : [ (i32 1) ; (i32 1) ; (i32 1) ] - running instr: i32.xor - stack : [ (i32 0) ; (i32 1) ] - running instr: br_if 1 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 8) ; (i32 1) ] - running instr: i32.const 1 - stack : [ (i32 1) ; (i32 8) ; (i32 1) ] - running instr: i32.add - stack : [ (i32 9) ; (i32 1) ] - running instr: local.set 1 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 9) ; (i32 1) ] - running instr: i32.const 10 - stack : [ (i32 10) ; (i32 9) ; (i32 1) ] - running instr: i32.le_s - stack : [ (i32 1) ; (i32 1) ] - running instr: br_if 0 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 9) ; (i32 1) ] - running instr: i32.const 100 - stack : [ (i32 100) ; (i32 9) ; (i32 1) ] - running instr: i32.le_s - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.and - stack : [ (i32 1) ] - running instr: local.tee 0 - stack : [ (i32 1) ] - running instr: local.get 0 - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.const 1 - stack : [ (i32 1) ; (i32 1) ; (i32 1) ] - running instr: i32.xor - stack : [ (i32 0) ; (i32 1) ] - running instr: br_if 1 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 9) ; (i32 1) ] - running instr: i32.const 1 - stack : [ (i32 1) ; (i32 9) ; (i32 1) ] - running instr: i32.add - stack : [ (i32 10) ; (i32 1) ] - running instr: local.set 1 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 10) ; (i32 1) ] - running instr: i32.const 10 - stack : [ (i32 10) ; (i32 10) ; (i32 1) ] - running instr: i32.le_s - stack : [ (i32 1) ; (i32 1) ] - running instr: br_if 0 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 10) ; (i32 1) ] - running instr: i32.const 100 - stack : [ (i32 100) ; (i32 10) ; (i32 1) ] - running instr: i32.le_s - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.and - stack : [ (i32 1) ] - running instr: local.tee 0 - stack : [ (i32 1) ] - running instr: local.get 0 - stack : [ (i32 1) ; (i32 1) ] - running instr: i32.const 1 - stack : [ (i32 1) ; (i32 1) ; (i32 1) ] - running instr: i32.xor - stack : [ (i32 0) ; (i32 1) ] - running instr: br_if 1 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 10) ; (i32 1) ] - running instr: i32.const 1 - stack : [ (i32 1) ; (i32 10) ; (i32 1) ] - running instr: i32.add - stack : [ (i32 11) ; (i32 1) ] - running instr: local.set 1 - stack : [ (i32 1) ] - running instr: local.get 1 - stack : [ (i32 11) ; (i32 1) ] - running instr: i32.const 10 - stack : [ (i32 10) ; (i32 11) ; (i32 1) ] - running instr: i32.le_s - stack : [ (i32 0) ; (i32 1) ] - running instr: br_if 0 - stack : [ (i32 1) ] - stack : [ (i32 1) ] - stack : [ (i32 1) ] - running instr: call 5 - stack : [ ] - running instr: call 6 - calling func : func anonymous - stack : [ ] - stack : [ ] - stack : [ ] - All OK - $ owi wasm2wat forall.instrumented.wasm > forall.instrumented2.wat - $ owi sym forall.instrumented2.wat --debug + $ owi sym forall.wat --srac --debug parsing ... + Contract of function $start + Preconditions: + (∀ $x:i32 + (⇒ (∧ (≥ $x (i32 1)) (≤ $x (i32 10))) (≤ $x (i32 100)))) + Postconditions: + checking ... grouping ... assigning ... @@ -831,13 +520,13 @@ interpreting ... stack : [ ] running instr: call 7 - calling func : func anonymous + calling func : func __weasel_start stack : [ ] - running instr: (block (result i32) + running instr: (block $__weasel_forall (result i32) i32.const 1 local.set 1 i32.const 1 - (loop (param i32) (result i32) + (loop $__weasel_loop (param i32) (result i32) local.get 1 i32.const 100 i32.le_s @@ -862,7 +551,7 @@ stack : [ ] running instr: i32.const 1 stack : [ (i32 1) ] - running instr: (loop (param i32) (result i32) + running instr: (loop $__weasel_loop (param i32) (result i32) local.get 1 i32.const 100 i32.le_s @@ -1226,7 +915,7 @@ running instr: call 5 stack : [ ] running instr: call 6 - calling func : func anonymous + calling func : func start stack : [ ] stack : [ ] stack : [ ] diff --git a/test/weasel/plus.t b/test/weasel/plus.t index df96461d3..bf2d2559b 100644 --- a/test/weasel/plus.t +++ b/test/weasel/plus.t @@ -1,8 +1,186 @@ $ owi instrument plus.wat - $ owi sym plus.instrumented.wat + $ cat plus.instrumented.wat + (module + (import "symbolic" "assert" (func $assert (param i32))) + (type (sub final (func (param $x i32) (result i32)))) + (type (sub final (func))) + (type (sub final (func (param i32)))) + (type (sub final (func (result i32)))) + (func $plus_three (param $x i32) (result i32) + i32.const 3 + local.get 0 + i32.add + ) + (func $start + i32.const 42 + call 3 + drop + ) + (func $__weasel_plus_three (param $x i32) (result i32) (local $__weasel_temp i32) (local $__weasel_res_0 i32) + local.get 0 + call 1 + local.set 2 + local.get 2 + local.get 0 + i32.const 3 + i32.add + i32.eq + call 0 + local.get 2 + ) + (start 2) + ) + $ owi instrument plus.wat --symbolic + $ cat plus.instrumented.wat + (module + (import "symbolic" "i32_symbol" (func $i32_symbol (result i32))) + (import "symbolic" "i64_symbol" (func $i64_symbol (result i64))) + (import "symbolic" "f32_symbol" (func $f32_symbol (result f32))) + (import "symbolic" "f64_symbol" (func $f64_symbol (result f64))) + (import "symbolic" "assume" (func $assume (param i32))) + (import "symbolic" "assert" (func $assert (param i32))) + (type (sub final (func (param $x i32) (result i32)))) + (type (sub final (func))) + (type (sub final (func (result i32)))) + (type (sub final (func (result i64)))) + (type (sub final (func (result f32)))) + (type (sub final (func (result f64)))) + (type (sub final (func (param i32)))) + (func $plus_three (param $x i32) (result i32) + i32.const 3 + local.get 0 + i32.add + ) + (func $start + i32.const 42 + call 8 + drop + ) + (func $__weasel_plus_three (param $x i32) (result i32) (local $__weasel_temp i32) (local $__weasel_res_0 i32) + local.get 0 + call 6 + local.set 2 + local.get 2 + local.get 0 + i32.const 3 + i32.add + i32.eq + call 5 + local.get 2 + ) + (start 7) + ) + $ owi sym plus.wat --rac --debug + parsing ... + Contract of function $plus_three + Preconditions: + + Postconditions: + (= result (+ $x (i32 3))) + checking ... + grouping ... + assigning ... + rewriting ... + typechecking ... + typechecking ... + linking ... + interpreting ... + stack : [ ] + running instr: call 2 + calling func : func start + stack : [ ] + running instr: i32.const 42 + stack : [ (i32 42) ] + running instr: call 3 + calling func : func __weasel_plus_three + stack : [ ] + running instr: local.get 0 + stack : [ (i32 42) ] + running instr: call 1 + calling func : func plus_three + stack : [ ] + running instr: i32.const 3 + stack : [ (i32 3) ] + running instr: local.get 0 + stack : [ (i32 42) ; (i32 3) ] + running instr: i32.add + stack : [ (i32 45) ] + stack : [ (i32 45) ] + running instr: local.set 2 + stack : [ ] + running instr: local.get 2 + stack : [ (i32 45) ] + running instr: local.get 0 + stack : [ (i32 42) ; (i32 45) ] + running instr: i32.const 3 + stack : [ (i32 3) ; (i32 42) ; (i32 45) ] + running instr: i32.add + stack : [ (i32 45) ; (i32 45) ] + running instr: i32.eq + stack : [ (i32 1) ] + running instr: call 0 + stack : [ ] + running instr: local.get 2 + stack : [ (i32 45) ] + stack : [ (i32 45) ] + running instr: drop + stack : [ ] + stack : [ ] All OK - $ owi sym plus.instrumented.wasm - All OK - $ owi wasm2wat plus.instrumented.wasm > plus.instrumented2.wat - $ owi sym plus.instrumented2.wat + $ owi sym plus.wat --srac --debug + parsing ... + Contract of function $plus_three + Preconditions: + + Postconditions: + (= result (+ $x (i32 3))) + checking ... + grouping ... + assigning ... + rewriting ... + typechecking ... + typechecking ... + linking ... + interpreting ... + stack : [ ] + running instr: call 7 + calling func : func start + stack : [ ] + running instr: i32.const 42 + stack : [ (i32 42) ] + running instr: call 8 + calling func : func __weasel_plus_three + stack : [ ] + running instr: local.get 0 + stack : [ (i32 42) ] + running instr: call 6 + calling func : func plus_three + stack : [ ] + running instr: i32.const 3 + stack : [ (i32 3) ] + running instr: local.get 0 + stack : [ (i32 42) ; (i32 3) ] + running instr: i32.add + stack : [ (i32 45) ] + stack : [ (i32 45) ] + running instr: local.set 2 + stack : [ ] + running instr: local.get 2 + stack : [ (i32 45) ] + running instr: local.get 0 + stack : [ (i32 42) ; (i32 45) ] + running instr: i32.const 3 + stack : [ (i32 3) ; (i32 42) ; (i32 45) ] + running instr: i32.add + stack : [ (i32 45) ; (i32 45) ] + running instr: i32.eq + stack : [ (i32 1) ] + running instr: call 5 + stack : [ ] + running instr: local.get 2 + stack : [ (i32 45) ] + stack : [ (i32 45) ] + running instr: drop + stack : [ ] + stack : [ ] All OK diff --git a/test/weasel/sum.t b/test/weasel/sum.t new file mode 100644 index 000000000..2c9a245da --- /dev/null +++ b/test/weasel/sum.t @@ -0,0 +1,272 @@ + $ owi instrument sum.wat + $ cat sum.instrumented.wat + (module + (import "symbolic" "assert" (func $assert (param i32))) + (type (sub final (func (param $p1 i32) (param $p2 i32) (param $p3 i32) (param $p4 i32) (result i32)))) + (type (sub final (func))) + (type (sub final (func (param i32)))) + (type (sub final (func (result i32)))) + (type (sub final (func (param i32) (result i32)))) + (func $sum (param $p1 i32) (param $p2 i32) (param $p3 i32) (param $p4 i32) (result i32) + local.get 0 + local.get 1 + local.get 2 + local.get 3 + i32.add + i32.add + i32.add + ) + (func $start + i32.const 42 + i32.const 42 + i32.const 42 + i32.const 42 + call 3 + drop + ) + (func $__weasel_sum (param $p1 i32) (param $p2 i32) (param $p3 i32) (param $p4 i32) (result i32) (local $__weasel_temp i32) (local $__weasel_res_0 i32) + local.get 0 + local.get 1 + local.get 2 + local.get 3 + call 1 + local.set 5 + local.get 5 + local.get 0 + local.get 1 + local.get 2 + local.get 3 + i32.add + i32.add + i32.add + i32.eq + call 0 + local.get 5 + ) + (start 2) + ) + $ owi instrument sum.wat --symbolic + $ cat sum.instrumented.wat + (module + (import "symbolic" "i32_symbol" (func $i32_symbol (result i32))) + (import "symbolic" "i64_symbol" (func $i64_symbol (result i64))) + (import "symbolic" "f32_symbol" (func $f32_symbol (result f32))) + (import "symbolic" "f64_symbol" (func $f64_symbol (result f64))) + (import "symbolic" "assume" (func $assume (param i32))) + (import "symbolic" "assert" (func $assert (param i32))) + (type (sub final (func (param $p1 i32) (param $p2 i32) (param $p3 i32) (param $p4 i32) (result i32)))) + (type (sub final (func))) + (type (sub final (func (result i32)))) + (type (sub final (func (result i64)))) + (type (sub final (func (result f32)))) + (type (sub final (func (result f64)))) + (type (sub final (func (param i32)))) + (type (sub final (func (param i32) (result i32)))) + (func $sum (param $p1 i32) (param $p2 i32) (param $p3 i32) (param $p4 i32) (result i32) + local.get 0 + local.get 1 + local.get 2 + local.get 3 + i32.add + i32.add + i32.add + ) + (func $start + i32.const 42 + i32.const 42 + i32.const 42 + i32.const 42 + call 8 + drop + ) + (func $__weasel_sum (param $p1 i32) (param $p2 i32) (param $p3 i32) (param $p4 i32) (result i32) (local $__weasel_temp i32) (local $__weasel_res_0 i32) + local.get 0 + local.get 1 + local.get 2 + local.get 3 + call 6 + local.set 5 + local.get 5 + local.get 0 + local.get 1 + local.get 2 + local.get 3 + i32.add + i32.add + i32.add + i32.eq + call 5 + local.get 5 + ) + (start 7) + ) + $ owi sym sum.wat --rac --debug + parsing ... + Contract of function 0 + Preconditions: + + Postconditions: + (= result (+ $p1 (+ $p2 (+ $p3 $p4)))) + checking ... + grouping ... + assigning ... + rewriting ... + typechecking ... + typechecking ... + linking ... + interpreting ... + stack : [ ] + running instr: call 2 + calling func : func start + stack : [ ] + running instr: i32.const 42 + stack : [ (i32 42) ] + running instr: i32.const 42 + stack : [ (i32 42) ; (i32 42) ] + running instr: i32.const 42 + stack : [ (i32 42) ; (i32 42) ; (i32 42) ] + running instr: i32.const 42 + stack : [ (i32 42) ; (i32 42) ; (i32 42) ; (i32 42) ] + running instr: call 3 + calling func : func __weasel_sum + stack : [ ] + running instr: local.get 0 + stack : [ (i32 42) ] + running instr: local.get 1 + stack : [ (i32 42) ; (i32 42) ] + running instr: local.get 2 + stack : [ (i32 42) ; (i32 42) ; (i32 42) ] + running instr: local.get 3 + stack : [ (i32 42) ; (i32 42) ; (i32 42) ; (i32 42) ] + running instr: call 1 + calling func : func sum + stack : [ ] + running instr: local.get 0 + stack : [ (i32 42) ] + running instr: local.get 1 + stack : [ (i32 42) ; (i32 42) ] + running instr: local.get 2 + stack : [ (i32 42) ; (i32 42) ; (i32 42) ] + running instr: local.get 3 + stack : [ (i32 42) ; (i32 42) ; (i32 42) ; (i32 42) ] + running instr: i32.add + stack : [ (i32 84) ; (i32 42) ; (i32 42) ] + running instr: i32.add + stack : [ (i32 126) ; (i32 42) ] + running instr: i32.add + stack : [ (i32 168) ] + stack : [ (i32 168) ] + running instr: local.set 5 + stack : [ ] + running instr: local.get 5 + stack : [ (i32 168) ] + running instr: local.get 0 + stack : [ (i32 42) ; (i32 168) ] + running instr: local.get 1 + stack : [ (i32 42) ; (i32 42) ; (i32 168) ] + running instr: local.get 2 + stack : [ (i32 42) ; (i32 42) ; (i32 42) ; (i32 168) ] + running instr: local.get 3 + stack : [ (i32 42) ; (i32 42) ; (i32 42) ; (i32 42) ; (i32 168) ] + running instr: i32.add + stack : [ (i32 84) ; (i32 42) ; (i32 42) ; (i32 168) ] + running instr: i32.add + stack : [ (i32 126) ; (i32 42) ; (i32 168) ] + running instr: i32.add + stack : [ (i32 168) ; (i32 168) ] + running instr: i32.eq + stack : [ (i32 1) ] + running instr: call 0 + stack : [ ] + running instr: local.get 5 + stack : [ (i32 168) ] + stack : [ (i32 168) ] + running instr: drop + stack : [ ] + stack : [ ] + All OK + $ owi sym sum.wat --srac --debug + parsing ... + Contract of function 0 + Preconditions: + + Postconditions: + (= result (+ $p1 (+ $p2 (+ $p3 $p4)))) + checking ... + grouping ... + assigning ... + rewriting ... + typechecking ... + typechecking ... + linking ... + interpreting ... + stack : [ ] + running instr: call 7 + calling func : func start + stack : [ ] + running instr: i32.const 42 + stack : [ (i32 42) ] + running instr: i32.const 42 + stack : [ (i32 42) ; (i32 42) ] + running instr: i32.const 42 + stack : [ (i32 42) ; (i32 42) ; (i32 42) ] + running instr: i32.const 42 + stack : [ (i32 42) ; (i32 42) ; (i32 42) ; (i32 42) ] + running instr: call 8 + calling func : func __weasel_sum + stack : [ ] + running instr: local.get 0 + stack : [ (i32 42) ] + running instr: local.get 1 + stack : [ (i32 42) ; (i32 42) ] + running instr: local.get 2 + stack : [ (i32 42) ; (i32 42) ; (i32 42) ] + running instr: local.get 3 + stack : [ (i32 42) ; (i32 42) ; (i32 42) ; (i32 42) ] + running instr: call 6 + calling func : func sum + stack : [ ] + running instr: local.get 0 + stack : [ (i32 42) ] + running instr: local.get 1 + stack : [ (i32 42) ; (i32 42) ] + running instr: local.get 2 + stack : [ (i32 42) ; (i32 42) ; (i32 42) ] + running instr: local.get 3 + stack : [ (i32 42) ; (i32 42) ; (i32 42) ; (i32 42) ] + running instr: i32.add + stack : [ (i32 84) ; (i32 42) ; (i32 42) ] + running instr: i32.add + stack : [ (i32 126) ; (i32 42) ] + running instr: i32.add + stack : [ (i32 168) ] + stack : [ (i32 168) ] + running instr: local.set 5 + stack : [ ] + running instr: local.get 5 + stack : [ (i32 168) ] + running instr: local.get 0 + stack : [ (i32 42) ; (i32 168) ] + running instr: local.get 1 + stack : [ (i32 42) ; (i32 42) ; (i32 168) ] + running instr: local.get 2 + stack : [ (i32 42) ; (i32 42) ; (i32 42) ; (i32 168) ] + running instr: local.get 3 + stack : [ (i32 42) ; (i32 42) ; (i32 42) ; (i32 42) ; (i32 168) ] + running instr: i32.add + stack : [ (i32 84) ; (i32 42) ; (i32 42) ; (i32 168) ] + running instr: i32.add + stack : [ (i32 126) ; (i32 42) ; (i32 168) ] + running instr: i32.add + stack : [ (i32 168) ; (i32 168) ] + running instr: i32.eq + stack : [ (i32 1) ] + running instr: call 5 + stack : [ ] + running instr: local.get 5 + stack : [ (i32 168) ] + stack : [ (i32 168) ] + running instr: drop + stack : [ ] + stack : [ ] + All OK diff --git a/test/weasel/sum.wat b/test/weasel/sum.wat new file mode 100644 index 000000000..994867752 --- /dev/null +++ b/test/weasel/sum.wat @@ -0,0 +1,18 @@ +(module + (@contract 0 + (ensures (= result (+ $p1 (+ $p2 (+ $p3 $p4))))) + ) + (func $sum + (param $p1 i32) (param $p2 i32) (param $p3 i32) (param $p4 i32) (result i32) + (local.get $p1) + (local.get $p2) + (local.get $p3) + (local.get $p4) + (i32.add) + (i32.add) + (i32.add)) + (func $start + (call $sum (i32.const 42) (i32.const 42) (i32.const 42) (i32.const 42)) + drop) + (start $start) +) From 4ed6c6e69c6d5440b5e9411e1f7de76e859da01f Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Tue, 27 Aug 2024 18:03:36 +0200 Subject: [PATCH 45/51] remove unused owi functions --- src/ast/code_generator.ml | 9 +-------- src/cmd/cmd_instrument.ml | 2 +- test/weasel/forall.t | 22 +++++++--------------- test/weasel/plus.t | 26 +++++++++----------------- test/weasel/sum.t | 26 +++++++++----------------- 5 files changed, 27 insertions(+), 58 deletions(-) diff --git a/src/ast/code_generator.ml b/src/ast/code_generator.ml index 81ecb7663..6a695b9aa 100644 --- a/src/ast/code_generator.ml +++ b/src/ast/code_generator.ml @@ -680,14 +680,7 @@ let add_owi_funcs (owi_funcs : (string * binary func_type) array) (m : modul) : let generate (symbolic : bool) (m : modul) : modul Result.t = let owi_funcs = - if symbolic then - [| ("i32_symbol", ([], [ Num_type I32 ])) - ; ("i64_symbol", ([], [ Num_type I64 ])) - ; ("f32_symbol", ([], [ Num_type F32 ])) - ; ("f64_symbol", ([], [ Num_type F64 ])) - ; ("assume", ([ (None, Num_type I32) ], [])) - ; ("assert", ([ (None, Num_type I32) ], [])) - |] + if symbolic then [| ("assert", ([ (None, Num_type I32) ], [])) |] else [| ("assert", ([ (None, Num_type I32) ], [])) |] in let m, owi_funcs = add_owi_funcs owi_funcs m in diff --git a/src/cmd/cmd_instrument.ml b/src/cmd/cmd_instrument.ml index 6138489a7..26f19eb26 100644 --- a/src/cmd/cmd_instrument.ml +++ b/src/cmd/cmd_instrument.ml @@ -19,7 +19,7 @@ let cmd_one unsafe symbolic file = let filename = Fpath.add_ext ".instrumented" filename in let filename = Fpath.add_ext ".wat" filename in let* () = - Binary_encoder.convert filename ~unsafe ~optimize:false + Binary_encoder.convert None filename ~unsafe ~optimize:false instrumented_text_modul in Bos.OS.File.writef filename "%a" Text.pp_modul instrumented_text_modul diff --git a/test/weasel/forall.t b/test/weasel/forall.t index 9cdda9a4d..a39c8dbaf 100644 --- a/test/weasel/forall.t +++ b/test/weasel/forall.t @@ -40,18 +40,10 @@ $ owi instrument forall.wat --symbolic $ cat forall.instrumented.wat (module - (import "symbolic" "i32_symbol" (func $i32_symbol (result i32))) - (import "symbolic" "i64_symbol" (func $i64_symbol (result i64))) - (import "symbolic" "f32_symbol" (func $f32_symbol (result f32))) - (import "symbolic" "f64_symbol" (func $f64_symbol (result f64))) - (import "symbolic" "assume" (func $assume (param i32))) (import "symbolic" "assert" (func $assert (param i32))) (type (sub final (func))) - (type (sub final (func (result i32)))) - (type (sub final (func (result i64)))) - (type (sub final (func (result f32)))) - (type (sub final (func (result f64)))) (type (sub final (func (param i32)))) + (type (sub final (func (result i32)))) (type (sub final (func (param i32) (result i32)))) (func $start @@ -79,10 +71,10 @@ i32.const 10 i32.le_s br_if 0)) - call 5 - call 6 + call 0 + call 1 ) - (start 7) + (start 2) ) $ owi sym forall.wat --rac --debug parsing ... @@ -519,7 +511,7 @@ linking ... interpreting ... stack : [ ] - running instr: call 7 + running instr: call 2 calling func : func __weasel_start stack : [ ] running instr: (block $__weasel_forall (result i32) @@ -912,9 +904,9 @@ stack : [ (i32 1) ] stack : [ (i32 1) ] stack : [ (i32 1) ] - running instr: call 5 + running instr: call 0 stack : [ ] - running instr: call 6 + running instr: call 1 calling func : func start stack : [ ] stack : [ ] diff --git a/test/weasel/plus.t b/test/weasel/plus.t index bf2d2559b..9fe2e8001 100644 --- a/test/weasel/plus.t +++ b/test/weasel/plus.t @@ -33,19 +33,11 @@ $ owi instrument plus.wat --symbolic $ cat plus.instrumented.wat (module - (import "symbolic" "i32_symbol" (func $i32_symbol (result i32))) - (import "symbolic" "i64_symbol" (func $i64_symbol (result i64))) - (import "symbolic" "f32_symbol" (func $f32_symbol (result f32))) - (import "symbolic" "f64_symbol" (func $f64_symbol (result f64))) - (import "symbolic" "assume" (func $assume (param i32))) (import "symbolic" "assert" (func $assert (param i32))) (type (sub final (func (param $x i32) (result i32)))) (type (sub final (func))) - (type (sub final (func (result i32)))) - (type (sub final (func (result i64)))) - (type (sub final (func (result f32)))) - (type (sub final (func (result f64)))) (type (sub final (func (param i32)))) + (type (sub final (func (result i32)))) (func $plus_three (param $x i32) (result i32) i32.const 3 local.get 0 @@ -53,22 +45,22 @@ ) (func $start i32.const 42 - call 8 + call 3 drop ) (func $__weasel_plus_three (param $x i32) (result i32) (local $__weasel_temp i32) (local $__weasel_res_0 i32) local.get 0 - call 6 + call 1 local.set 2 local.get 2 local.get 0 i32.const 3 i32.add i32.eq - call 5 + call 0 local.get 2 ) - (start 7) + (start 2) ) $ owi sym plus.wat --rac --debug parsing ... @@ -143,17 +135,17 @@ linking ... interpreting ... stack : [ ] - running instr: call 7 + running instr: call 2 calling func : func start stack : [ ] running instr: i32.const 42 stack : [ (i32 42) ] - running instr: call 8 + running instr: call 3 calling func : func __weasel_plus_three stack : [ ] running instr: local.get 0 stack : [ (i32 42) ] - running instr: call 6 + running instr: call 1 calling func : func plus_three stack : [ ] running instr: i32.const 3 @@ -175,7 +167,7 @@ stack : [ (i32 45) ; (i32 45) ] running instr: i32.eq stack : [ (i32 1) ] - running instr: call 5 + running instr: call 0 stack : [ ] running instr: local.get 2 stack : [ (i32 45) ] diff --git a/test/weasel/sum.t b/test/weasel/sum.t index 2c9a245da..be2cfad92 100644 --- a/test/weasel/sum.t +++ b/test/weasel/sum.t @@ -48,19 +48,11 @@ $ owi instrument sum.wat --symbolic $ cat sum.instrumented.wat (module - (import "symbolic" "i32_symbol" (func $i32_symbol (result i32))) - (import "symbolic" "i64_symbol" (func $i64_symbol (result i64))) - (import "symbolic" "f32_symbol" (func $f32_symbol (result f32))) - (import "symbolic" "f64_symbol" (func $f64_symbol (result f64))) - (import "symbolic" "assume" (func $assume (param i32))) (import "symbolic" "assert" (func $assert (param i32))) (type (sub final (func (param $p1 i32) (param $p2 i32) (param $p3 i32) (param $p4 i32) (result i32)))) (type (sub final (func))) - (type (sub final (func (result i32)))) - (type (sub final (func (result i64)))) - (type (sub final (func (result f32)))) - (type (sub final (func (result f64)))) (type (sub final (func (param i32)))) + (type (sub final (func (result i32)))) (type (sub final (func (param i32) (result i32)))) (func $sum (param $p1 i32) (param $p2 i32) (param $p3 i32) (param $p4 i32) (result i32) local.get 0 @@ -76,7 +68,7 @@ i32.const 42 i32.const 42 i32.const 42 - call 8 + call 3 drop ) (func $__weasel_sum (param $p1 i32) (param $p2 i32) (param $p3 i32) (param $p4 i32) (result i32) (local $__weasel_temp i32) (local $__weasel_res_0 i32) @@ -84,7 +76,7 @@ local.get 1 local.get 2 local.get 3 - call 6 + call 1 local.set 5 local.get 5 local.get 0 @@ -95,10 +87,10 @@ i32.add i32.add i32.eq - call 5 + call 0 local.get 5 ) - (start 7) + (start 2) ) $ owi sym sum.wat --rac --debug parsing ... @@ -201,7 +193,7 @@ linking ... interpreting ... stack : [ ] - running instr: call 7 + running instr: call 2 calling func : func start stack : [ ] running instr: i32.const 42 @@ -212,7 +204,7 @@ stack : [ (i32 42) ; (i32 42) ; (i32 42) ] running instr: i32.const 42 stack : [ (i32 42) ; (i32 42) ; (i32 42) ; (i32 42) ] - running instr: call 8 + running instr: call 3 calling func : func __weasel_sum stack : [ ] running instr: local.get 0 @@ -223,7 +215,7 @@ stack : [ (i32 42) ; (i32 42) ; (i32 42) ] running instr: local.get 3 stack : [ (i32 42) ; (i32 42) ; (i32 42) ; (i32 42) ] - running instr: call 6 + running instr: call 1 calling func : func sum stack : [ ] running instr: local.get 0 @@ -261,7 +253,7 @@ stack : [ (i32 168) ; (i32 168) ] running instr: i32.eq stack : [ (i32 1) ] - running instr: call 5 + running instr: call 0 stack : [ ] running instr: local.get 5 stack : [ (i32 168) ] From 74fbb5748cb695ce46230185b870545ce9f350cc Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Mon, 2 Sep 2024 11:18:32 +0200 Subject: [PATCH 46/51] add memory instruction --- src/annot/spec.ml | 24 +++++++++--------------- src/annot/spec.mli | 6 ++---- src/ast/code_generator.ml | 12 ++++++++++-- src/text_to_binary/rewrite.ml | 3 +++ 4 files changed, 24 insertions(+), 21 deletions(-) diff --git a/src/annot/spec.ml b/src/annot/spec.ml index ee299956a..70bd0cc9c 100644 --- a/src/annot/spec.ml +++ b/src/annot/spec.ml @@ -30,6 +30,7 @@ pterm ::= 'i32' i32 ==> match Int32.of_string i32 with Some i32 - | unop term_1 ==> Unop (unop, term_1) | binop term_1 term_2 ==> BinOp (binop, term_1, term_2) | 'result' i ==> Result (Some i) + | 'memory' term_1 ==> Memory term_1 binpred ::= '>=' ==> Ge | '>' ==> Gt @@ -88,16 +89,13 @@ type nonrec binder = type nonrec binder_type = num_type -type nonrec unop = - | Neg - | CustomUnOp of string (* for testing purpose only *) +type nonrec unop = Neg type nonrec binop = | Plus | Minus | Mult | Div - | CustomBinOp of string (* for testing purpose only *) type 'a term = | Int32 : Int32.t -> 'a term @@ -111,6 +109,7 @@ type 'a term = | UnOp : unop * 'a term -> 'a term | BinOp : binop * 'a term * 'a term -> 'a term | Result : int option -> 'a term + | Memory : 'a term -> 'a term type 'a prop = | Const : bool -> 'a prop @@ -139,16 +138,13 @@ let pp_binder fmt = function Forall -> pf fmt "∀" | Exists -> pf fmt "∃" let pp_binder_type = pp_num_type -let pp_unop fmt = function - | Neg -> pf fmt "-" - | CustomUnOp c -> pf fmt "%a" string c +let pp_unop fmt = function Neg -> pf fmt "-" let pp_binop fmt = function | Plus -> pf fmt "+" | Minus -> pf fmt "-" | Mult -> pf fmt "*" | Div -> pf fmt "/" - | CustomBinOp c -> pf fmt "%a" string c let rec pp_term : type a. formatter -> a term -> unit = fun fmt -> function @@ -165,6 +161,7 @@ let rec pp_term : type a. formatter -> a term -> unit = pf fmt "@[(%a@ %a@ %a)@]" pp_binop b pp_term tm1 pp_term tm2 | Result (Some i) -> pf fmt "(result %i)" i | Result None -> pf fmt "result" + | Memory tm1 -> pf fmt "(memory %a)" pp_term tm1 let rec pp_prop : type a. formatter -> a prop -> unit = fun fmt -> function @@ -284,9 +281,6 @@ let rec parse_term = | List [ Atom "-"; tm1 ] -> let+ tm1 = parse_term tm1 in UnOp (Neg, tm1) - | List [ Atom c; tm1 ] -> - let+ tm1 = parse_term tm1 in - UnOp (CustomUnOp c, tm1) (* BinOp *) | List [ Atom "+"; tm1; tm2 ] -> let* tm1 = parse_term tm1 in @@ -304,10 +298,10 @@ let rec parse_term = let* tm1 = parse_term tm1 in let+ tm2 = parse_term tm2 in BinOp (Div, tm1, tm2) - | List [ Atom c; tm1; tm2 ] -> - let* tm1 = parse_term tm1 in - let+ tm2 = parse_term tm2 in - BinOp (CustomBinOp c, tm1, tm2) + (* Memory *) + | List [ Atom "memory"; tm1 ] -> + let+ tm1 = parse_term tm1 in + Memory tm1 (* Invalid *) | tm -> Error (`Spec_unknown_term tm) diff --git a/src/annot/spec.mli b/src/annot/spec.mli index 0cac60a82..4a1a114d8 100644 --- a/src/annot/spec.mli +++ b/src/annot/spec.mli @@ -27,16 +27,13 @@ type nonrec binder = type nonrec binder_type = num_type -type nonrec unop = - | Neg - | CustomUnOp of string (* for testing purpose only *) +type nonrec unop = Neg type nonrec binop = | Plus | Minus | Mult | Div - | CustomBinOp of string (* for testing purpose only *) type 'a term = | Int32 : Int32.t -> 'a term @@ -50,6 +47,7 @@ type 'a term = | UnOp : unop * 'a term -> 'a term | BinOp : binop * 'a term * 'a term -> 'a term | Result : int option -> 'a term + | Memory : 'a term -> 'a term type 'a prop = | Const : bool -> 'a prop diff --git a/src/ast/code_generator.ml b/src/ast/code_generator.ml index 6a695b9aa..185f47504 100644 --- a/src/ast/code_generator.ml +++ b/src/ast/code_generator.ml @@ -113,7 +113,6 @@ let unop_generate (u : unop) (expr1 : binary expr) (ty1 : binary val_type) : in Ok (expr, Num_type F64) | Ref_type _ -> Error (`Spec_type_error Fmt.(str "%a" pp_unop u)) ) - | CustomUnOp _ -> Error (`Spec_type_error Fmt.(str "%a" pp_unop u)) let binop_generate (b : binop) (expr1 : binary expr) (ty1 : binary val_type) (expr2 : binary expr) (ty2 : binary val_type) : @@ -179,7 +178,6 @@ let binop_generate (b : binop) (expr1 : binary expr) (ty1 : binary val_type) let expr = expr1 @ expr2 @ [ F_binop (S64, Div) ] in Ok (expr, Num_type F64) | _, _ -> Error (`Spec_type_error Fmt.(str "%a" pp_binop b)) ) - | CustomBinOp _ -> Error (`Spec_type_error Fmt.(str "%a" pp_binop b)) let rec term_generate tenv (term : binary term) : (binary expr * binary val_type) Result.t = @@ -214,6 +212,16 @@ let rec term_generate tenv (term : binary term) : | Result None -> if Array.length tenv.result_types = 0 then Error (`Spec_invalid_indice "0") else Ok ([ Local_get (tenv.result 0) ], tenv.result_types.(0)) + | Memory tm1 -> ( + let* expr1, ty1 = term_generate tenv tm1 in + match ty1 with + | Num_type I32 -> + Ok + ( expr1 + @ [ I_load (S32, { offset = Int32.of_int 0; align = Int32.of_int 0 }) + ] + , Num_type I32 ) + | _ -> Error (`Spec_type_error Fmt.(str "%a" pp_term tm1)) ) let binpred_generate (b : binpred) (expr1 : binary expr) (ty1 : binary val_type) (expr2 : binary expr) (ty2 : binary val_type) : binary expr Result.t = diff --git a/src/text_to_binary/rewrite.ml b/src/text_to_binary/rewrite.ml index 8f59eb831..c8b871fce 100644 --- a/src/text_to_binary/rewrite.ml +++ b/src/text_to_binary/rewrite.ml @@ -429,6 +429,9 @@ let rec rewrite_term ~(binder_list : string option list) ~(modul : Assigned.t) let+ tm2 = rewrite_term ~binder_list ~modul ~func_param_list tm2 in BinOp (b, tm1, tm2) | Result i -> Ok (Result i) + | Memory tm1 -> + let+ tm1 = rewrite_term ~binder_list ~modul ~func_param_list tm1 in + Memory tm1 let rec rewrite_prop ~(binder_list : string option list) ~(modul : Assigned.t) ~(func_param_list : string option list) : From e1763562a22399598c2873d0b169e707d04e786e Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Fri, 6 Sep 2024 13:05:34 +0200 Subject: [PATCH 47/51] changes.md --- CHANGES.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 695d6554b..954e3741b 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,8 @@ ## unreleased +- add `owi instrument` to instrument Webassembly module annotated by Weasel specification language +- add `--srac` option to `sym` and `conc` cmd +- add `--rac` option to `run`, `sym` and `conc` cmd - add `--output` option to `wat2wasm`, `wasm2wat` and `opt` cmd - Change `free` prototype to now return a pointer on which tracking is deactivated - add `--emit-file` option to `wasm2wat` to emit .wat files From 916ae44b5ba1b635d2447edbf2dae8d3f54dbd43 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Fri, 6 Sep 2024 14:24:15 +0200 Subject: [PATCH 48/51] add weasel example --- CHANGES.md | 3 +- example/run/README.md | 3 - example/weasel/README.md | 138 +++++++++++++++++++++ example/weasel/dune | 4 + example/weasel/plus_three.instrumented.wat | 30 +++++ example/weasel/plus_three.wat | 16 +++ src/bin/owi.ml | 2 +- src/cmd/cmd_run.ml | 8 +- src/cmd/cmd_run.mli | 2 +- test/opt/output.t | 1 - test/wasm2wat/output.t | 2 - 11 files changed, 195 insertions(+), 14 deletions(-) create mode 100644 example/weasel/README.md create mode 100644 example/weasel/dune create mode 100644 example/weasel/plus_three.instrumented.wat create mode 100644 example/weasel/plus_three.wat diff --git a/CHANGES.md b/CHANGES.md index 954e3741b..196b4a2f7 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,8 +1,7 @@ ## unreleased - add `owi instrument` to instrument Webassembly module annotated by Weasel specification language -- add `--srac` option to `sym` and `conc` cmd -- add `--rac` option to `run`, `sym` and `conc` cmd +- add `--rac` and `--srac` option to `sym` and `conc` cmd - add `--output` option to `wat2wasm`, `wasm2wat` and `opt` cmd - Change `free` prototype to now return a pointer on which tracking is deactivated - add `--emit-file` option to `wasm2wat` to emit .wat files diff --git a/example/run/README.md b/example/run/README.md index 7a549eb66..781d3b20e 100644 --- a/example/run/README.md +++ b/example/run/README.md @@ -70,9 +70,6 @@ OPTIONS -p, --profiling profiling mode - --rac - runtime assertion checking mode - -u, --unsafe skip typechecking pass diff --git a/example/weasel/README.md b/example/weasel/README.md new file mode 100644 index 000000000..f11ef0cfd --- /dev/null +++ b/example/weasel/README.md @@ -0,0 +1,138 @@ +# Weasel + +Weasel stands for WEbAssembly Specification Language, it can be used to annotate Webassembly text modules in [custom annotation](https://github.com/WebAssembly/annotations). Annotated modules can be instrumented to perform runtime assertion checking thanks to owi's code generator. + +Commands and options related to Weasel: +- `owi instrument` to instrument an annotated text module. +- `--rac` for `sym` and `conc` to instrument an annotated text module and perform runtime assertion checking. +- `--srac` for `sym` and `conc` to instrument an annotated text module and perform runtime assertion checking symbolically. + +The formal specification of Weasel can be found in `src/annot/spec.ml`. + +## Basic example + +Suppose we have a function returning its parameter plus three: + +```wast +(module + (;...;) + (func $plus_three (param $x i32) (result i32) + local.get $x + i32.const 3 + i32.add + ) + (;...;) +) +``` + +With Weasel, we can annotate this function by specifying its postconditions: + +```wast +(module + (;...;) + (@contract $plus_three + (ensures (= result (+ $x 3))) + ) + (func $plus_three (param $x i32) (result i32) + local.get $x + i32.const 3 + i32.add + ) + (;...;) +) +``` + +`owi instrument` generates a new wrapper function checking this postcondition: + +```sh +$ owi instrument plus_three.wat +$ cat plus_three.instrumented.wat +(module + (import "symbolic" "assert" (func $assert (param i32))) + (type (sub final (func (param $x i32) (result i32)))) + (type (sub final (func))) + (type (sub final (func (param i32)))) + (type (sub final (func (result i32)))) + (func $plus_three (param $x i32) (result i32) + local.get 0 + i32.const 3 + i32.add + ) + (func $start + i32.const 42 + call 3 + drop + ) + (func $__weasel_plus_three (param $x i32) (result i32) (local $__weasel_temp i32) (local $__weasel_res_0 i32) + local.get 0 + call 1 + local.set 2 + local.get 2 + local.get 0 + i32.const 3 + i32.add + i32.eq + call 0 + local.get 2 + ) + (start 2) +) +``` + +We can perform runtime assertion checking either by `owi sym plus_three.instrumented.wat` or by `owi sym --rac plus_three.wat`. + +```sh +$ owi sym plus_three.instrumented.wat +All OK +$ owi sym --rac plus_three.wat +All OK +``` + +## Man page + +```sh +$ owi instrument --help=plain +NAME + owi-instrument - Generate an instrumented file with runtime assertion + checking coming from Weasel specifications + +SYNOPSIS + owi instrument [--debug] [--symbolic] [--unsafe] [OPTION]… [ARG]… + +OPTIONS + -d, --debug + debug mode + + --symbolic + generate instrumented module that depends on symbolic execution + + -u, --unsafe + skip typechecking pass + +COMMON OPTIONS + --help[=FMT] (default=auto) + Show this help in format FMT. The value FMT must be one of auto, + pager, groff or plain. With auto, the format is pager or plain + whenever the TERM env var is dumb or undefined. + + --version + Show version information. + +EXIT STATUS + owi instrument exits with: + + 0 on success. + + 123 on indiscriminate errors reported on standard error. + + 124 on command line parsing errors. + + 125 on unexpected internal errors (bugs). + +BUGS + Email them to . + +SEE ALSO + owi(1) + +``` diff --git a/example/weasel/dune b/example/weasel/dune new file mode 100644 index 000000000..6588b0ba6 --- /dev/null +++ b/example/weasel/dune @@ -0,0 +1,4 @@ +(mdx + (libraries owi) + (deps %{bin:owi} plus_three.wat plus_three.instrumented.wat) + (files README.md)) diff --git a/example/weasel/plus_three.instrumented.wat b/example/weasel/plus_three.instrumented.wat new file mode 100644 index 000000000..60de0f0e1 --- /dev/null +++ b/example/weasel/plus_three.instrumented.wat @@ -0,0 +1,30 @@ +(module + (import "symbolic" "assert" (func $assert (param i32))) + (type (sub final (func (param $x i32) (result i32)))) + (type (sub final (func))) + (type (sub final (func (param i32)))) + (type (sub final (func (result i32)))) + (func $plus_three (param $x i32) (result i32) + local.get 0 + i32.const 3 + i32.add + ) + (func $start + i32.const 42 + call 3 + drop + ) + (func $__weasel_plus_three (param $x i32) (result i32) (local $__weasel_temp i32) (local $__weasel_res_0 i32) + local.get 0 + call 1 + local.set 2 + local.get 2 + local.get 0 + i32.const 3 + i32.add + i32.eq + call 0 + local.get 2 + ) + (start 2) +) \ No newline at end of file diff --git a/example/weasel/plus_three.wat b/example/weasel/plus_three.wat new file mode 100644 index 000000000..d1b3eed01 --- /dev/null +++ b/example/weasel/plus_three.wat @@ -0,0 +1,16 @@ +(module + (@contract $plus_three + (ensures (= result (+ $x 3))) + ) + (func $plus_three (param $x i32) (result i32) + local.get $x + i32.const 3 + i32.add + ) + (func $start + i32.const 42 + call $plus_three + drop + ) + (start $start) +) diff --git a/src/bin/owi.ml b/src/bin/owi.ml index 53ae9342e..6702c481d 100644 --- a/src/bin/owi.ml +++ b/src/bin/owi.ml @@ -231,7 +231,7 @@ let run_cmd = in Cmd.v info Term.( - const Cmd_run.cmd $ profiling $ debug $ unsafe $ rac $ optimize $ files ) + const Cmd_run.cmd $ profiling $ debug $ unsafe $ optimize $ files ) let validate_cmd = let open Cmdliner in diff --git a/src/cmd/cmd_run.ml b/src/cmd/cmd_run.ml index 3f159327d..b791c8546 100644 --- a/src/cmd/cmd_run.ml +++ b/src/cmd/cmd_run.ml @@ -4,15 +4,15 @@ open Syntax -let run_file ~unsafe ~rac ~optimize filename = +let run_file ~unsafe ~optimize filename = let name = None in let+ (_ : _ Link.state) = - Compile.File.until_interpret ~unsafe ~rac ~srac:false ~optimize ~name + Compile.File.until_interpret ~unsafe ~rac:false ~srac:false ~optimize ~name Link.empty_state filename in () -let cmd profiling debug unsafe rac optimize files = +let cmd profiling debug unsafe optimize files = if profiling then Log.profiling_on := true; if debug then Log.debug_on := true; - list_iter (run_file ~unsafe ~rac ~optimize) files + list_iter (run_file ~unsafe ~optimize) files diff --git a/src/cmd/cmd_run.mli b/src/cmd/cmd_run.mli index 63aec0acf..5cef2e0c3 100644 --- a/src/cmd/cmd_run.mli +++ b/src/cmd/cmd_run.mli @@ -2,4 +2,4 @@ (* Copyright © 2021-2024 OCamlPro *) (* Written by the Owi programmers *) -val cmd : bool -> bool -> bool -> bool -> bool -> Fpath.t list -> unit Result.t +val cmd : bool -> bool -> bool -> bool -> Fpath.t list -> unit Result.t diff --git a/test/opt/output.t b/test/opt/output.t index f99c975c9..310f5cdaf 100644 --- a/test/opt/output.t +++ b/test/opt/output.t @@ -1,7 +1,6 @@ $ owi opt fbinop.wat -o bar.wat $ owi fmt bar.wat (module - (type (sub final (func))) (func $start diff --git a/test/wasm2wat/output.t b/test/wasm2wat/output.t index ad270c4f6..a3f3c79d7 100644 --- a/test/wasm2wat/output.t +++ b/test/wasm2wat/output.t @@ -1,9 +1,7 @@ $ owi wasm2wat done.wasm -o bar.wat $ owi fmt bar.wat (module - (type (sub final (func (param i32) (param i32) (result i32)))) - (type (sub final (func))) (func (param i32) (param i32) (result i32) local.get 0 From 681a2b45080001adee826a637c7da1da656fe783 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Fri, 6 Sep 2024 14:39:28 +0200 Subject: [PATCH 49/51] readd owi run --rac --- CHANGES.md | 3 ++- example/run/README.md | 3 +++ example/weasel/README.md | 2 +- src/bin/owi.ml | 2 +- src/cmd/cmd_run.ml | 8 ++++---- src/cmd/cmd_run.mli | 2 +- 6 files changed, 12 insertions(+), 8 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 196b4a2f7..954e3741b 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,7 +1,8 @@ ## unreleased - add `owi instrument` to instrument Webassembly module annotated by Weasel specification language -- add `--rac` and `--srac` option to `sym` and `conc` cmd +- add `--srac` option to `sym` and `conc` cmd +- add `--rac` option to `run`, `sym` and `conc` cmd - add `--output` option to `wat2wasm`, `wasm2wat` and `opt` cmd - Change `free` prototype to now return a pointer on which tracking is deactivated - add `--emit-file` option to `wasm2wat` to emit .wat files diff --git a/example/run/README.md b/example/run/README.md index 781d3b20e..7a549eb66 100644 --- a/example/run/README.md +++ b/example/run/README.md @@ -70,6 +70,9 @@ OPTIONS -p, --profiling profiling mode + --rac + runtime assertion checking mode + -u, --unsafe skip typechecking pass diff --git a/example/weasel/README.md b/example/weasel/README.md index f11ef0cfd..0728db489 100644 --- a/example/weasel/README.md +++ b/example/weasel/README.md @@ -4,7 +4,7 @@ Weasel stands for WEbAssembly Specification Language, it can be used to annotate Commands and options related to Weasel: - `owi instrument` to instrument an annotated text module. -- `--rac` for `sym` and `conc` to instrument an annotated text module and perform runtime assertion checking. +- `--rac` for `run`, `sym` and `conc` to instrument an annotated text module and perform runtime assertion checking. - `--srac` for `sym` and `conc` to instrument an annotated text module and perform runtime assertion checking symbolically. The formal specification of Weasel can be found in `src/annot/spec.ml`. diff --git a/src/bin/owi.ml b/src/bin/owi.ml index 6702c481d..53ae9342e 100644 --- a/src/bin/owi.ml +++ b/src/bin/owi.ml @@ -231,7 +231,7 @@ let run_cmd = in Cmd.v info Term.( - const Cmd_run.cmd $ profiling $ debug $ unsafe $ optimize $ files ) + const Cmd_run.cmd $ profiling $ debug $ unsafe $ rac $ optimize $ files ) let validate_cmd = let open Cmdliner in diff --git a/src/cmd/cmd_run.ml b/src/cmd/cmd_run.ml index b791c8546..3f159327d 100644 --- a/src/cmd/cmd_run.ml +++ b/src/cmd/cmd_run.ml @@ -4,15 +4,15 @@ open Syntax -let run_file ~unsafe ~optimize filename = +let run_file ~unsafe ~rac ~optimize filename = let name = None in let+ (_ : _ Link.state) = - Compile.File.until_interpret ~unsafe ~rac:false ~srac:false ~optimize ~name + Compile.File.until_interpret ~unsafe ~rac ~srac:false ~optimize ~name Link.empty_state filename in () -let cmd profiling debug unsafe optimize files = +let cmd profiling debug unsafe rac optimize files = if profiling then Log.profiling_on := true; if debug then Log.debug_on := true; - list_iter (run_file ~unsafe ~optimize) files + list_iter (run_file ~unsafe ~rac ~optimize) files diff --git a/src/cmd/cmd_run.mli b/src/cmd/cmd_run.mli index 5cef2e0c3..63aec0acf 100644 --- a/src/cmd/cmd_run.mli +++ b/src/cmd/cmd_run.mli @@ -2,4 +2,4 @@ (* Copyright © 2021-2024 OCamlPro *) (* Written by the Owi programmers *) -val cmd : bool -> bool -> bool -> bool -> Fpath.t list -> unit Result.t +val cmd : bool -> bool -> bool -> bool -> bool -> Fpath.t list -> unit Result.t From d0c7c952b780a3b2983ad9e035f0a58b7e6b1c34 Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Fri, 6 Sep 2024 15:10:11 +0200 Subject: [PATCH 50/51] link assert_i32 in cmd_run --- src/cmd/cmd_run.ml | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/src/cmd/cmd_run.ml b/src/cmd/cmd_run.ml index 3f159327d..d3e949f16 100644 --- a/src/cmd/cmd_run.ml +++ b/src/cmd/cmd_run.ml @@ -4,11 +4,26 @@ open Syntax +let extern_module : Concrete_value.Func.extern_func Link.extern_module = + let assert_i32 n = assert (not @@ Prelude.Int32.equal n 0l) in + let functions = + [ ( "assert" + , Concrete_value.Func.Extern_func (Func (Arg (I32, Res), R0), assert_i32) + ) + ] + in + { functions } + +(* module name is called "symbolic" to be compatible with code generator *) +let link_state = + Link.extern_module Link.empty_state ~name:"symbolic" extern_module + let run_file ~unsafe ~rac ~optimize filename = let name = None in + let link_state = if rac then link_state else Link.empty_state in let+ (_ : _ Link.state) = Compile.File.until_interpret ~unsafe ~rac ~srac:false ~optimize ~name - Link.empty_state filename + link_state filename in () From f39e44375e1a43ec14c51bad237b3af65314283b Mon Sep 17 00:00:00 2001 From: Zhicheng HUI Date: Tue, 17 Sep 2024 10:30:52 +0200 Subject: [PATCH 51/51] add assert.wat in test --- src/ast/code_generator.ml | 7 ++----- test/weasel/assert.t | 1 + test/weasel/assert.wat | 8 ++++++++ test/weasel/dune | 2 +- 4 files changed, 12 insertions(+), 6 deletions(-) create mode 100644 test/weasel/assert.t create mode 100644 test/weasel/assert.wat diff --git a/src/ast/code_generator.ml b/src/ast/code_generator.ml index 185f47504..b2c3ade79 100644 --- a/src/ast/code_generator.ml +++ b/src/ast/code_generator.ml @@ -686,11 +686,8 @@ let add_owi_funcs (owi_funcs : (string * binary func_type) array) (m : modul) : in update_func () -let generate (symbolic : bool) (m : modul) : modul Result.t = - let owi_funcs = - if symbolic then [| ("assert", ([ (None, Num_type I32) ], [])) |] - else [| ("assert", ([ (None, Num_type I32) ], [])) |] - in +let generate (_symbolic : bool) (m : modul) : modul Result.t = + let owi_funcs = [| ("assert", ([ (None, Num_type I32) ], [])) |] in let m, owi_funcs = add_owi_funcs owi_funcs m in contracts_generate owi_funcs m (List.filter_map diff --git a/test/weasel/assert.t b/test/weasel/assert.t new file mode 100644 index 000000000..a9cf4050b --- /dev/null +++ b/test/weasel/assert.t @@ -0,0 +1 @@ + $ owi run --rac ./assert.wat diff --git a/test/weasel/assert.wat b/test/weasel/assert.wat new file mode 100644 index 000000000..748b78e43 --- /dev/null +++ b/test/weasel/assert.wat @@ -0,0 +1,8 @@ +(module + (@contract $start + (requires (= 2 (+ 1 1))) + ) + (func $start + ) + (start $start) +) diff --git a/test/weasel/dune b/test/weasel/dune index d929f1550..b1a73d7ab 100644 --- a/test/weasel/dune +++ b/test/weasel/dune @@ -1,2 +1,2 @@ (cram - (deps %{bin:owi} forall.wat plus.wat sum.wat)) + (deps %{bin:owi} assert.wat forall.wat plus.wat sum.wat))