From 9e51593ab22da51f4e1711a5ab540b723381288a Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 24 Apr 2023 14:18:37 +0900 Subject: [PATCH 001/108] update .gitignore --- src/regnant/.gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/regnant/.gitignore b/src/regnant/.gitignore index 5b3aa78e..d5bb4344 100644 --- a/src/regnant/.gitignore +++ b/src/regnant/.gitignore @@ -6,3 +6,5 @@ build/ sootOutput/ tmp/ minepump +bin/ +.idea/ \ No newline at end of file From 76a3fba197f0b8575f2b47c1aeb8a6a1ebbfb47e Mon Sep 17 00:00:00 2001 From: artoy Date: Sun, 7 May 2023 18:24:17 +0900 Subject: [PATCH 002/108] update .gitignore --- src/.gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/src/.gitignore b/src/.gitignore index 4eeaaab6..29b36a4f 100644 --- a/src/.gitignore +++ b/src/.gitignore @@ -1,3 +1,4 @@ *.smt /recursive-tests/ /benchmarks/consort/**/*.class +.tmp/ \ No newline at end of file From 470a0c7b1c58409ac9e5635f1144f4f5ac81e836 Mon Sep 17 00:00:00 2001 From: artoy Date: Sun, 7 May 2023 18:25:44 +0900 Subject: [PATCH 003/108] some fix --- src/.gitignore | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/.gitignore b/src/.gitignore index 29b36a4f..1d326fe2 100644 --- a/src/.gitignore +++ b/src/.gitignore @@ -1,4 +1,4 @@ *.smt /recursive-tests/ /benchmarks/consort/**/*.class -.tmp/ \ No newline at end of file +tmp/ \ No newline at end of file From a8e1bdd839abb43afc247f8e6d14901b025c23f7 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Sun, 7 May 2023 22:13:01 +0900 Subject: [PATCH 004/108] update lexer and parser --- src/lexer.mll | 5 +++++ src/parser.mly | 11 +++++++++++ src/surfaceAst.ml | 4 ++++ 3 files changed, 20 insertions(+) diff --git a/src/lexer.mll b/src/lexer.mll index 72cc8b05..b6ceca5d 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -68,6 +68,11 @@ rule read = | '_' { UNDERSCORE } | id { ID (Lexing.lexeme lexbuf) } | eof { EOF } + | "Nil" { NIL } + | "Cons" { CONS } + | "match" { MATCH } + | "with" { WITH } + | "|" { BAR } | _ { failwith @@ "Invalid token " ^ (Lexing.lexeme lexbuf) } and comment = parse diff --git a/src/parser.mly b/src/parser.mly index ec46b923..09f1f333 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -44,6 +44,9 @@ %token ARROW %token NU AND +// pattern match of list +%token CONS NIL MATCH WITH BAR + %left AND %type lhs @@ -104,6 +107,9 @@ let expr := | RETURN; lbl = expr_label; e = lhs; { Return ((lbl,$startpos),e) } + | MATCH; lbl = expr_label; e1 = lhs; WITH; NIL; ARROW; e2 = expr; BAR; CONS; h = ID; r = ID; ARROW; e3 = expr; { + Match ((lbl,$startpos),e1,e2,h,r,e3) + } let ap := | STAR; a = ap_prim; { Paths.deref a } @@ -128,6 +134,7 @@ let op := | ~ = ID; <`OVar> | TRUE; { `OBool true } | FALSE; { `OBool false } + | NIL; { `Nil } | STAR; ~ = ID; <`ODeref> | ~ = nondet; <> | LPAREN; o = lhs; RPAREN; { o } @@ -136,6 +143,10 @@ let op := | LPAREN; l = tuple_contents; RPAREN; <`Tuple> | ~ = array_expr; <`Read> | ~ = op; DOT; LENGTH; <`LengthOf> + | ~ = cons; <> + +let cons := + | ~ = CONS; h = lhs; r = cons <`Cons> let tuple_rest := | l = lhs; COMMA; { [l] } diff --git a/src/surfaceAst.ml b/src/surfaceAst.ml index f10f3af2..219923e7 100644 --- a/src/surfaceAst.ml +++ b/src/surfaceAst.ml @@ -38,6 +38,8 @@ type lhs = [ | `Tuple of lhs list | `Read of lhs * lhs | `LengthOf of lhs + | `Nil + | `Cons of lhs * lhs ] and call = string * int * (lhs list) type relation = { @@ -63,6 +65,7 @@ type exp = | Assert of pos * relation | Seq of Lexing.position * exp * exp | Return of pos * lhs + | Match of pos * lhs * exp * exp * string * string * exp type fn = string * string list * exp type prog = fn list * exp @@ -185,6 +188,7 @@ let rec simplify_expr ?next ~is_tail count e : pos * A.raw_exp = lift_to_var ~ctxt:i count rval (fun _ tvar -> A.Return tvar |> tag_with i ) + | raise and lift_to_lhs ~ctxt count (lhs : lhs) (rest: int -> A.lhs -> A.exp) = let k r = rest count r in From eed6e27092285174a03f5ae9dbb963b5b5a28a46 Mon Sep 17 00:00:00 2001 From: artoy Date: Sun, 7 May 2023 23:01:15 +0900 Subject: [PATCH 005/108] fix cons and match --- src/parser.mly | 4 ++-- src/surfaceAst.ml | 9 +++++++-- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/src/parser.mly b/src/parser.mly index 09f1f333..769e49bc 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -134,7 +134,6 @@ let op := | ~ = ID; <`OVar> | TRUE; { `OBool true } | FALSE; { `OBool false } - | NIL; { `Nil } | STAR; ~ = ID; <`ODeref> | ~ = nondet; <> | LPAREN; o = lhs; RPAREN; { o } @@ -146,7 +145,8 @@ let op := | ~ = cons; <> let cons := - | ~ = CONS; h = lhs; r = cons <`Cons> + | CONS; h = lhs; r = cons; <`Cons> + | NIL; { `Nil } let tuple_rest := | l = lhs; COMMA; { [l] } diff --git a/src/surfaceAst.ml b/src/surfaceAst.ml index 219923e7..ad2a2152 100644 --- a/src/surfaceAst.ml +++ b/src/surfaceAst.ml @@ -65,7 +65,7 @@ type exp = | Assert of pos * relation | Seq of Lexing.position * exp * exp | Return of pos * lhs - | Match of pos * lhs * exp * exp * string * string * exp + | Match of pos * lhs * exp * string * string * exp type fn = string * string list * exp type prog = fn list * exp @@ -92,6 +92,9 @@ let sanity_check_alias (v1:Paths.path) (v2:Paths.path) = if root1=root2 then (print_string "Warning: found an alias statement that contains more than one occurrence of the same variable.\nThe analysis may be unsound\n";flush stdout) +(* FIXME: delete it before merge to main branch *) +exception Not_implemented of string + (* This rewriting is fairly standard, but it helps to understand some key components. First, count determines the number of temporary variables in scope, this ensures temporary variables are unique when they are created. This count is thus threaded through @@ -188,7 +191,7 @@ let rec simplify_expr ?next ~is_tail count e : pos * A.raw_exp = lift_to_var ~ctxt:i count rval (fun _ tvar -> A.Return tvar |> tag_with i ) - | raise + | Match (_, _, _, _, _, _) -> raise(Not_implemented "match") and lift_to_lhs ~ctxt count (lhs : lhs) (rest: int -> A.lhs -> A.exp) = let k r = rest count r in @@ -228,6 +231,8 @@ and lift_to_lhs ~ctxt count (lhs : lhs) (rest: int -> A.lhs -> A.exp) = ) ) | `OBool f -> k @@ A.Const (if f then 0 else 1) + | `Cons _ -> raise (Not_implemented "cons") + | `Nil -> raise (Not_implemented "nil") and lift_to_rinit ~ctxt count (r: lhs) rest = let k = rest count in From e81e6f3de7da708564deb3e0573bba073a08b49e Mon Sep 17 00:00:00 2001 From: artoy Date: Sun, 7 May 2023 23:21:02 +0900 Subject: [PATCH 006/108] fix lexer --- src/lexer.mll | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/lexer.mll b/src/lexer.mll index b6ceca5d..3f2fccca 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -64,15 +64,15 @@ rule read = | '~' { NU } | ":=" { ASSIGN } | "null" { NULL } - | operators { OPERATOR (Lexing.lexeme lexbuf) } - | '_' { UNDERSCORE } - | id { ID (Lexing.lexeme lexbuf) } - | eof { EOF } | "Nil" { NIL } | "Cons" { CONS } | "match" { MATCH } | "with" { WITH } | "|" { BAR } + | operators { OPERATOR (Lexing.lexeme lexbuf) } + | '_' { UNDERSCORE } + | id { ID (Lexing.lexeme lexbuf) } + | eof { EOF } | _ { failwith @@ "Invalid token " ^ (Lexing.lexeme lexbuf) } and comment = parse From e2fbc28ee7d2496f03b1f1f9b427c41825c0b3b1 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 8 May 2023 13:16:23 +0900 Subject: [PATCH 007/108] fix parser (but occurs shift/reduce conflict) --- src/parser.mly | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parser.mly b/src/parser.mly index 769e49bc..0a3cc745 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -142,10 +142,10 @@ let op := | LPAREN; l = tuple_contents; RPAREN; <`Tuple> | ~ = array_expr; <`Read> | ~ = op; DOT; LENGTH; <`LengthOf> - | ~ = cons; <> + | CONS; h = lhs; r = cons; <`Cons> let cons := - | CONS; h = lhs; r = cons; <`Cons> + | LPAREN; CONS; h = lhs; r = cons; RPAREN; <`Cons> | NIL; { `Nil } let tuple_rest := From 5a97cdff72ee5a54ddf5ca6050e5c12b513683de Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 8 May 2023 17:54:34 +0900 Subject: [PATCH 008/108] add match --- src/ast.ml | 7 +++++-- src/astPrinter.ml | 10 ++++++++++ src/flowInference.ml | 2 ++ src/ownershipInference.ml | 1 + src/simpleChecker.ml | 2 +- src/surfaceAst.ml | 13 +++++++------ 6 files changed, 26 insertions(+), 9 deletions(-) diff --git a/src/ast.ml b/src/ast.ml index 89c94a29..8d7303e4 100644 --- a/src/ast.ml +++ b/src/ast.ml @@ -28,7 +28,9 @@ type lhs = | Nondet of RefinementTypes.concr_refinement option | Read of string * string | LengthOf of string - | Null [@@deriving sexp] + | Null + | Nil + | Cons of lhs * lhs [@@deriving sexp] type patt = | PVar of string @@ -64,7 +66,8 @@ type raw_exp = | Let of patt * lhs * exp | Alias of Paths.concr_ap * Paths.concr_ap * exp | Assert of relation * exp - | Return of string [@@deriving sexp] + | Return of string + | Match of lhs * exp * string * string * exp [@@deriving sexp] and exp = position * raw_exp [@@deriving sexp] diff --git a/src/astPrinter.ml b/src/astPrinter.ml index f86bee4b..6eecc928 100644 --- a/src/astPrinter.ml +++ b/src/astPrinter.ml @@ -161,6 +161,16 @@ let rec pp_expr ~ip:((po_id,pr_id) as ip) ~annot (id,e) = | Unit -> ps "()" | Return v -> pf "return%a %s" po_id id v | Fail -> ps "fail" + | Match (e1, e2, h, r, e3) -> + pl [ + pf "match %a with" (ul pp_lhs) e1; + pf "| Nil -> {"; + pp_expr ~ip ~annot e2; + ps "}"; + pf "| Cons(%s,%s) -> {" h r; + pp_expr ~ip ~annot e3; + ps "}"; + ] in match e with | Seq _ -> e_printer diff --git a/src/flowInference.ml b/src/flowInference.ml index 6ca8a38a..886b251d 100644 --- a/src/flowInference.ml +++ b/src/flowInference.ml @@ -2217,6 +2217,7 @@ let relation_name ((e_id,_),expr) ctxt = | Unit -> "unit" | Return _ -> "return" | Fail -> "fail" + | Match _ -> "match" in prefix ^ kind @@ -2840,6 +2841,7 @@ let rec process_expr ~output (((relation : relation),tyenv) as st) continuation alias_recursive >> add_implication ante @@ PRelation (k_rel,out_subst,None) >> process_expr ~output (k_rel,tyenv) continuation k + | Match (_, _, _, _, _) -> assert false let analyze_function fn ctxt = let { in_rel = (in_nm,in_args, isrc); diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 1dbfcab9..0b29b1c9 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -728,6 +728,7 @@ let rec process_expr ~output ((e_id,_),expr) = in let bindings = assign_patt_loop [] patt to_bind in with_types bindings @@ process_expr ~output body + | Match (_, _, _, _, _) -> assert false and process_conditional ~e_id ~tr_branch ~output e1 e2 ctxt = let (ctxt_tpre,()) = tr_branch ctxt in let (ctxt_t,tfl) = process_expr ~output e1 ctxt_tpre in diff --git a/src/simpleChecker.ml b/src/simpleChecker.ml index 9a1c838c..e9578125 100644 --- a/src/simpleChecker.ml +++ b/src/simpleChecker.ml @@ -554,7 +554,7 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = unify t ty; res_acc,true end - + | Match (_, _, _, _, _) -> assert false let constrain_fn sub fenv acc ({ name; body; _ } as fn) = let tyenv = init_tyenv fenv fn in diff --git a/src/surfaceAst.ml b/src/surfaceAst.ml index ad2a2152..58fc5660 100644 --- a/src/surfaceAst.ml +++ b/src/surfaceAst.ml @@ -92,9 +92,6 @@ let sanity_check_alias (v1:Paths.path) (v2:Paths.path) = if root1=root2 then (print_string "Warning: found an alias statement that contains more than one occurrence of the same variable.\nThe analysis may be unsound\n";flush stdout) -(* FIXME: delete it before merge to main branch *) -exception Not_implemented of string - (* This rewriting is fairly standard, but it helps to understand some key components. First, count determines the number of temporary variables in scope, this ensures temporary variables are unique when they are created. This count is thus threaded through @@ -191,7 +188,11 @@ let rec simplify_expr ?next ~is_tail count e : pos * A.raw_exp = lift_to_var ~ctxt:i count rval (fun _ tvar -> A.Return tvar |> tag_with i ) - | Match (_, _, _, _, _, _) -> raise(Not_implemented "match") + | Match (i, e1, e2, h, r, e3) -> + lift_to_lhs ~ctxt:i count e1 (fun c e1' -> + A.Match (e1', simplify_expr ~is_tail c e2, h, r, simplify_expr ~is_tail c e3) + |> tag_with i + ) and lift_to_lhs ~ctxt count (lhs : lhs) (rest: int -> A.lhs -> A.exp) = let k r = rest count r in @@ -231,8 +232,8 @@ and lift_to_lhs ~ctxt count (lhs : lhs) (rest: int -> A.lhs -> A.exp) = ) ) | `OBool f -> k @@ A.Const (if f then 0 else 1) - | `Cons _ -> raise (Not_implemented "cons") - | `Nil -> raise (Not_implemented "nil") + | `Cons _ -> assert false + | `Nil -> assert false and lift_to_rinit ~ctxt count (r: lhs) rest = let k = rest count in From 08433d703dafe56083d89962032478affce575ce Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Wed, 10 May 2023 10:11:44 +0900 Subject: [PATCH 009/108] implement nil in simplify_expr --- src/surfaceAst.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/surfaceAst.ml b/src/surfaceAst.ml index 58fc5660..897f1d57 100644 --- a/src/surfaceAst.ml +++ b/src/surfaceAst.ml @@ -233,7 +233,7 @@ and lift_to_lhs ~ctxt count (lhs : lhs) (rest: int -> A.lhs -> A.exp) = ) | `OBool f -> k @@ A.Const (if f then 0 else 1) | `Cons _ -> assert false - | `Nil -> assert false + | `Nil -> k @@ A.Nil and lift_to_rinit ~ctxt count (r: lhs) rest = let k = rest count in From cb05842b18b7e48884d1ecd72c73df6d408865e6 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 11 May 2023 15:36:31 +0900 Subject: [PATCH 010/108] complete surfaceAST --- src/astPrinter.ml | 11 ++++++++++- src/flowInference.ml | 2 ++ src/ownershipInference.ml | 2 ++ src/parser.mly | 1 + src/simpleChecker.ml | 2 ++ src/surfaceAst.ml | 6 +++++- 6 files changed, 22 insertions(+), 2 deletions(-) diff --git a/src/astPrinter.ml b/src/astPrinter.ml index 6eecc928..4da7b998 100644 --- a/src/astPrinter.ml +++ b/src/astPrinter.ml @@ -75,7 +75,7 @@ let rec pp_ref_ast (r: RefinementTypes.concr_refinement) = (ul pp_ref_ast) r2 | _ -> failwith @@ "Cannot annotate with relation " ^ (string_of_refinement r) -let pp_lhs = function +let rec pp_lhs = function | Var x -> pv x | Const i -> pi i | Mkref il -> pl [ @@ -104,6 +104,15 @@ let pp_lhs = function pf "%s[%s]" b i | LengthOf v -> pf "%s.length" v + | Cons (h, r) -> + pl [ + ps "cons"; + pp_lhs h; + ps "("; + pp_lhs r; + ps ")" + ] + | Nil -> ps "nil" let rec pp_patt = function | PVar v -> pv v diff --git a/src/flowInference.ml b/src/flowInference.ml index 886b251d..cb36f44b 100644 --- a/src/flowInference.ml +++ b/src/flowInference.ml @@ -2201,6 +2201,8 @@ let apply_patt ~e_id tyenv patt rhs = RecRelations.null_for_var ~e_id ~ty:null_types v >> H.update_null_havoc ~e_id ~ty:null_types v >> add_relation_flow ?pre:None flows in_rel out_rel) + | PVar _, Cons _ -> assert false + | PVar _, Nil -> assert false let relation_name ((e_id,_),expr) ctxt = let prefix = Printf.sprintf "%s-%d-" (Option.value ~default:"main-fn" ctxt.curr_fun) e_id in diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 0b29b1c9..df8c380b 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -717,6 +717,8 @@ let rec process_expr ~output ((e_id,_),expr) = ) t_init in return @@ Tuple tl | Call c -> process_call e_id c + | Cons _ -> assert false + | Nil -> assert false in let rec assign_patt_loop acc patt ty = match patt,ty with diff --git a/src/parser.mly b/src/parser.mly index 0a3cc745..7d771143 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -143,6 +143,7 @@ let op := | ~ = array_expr; <`Read> | ~ = op; DOT; LENGTH; <`LengthOf> | CONS; h = lhs; r = cons; <`Cons> + | NIL; { `Nil } let cons := | LPAREN; CONS; h = lhs; r = cons; RPAREN; <`Cons> diff --git a/src/simpleChecker.ml b/src/simpleChecker.ml index e9578125..4cb2443c 100644 --- a/src/simpleChecker.ml +++ b/src/simpleChecker.ml @@ -531,6 +531,8 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = let cont = fresh_var () in unify_var b @@ `Array cont; same cont + | Cons _ -> assert false; + | Nil -> assert false; in let rec unify_patt acc p t = match p with diff --git a/src/surfaceAst.ml b/src/surfaceAst.ml index 897f1d57..58f8c983 100644 --- a/src/surfaceAst.ml +++ b/src/surfaceAst.ml @@ -232,7 +232,11 @@ and lift_to_lhs ~ctxt count (lhs : lhs) (rest: int -> A.lhs -> A.exp) = ) ) | `OBool f -> k @@ A.Const (if f then 0 else 1) - | `Cons _ -> assert false + | `Cons (h, r) -> lift_to_lhs ~ctxt count h (fun c h' -> + lift_to_lhs ~ctxt c r (fun c' r' -> + rest c' @@ A.Cons (h', r') + ) + ) | `Nil -> k @@ A.Nil and lift_to_rinit ~ctxt count (r: lhs) rest = From 235de7e287c9a31eaf5b40c627ab09f454e88631 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Fri, 12 May 2023 17:50:08 +0900 Subject: [PATCH 011/108] add tests --- src/.gitignore | 1 - src/test/list/cons.imp | 5 +++++ src/test/list/match.imp | 14 ++++++++++++++ src/test/list/nil.imp | 4 ++++ 4 files changed, 23 insertions(+), 1 deletion(-) create mode 100644 src/test/list/cons.imp create mode 100644 src/test/list/match.imp create mode 100644 src/test/list/nil.imp diff --git a/src/.gitignore b/src/.gitignore index 1d326fe2..4eeaaab6 100644 --- a/src/.gitignore +++ b/src/.gitignore @@ -1,4 +1,3 @@ *.smt /recursive-tests/ /benchmarks/consort/**/*.class -tmp/ \ No newline at end of file diff --git a/src/test/list/cons.imp b/src/test/list/cons.imp new file mode 100644 index 00000000..38defab4 --- /dev/null +++ b/src/test/list/cons.imp @@ -0,0 +1,5 @@ +{ + let x = Cons 1 Nil in + let y = Cons 1 (Cons 2 (Cons 3 Nil)) in + assert(y = Cons 1 (Cons 2 (Cons 3 Nil))) +} \ No newline at end of file diff --git a/src/test/list/match.imp b/src/test/list/match.imp new file mode 100644 index 00000000..a4e7cacb --- /dev/null +++ b/src/test/list/match.imp @@ -0,0 +1,14 @@ +sum(l, s) { + match l with + Nil -> s + | Cons h r -> { + let s = s + h in + sum(r, s) + } +} + +{ + let l = Cons 1 (Cons 2 (Cons 3 Nil)) in + let s = sum(l, 0) in + assert(s = 6) +} \ No newline at end of file diff --git a/src/test/list/nil.imp b/src/test/list/nil.imp new file mode 100644 index 00000000..613912a0 --- /dev/null +++ b/src/test/list/nil.imp @@ -0,0 +1,4 @@ +{ + let x = Nil in + assert(x = Nil) +} \ No newline at end of file From 1ee6dad07a50c2e4af92fef0f0c2572df5a9b12f Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Wed, 17 May 2023 10:51:54 +0900 Subject: [PATCH 012/108] add intlist --- src/simpleChecker.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/simpleChecker.ml b/src/simpleChecker.ml index 4cb2443c..3c496df5 100644 --- a/src/simpleChecker.ml +++ b/src/simpleChecker.ml @@ -65,6 +65,7 @@ type 'a c_typ = [ | `TyCons of TyCons.t | `Tuple of 'a list | `Array of 'a + | `IntList ] [@@deriving sexp] type typ = [ From 1ce1170b06b260951717bda01f8139a88d575e45 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 18 May 2023 13:53:36 +0900 Subject: [PATCH 013/108] add definition fold and unfold --- src/ast.ml | 4 +++- src/simpleChecker.ml | 4 ++-- src/surfaceAst.ml | 6 +++--- 3 files changed, 8 insertions(+), 6 deletions(-) diff --git a/src/ast.ml b/src/ast.ml index 8d7303e4..953c151a 100644 --- a/src/ast.ml +++ b/src/ast.ml @@ -30,7 +30,9 @@ type lhs = | LengthOf of string | Null | Nil - | Cons of lhs * lhs [@@deriving sexp] + | Cons of lhs * lhs + | Fold of lhs + | Unfold of lhs [@@deriving sexp] type patt = | PVar of string diff --git a/src/simpleChecker.ml b/src/simpleChecker.ml index 3c496df5..619c13b0 100644 --- a/src/simpleChecker.ml +++ b/src/simpleChecker.ml @@ -204,9 +204,9 @@ let rec occurs_check sub v (t2: typ) = | `Tuple tl -> List.iter (occurs_check sub v) tl | `Array t' -> occurs_check sub v t' | `Var _ - | `Int + | `Int -> () (* Notice that we do not check reference contents for recursion. Recursion under a reference constructor is fine *) - | `TyCons _ -> () + (* | `TyCons _ -> () *) let assign sub var t = occurs_check sub var (t :> typ); diff --git a/src/surfaceAst.ml b/src/surfaceAst.ml index 58f8c983..f5b1a0c3 100644 --- a/src/surfaceAst.ml +++ b/src/surfaceAst.ml @@ -190,7 +190,7 @@ let rec simplify_expr ?next ~is_tail count e : pos * A.raw_exp = ) | Match (i, e1, e2, h, r, e3) -> lift_to_lhs ~ctxt:i count e1 (fun c e1' -> - A.Match (e1', simplify_expr ~is_tail c e2, h, r, simplify_expr ~is_tail c e3) + A.Match (A.Unfold e1', simplify_expr ~is_tail c e2, h, r, simplify_expr ~is_tail c e3) |> tag_with i ) @@ -234,10 +234,10 @@ and lift_to_lhs ~ctxt count (lhs : lhs) (rest: int -> A.lhs -> A.exp) = | `OBool f -> k @@ A.Const (if f then 0 else 1) | `Cons (h, r) -> lift_to_lhs ~ctxt count h (fun c h' -> lift_to_lhs ~ctxt c r (fun c' r' -> - rest c' @@ A.Cons (h', r') + rest c' @@ A.Fold (A.Cons (h', r')) ) ) - | `Nil -> k @@ A.Nil + | `Nil -> k @@ A.Fold A.Nil and lift_to_rinit ~ctxt count (r: lhs) rest = let k = rest count in From 756affc45609ac4e4285b6535b9c7550e7d4b355 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 18 May 2023 16:13:26 +0900 Subject: [PATCH 014/108] add process recursive types --- src/simpleChecker.ml | 31 +++++++++++++++++++++++++++---- 1 file changed, 27 insertions(+), 4 deletions(-) diff --git a/src/simpleChecker.ml b/src/simpleChecker.ml index 619c13b0..defb792e 100644 --- a/src/simpleChecker.ml +++ b/src/simpleChecker.ml @@ -66,11 +66,13 @@ type 'a c_typ = [ | `Tuple of 'a list | `Array of 'a | `IntList + | `Nil ] [@@deriving sexp] type typ = [ typ c_typ | `Var of int +| `Cons of typ * typ ] [@@deriving sexp] type refined_typ = typ c_typ @@ -203,10 +205,14 @@ let rec occurs_check sub v (t2: typ) = | `Var v' when v' = v -> failwith "Malformed recursive type" | `Tuple tl -> List.iter (occurs_check sub v) tl | `Array t' -> occurs_check sub v t' + | `Cons (x, y) -> occurs_check sub v x; occurs_check sub v y + | `IntList + | `Nil | `Var _ - | `Int -> () + | `Int (* Notice that we do not check reference contents for recursion. Recursion under a reference constructor is fine *) - (* | `TyCons _ -> () *) + (* TODO: Probably, TyCons is going to be deleted *) + | `TyCons _ -> () let assign sub var t = occurs_check sub var (t :> typ); @@ -356,6 +362,21 @@ let dump_sexp p t = (p t) |> Sexplib.Sexp.to_string_hum |> print_endline [@@ocaml.warning "-32"] +(* get a type Fold lhs or Unfold lhs by a type of lhs *) +let process_rec loc = function + | Fold lhs -> ( + match lhs with + Nil | Cons _ -> `IntList + | _ -> failwith @@ Printf.sprintf "Cannot fold types that is neither Nil nor Cons at %s" @@ Locations.string_of_location loc + ) + | Unfold lhs -> ( + match lhs with + Nil -> `Nil + | Cons _ -> `Cons (`Int, `IntList) + | _ -> failwith @@ Printf.sprintf "Cannot unfold types that is neither Nil nor Cons at %s" @@ Locations.string_of_location loc + ) + | _ -> failwith @@ Printf.sprintf "Cannot fold or unfold types that is not recursive types at %s" @@ Locations.string_of_location loc + let rec process_expr ret_type ctxt ((id,loc),e) res_acc = let resolv = function | `Var v -> `Var (UnionFind.find ctxt.sub.uf v) @@ -532,8 +553,10 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = let cont = fresh_var () in unify_var b @@ `Array cont; same cont - | Cons _ -> assert false; - | Nil -> assert false; + | Cons _ -> assert false + | Nil -> assert false + | Fold _ -> assert false + | Unfold _ -> assert false in let rec unify_patt acc p t = match p with From 5d74cdb34ea94226aedce1ec405910cb66d543ef Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 18 May 2023 16:16:06 +0900 Subject: [PATCH 015/108] fix error --- src/simpleChecker.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/simpleChecker.ml b/src/simpleChecker.ml index defb792e..09b84973 100644 --- a/src/simpleChecker.ml +++ b/src/simpleChecker.ml @@ -363,19 +363,19 @@ let dump_sexp p t = [@@ocaml.warning "-32"] (* get a type Fold lhs or Unfold lhs by a type of lhs *) -let process_rec loc = function +let process_rec ~loc = function | Fold lhs -> ( match lhs with Nil | Cons _ -> `IntList - | _ -> failwith @@ Printf.sprintf "Cannot fold types that is neither Nil nor Cons at %s" @@ Locations.string_of_location loc + | _ -> Locations.raise_errorf ~loc "Cannot fold types that is neither Nil nor Cons" ) | Unfold lhs -> ( match lhs with Nil -> `Nil | Cons _ -> `Cons (`Int, `IntList) - | _ -> failwith @@ Printf.sprintf "Cannot unfold types that is neither Nil nor Cons at %s" @@ Locations.string_of_location loc + | _ -> Locations.raise_errorf ~loc "Cannot unfold types that is neither Nil nor Cons" ) - | _ -> failwith @@ Printf.sprintf "Cannot fold or unfold types that is not recursive types at %s" @@ Locations.string_of_location loc + | _ -> Locations.raise_errorf ~loc "Cannot fold or unfold types that is not recursive types" let rec process_expr ret_type ctxt ((id,loc),e) res_acc = let resolv = function From 1c916cb040d92767ce9612ab639d6ff558d92677 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 18 May 2023 17:32:42 +0900 Subject: [PATCH 016/108] wip --- src/ast.ml | 2 +- src/parser.mly | 4 ++-- src/simpleChecker.ml | 13 ++++++++----- src/surfaceAst.ml | 10 ++++------ 4 files changed, 15 insertions(+), 14 deletions(-) diff --git a/src/ast.ml b/src/ast.ml index 953c151a..bc8e9955 100644 --- a/src/ast.ml +++ b/src/ast.ml @@ -32,7 +32,7 @@ type lhs = | Nil | Cons of lhs * lhs | Fold of lhs - | Unfold of lhs [@@deriving sexp] + | Unfold of string [@@deriving sexp] type patt = | PVar of string diff --git a/src/parser.mly b/src/parser.mly index 7d771143..5531804e 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -107,8 +107,8 @@ let expr := | RETURN; lbl = expr_label; e = lhs; { Return ((lbl,$startpos),e) } - | MATCH; lbl = expr_label; e1 = lhs; WITH; NIL; ARROW; e2 = expr; BAR; CONS; h = ID; r = ID; ARROW; e3 = expr; { - Match ((lbl,$startpos),e1,e2,h,r,e3) + | MATCH; lbl = expr_label; id = ID; WITH; NIL; ARROW; e1 = expr; BAR; CONS; h = ID; r = ID; ARROW; e2 = expr; { + Match ((lbl,$startpos),id,e1,h,r,e2) } let ap := diff --git a/src/simpleChecker.ml b/src/simpleChecker.ml index 09b84973..268eb015 100644 --- a/src/simpleChecker.ml +++ b/src/simpleChecker.ml @@ -371,6 +371,7 @@ let process_rec ~loc = function ) | Unfold lhs -> ( match lhs with + (* TODO: How can we get a value or unfolded type of lhs? *) Nil -> `Nil | Cons _ -> `Cons (`Int, `IntList) | _ -> Locations.raise_errorf ~loc "Cannot unfold types that is neither Nil nor Cons" @@ -553,10 +554,10 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = let cont = fresh_var () in unify_var b @@ `Array cont; same cont - | Cons _ -> assert false - | Nil -> assert false - | Fold _ -> assert false - | Unfold _ -> assert false + | Fold l -> same @@ process_rec ~loc l + | Cons _ -> Locations.raise_errorf ~loc "No Cons will come here, Cons should be wrapped in Fold" + | Nil -> Locations.raise_errorf ~loc "No Nil will come here, Nil should be wrapped in Fold" + | Unfold _ -> Locations.raise_errorf ~loc "No Unfold will come here" in let rec unify_patt acc p t = match p with @@ -580,7 +581,9 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = unify t ty; res_acc,true end - | Match (_, _, _, _, _) -> assert false + | Match (e1, e2, h, r, e3) -> + unify e1 @@ process_rec ~loc e1; + let constrain_fn sub fenv acc ({ name; body; _ } as fn) = let tyenv = init_tyenv fenv fn in diff --git a/src/surfaceAst.ml b/src/surfaceAst.ml index f5b1a0c3..f860a168 100644 --- a/src/surfaceAst.ml +++ b/src/surfaceAst.ml @@ -65,7 +65,7 @@ type exp = | Assert of pos * relation | Seq of Lexing.position * exp * exp | Return of pos * lhs - | Match of pos * lhs * exp * string * string * exp + | Match of pos * string * exp * string * string * exp type fn = string * string list * exp type prog = fn list * exp @@ -188,11 +188,9 @@ let rec simplify_expr ?next ~is_tail count e : pos * A.raw_exp = lift_to_var ~ctxt:i count rval (fun _ tvar -> A.Return tvar |> tag_with i ) - | Match (i, e1, e2, h, r, e3) -> - lift_to_lhs ~ctxt:i count e1 (fun c e1' -> - A.Match (A.Unfold e1', simplify_expr ~is_tail c e2, h, r, simplify_expr ~is_tail c e3) - |> tag_with i - ) + | Match (i, id, e1, h, r, e2) -> + A.Match (A.Unfold id, simplify_expr ~is_tail count e1, h, r, simplify_expr ~is_tail count e2) + |> tag_with i and lift_to_lhs ~ctxt count (lhs : lhs) (rest: int -> A.lhs -> A.exp) = let k r = rest count r in From 7a13d0630949b35ebc70bbf086f3054d79fefcf4 Mon Sep 17 00:00:00 2001 From: artoy Date: Sun, 21 May 2023 15:18:08 +0900 Subject: [PATCH 017/108] fix match statement --- src/parser.mly | 4 ++-- src/simpleChecker.ml | 4 ---- src/surfaceAst.ml | 10 ++++++---- 3 files changed, 8 insertions(+), 10 deletions(-) diff --git a/src/parser.mly b/src/parser.mly index 5531804e..7d771143 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -107,8 +107,8 @@ let expr := | RETURN; lbl = expr_label; e = lhs; { Return ((lbl,$startpos),e) } - | MATCH; lbl = expr_label; id = ID; WITH; NIL; ARROW; e1 = expr; BAR; CONS; h = ID; r = ID; ARROW; e2 = expr; { - Match ((lbl,$startpos),id,e1,h,r,e2) + | MATCH; lbl = expr_label; e1 = lhs; WITH; NIL; ARROW; e2 = expr; BAR; CONS; h = ID; r = ID; ARROW; e3 = expr; { + Match ((lbl,$startpos),e1,e2,h,r,e3) } let ap := diff --git a/src/simpleChecker.ml b/src/simpleChecker.ml index 268eb015..8cf985cc 100644 --- a/src/simpleChecker.ml +++ b/src/simpleChecker.ml @@ -66,13 +66,11 @@ type 'a c_typ = [ | `Tuple of 'a list | `Array of 'a | `IntList - | `Nil ] [@@deriving sexp] type typ = [ typ c_typ | `Var of int -| `Cons of typ * typ ] [@@deriving sexp] type refined_typ = typ c_typ @@ -205,9 +203,7 @@ let rec occurs_check sub v (t2: typ) = | `Var v' when v' = v -> failwith "Malformed recursive type" | `Tuple tl -> List.iter (occurs_check sub v) tl | `Array t' -> occurs_check sub v t' - | `Cons (x, y) -> occurs_check sub v x; occurs_check sub v y | `IntList - | `Nil | `Var _ | `Int (* Notice that we do not check reference contents for recursion. Recursion under a reference constructor is fine *) diff --git a/src/surfaceAst.ml b/src/surfaceAst.ml index f860a168..fbdc236c 100644 --- a/src/surfaceAst.ml +++ b/src/surfaceAst.ml @@ -65,7 +65,7 @@ type exp = | Assert of pos * relation | Seq of Lexing.position * exp * exp | Return of pos * lhs - | Match of pos * string * exp * string * string * exp + | Match of pos * lhs * exp * string * string * exp type fn = string * string list * exp type prog = fn list * exp @@ -188,9 +188,11 @@ let rec simplify_expr ?next ~is_tail count e : pos * A.raw_exp = lift_to_var ~ctxt:i count rval (fun _ tvar -> A.Return tvar |> tag_with i ) - | Match (i, id, e1, h, r, e2) -> - A.Match (A.Unfold id, simplify_expr ~is_tail count e1, h, r, simplify_expr ~is_tail count e2) - |> tag_with i + | Match (i, e1, e2, h, r, e3) -> + lift_to_lhs ~ctxt:i count e1 (fun c e1' -> + A.Match (e1', simplify_expr ~is_tail c e2, h, r, simplify_expr ~is_tail c e3) + |> tag_with i + ) and lift_to_lhs ~ctxt count (lhs : lhs) (rest: int -> A.lhs -> A.exp) = let k r = rest count r in From 4419afdc91913281a1d1333ac128d15daf8df49d Mon Sep 17 00:00:00 2001 From: artoy Date: Sun, 21 May 2023 17:08:18 +0900 Subject: [PATCH 018/108] complete simple type check of list and match --- src/ast.ml | 4 +--- src/simpleChecker.ml | 34 ++++++++++++---------------------- src/surfaceAst.ml | 5 ++--- 3 files changed, 15 insertions(+), 28 deletions(-) diff --git a/src/ast.ml b/src/ast.ml index bc8e9955..8d7303e4 100644 --- a/src/ast.ml +++ b/src/ast.ml @@ -30,9 +30,7 @@ type lhs = | LengthOf of string | Null | Nil - | Cons of lhs * lhs - | Fold of lhs - | Unfold of string [@@deriving sexp] + | Cons of lhs * lhs [@@deriving sexp] type patt = | PVar of string diff --git a/src/simpleChecker.ml b/src/simpleChecker.ml index 8cf985cc..5e5dc1d7 100644 --- a/src/simpleChecker.ml +++ b/src/simpleChecker.ml @@ -358,22 +358,6 @@ let dump_sexp p t = (p t) |> Sexplib.Sexp.to_string_hum |> print_endline [@@ocaml.warning "-32"] -(* get a type Fold lhs or Unfold lhs by a type of lhs *) -let process_rec ~loc = function - | Fold lhs -> ( - match lhs with - Nil | Cons _ -> `IntList - | _ -> Locations.raise_errorf ~loc "Cannot fold types that is neither Nil nor Cons" - ) - | Unfold lhs -> ( - match lhs with - (* TODO: How can we get a value or unfolded type of lhs? *) - Nil -> `Nil - | Cons _ -> `Cons (`Int, `IntList) - | _ -> Locations.raise_errorf ~loc "Cannot unfold types that is neither Nil nor Cons" - ) - | _ -> Locations.raise_errorf ~loc "Cannot fold or unfold types that is not recursive types" - let rec process_expr ret_type ctxt ((id,loc),e) res_acc = let resolv = function | `Var v -> `Var (UnionFind.find ctxt.sub.uf v) @@ -550,10 +534,9 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = let cont = fresh_var () in unify_var b @@ `Array cont; same cont - | Fold l -> same @@ process_rec ~loc l - | Cons _ -> Locations.raise_errorf ~loc "No Cons will come here, Cons should be wrapped in Fold" - | Nil -> Locations.raise_errorf ~loc "No Nil will come here, Nil should be wrapped in Fold" - | Unfold _ -> Locations.raise_errorf ~loc "No Unfold will come here" + (* Types of Cons and Nil is "folded" so they are handled as IntList, simply *) + | Cons _ -> same `IntList + | Nil -> same `IntList in let rec unify_patt acc p t = match p with @@ -578,8 +561,15 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = res_acc,true end | Match (e1, e2, h, r, e3) -> - unify e1 @@ process_rec ~loc e1; - + let v1 = + match e1 with + Var v -> v + | _ -> Locations.raise_errorf ~loc "Not implemented" + in + unify_var v1 `IntList; + (* No need a constraint to be the return type of e2 and e3 are the same because they share the "ret_type". *) + process_expr ret_type ctxt e2 res_acc + |&| process_expr ret_type (add_var h `Int (add_var r `IntList ctxt)) e3 let constrain_fn sub fenv acc ({ name; body; _ } as fn) = let tyenv = init_tyenv fenv fn in diff --git a/src/surfaceAst.ml b/src/surfaceAst.ml index fbdc236c..136ed339 100644 --- a/src/surfaceAst.ml +++ b/src/surfaceAst.ml @@ -234,10 +234,9 @@ and lift_to_lhs ~ctxt count (lhs : lhs) (rest: int -> A.lhs -> A.exp) = | `OBool f -> k @@ A.Const (if f then 0 else 1) | `Cons (h, r) -> lift_to_lhs ~ctxt count h (fun c h' -> lift_to_lhs ~ctxt c r (fun c' r' -> - rest c' @@ A.Fold (A.Cons (h', r')) + rest c' @@ A.Cons (h', r')) ) - ) - | `Nil -> k @@ A.Fold A.Nil + | `Nil -> k @@ A.Nil and lift_to_rinit ~ctxt count (r: lhs) rest = let k = rest count in From 46d8599b9ab140bdddfab4e9e21c2a4c62bfc697 Mon Sep 17 00:00:00 2001 From: artoy Date: Mon, 22 May 2023 11:33:06 +0900 Subject: [PATCH 019/108] some fix --- src/ownershipInference.ml | 9 +++++++++ src/simpleChecker.ml | 8 ++++++++ src/simpleTypes.ml | 3 +++ src/simpleTypes.mli | 1 + 4 files changed, 21 insertions(+) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index df8c380b..b584ed35 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -35,6 +35,7 @@ type 'a otype_ = | Tuple of 'a otype_ list | TVar of int | Mu of int * 'a otype_ + | IntList type otype = ownership otype_ @@ -142,6 +143,7 @@ let unfold = | Array (t,o) -> Array (subst_once id sub t,o) | Tuple tl -> Tuple (List.map (subst_once id sub) tl) | Mu (id',t) -> assert (id' <> id); Mu (id',subst_once id sub t) + | IntList -> assert false in let rec unfold_loop ~unfld = function | TVar id -> assert (IntSet.mem id unfld); TVar id @@ -155,6 +157,7 @@ let unfold = | (Mu (id,t)) as mu -> let t' = subst_once id mu t in unfold_loop ~unfld:(IntSet.add id unfld) t' + | IntList -> assert false in unfold_loop ~unfld:IntSet.empty @@ -250,6 +253,7 @@ let rec constrain_wf_loop o t ctxt = constrain_wf_loop o' t' { ctxt with ocons = Wf (o,o')::ctxt.ocons } + | IntList -> assert false (** Like constrain_wf_above, but only begin emitting wf constraints when the first ownership variable is encountered *) @@ -260,6 +264,7 @@ let rec constrain_well_formed = function | Mu (_,t) -> constrain_well_formed t | Ref (t,o) | Array (t,o) -> constrain_wf_loop o t + | IntList -> assert false (** Record the allocation of an ownership variable in the context of a magic operation. Updates the gen map *) @@ -336,6 +341,7 @@ let lift_to_ownership loc root t_simp = simple_lift ~unfld (P.t_ind root i) t ) tl in return @@ Tuple tl' + | `IntList -> assert false in let%bind t = simple_lift ~unfld:IntSet.empty root t_simp in constrain_well_formed t >> return t @@ -366,6 +372,7 @@ let make_fresh_type loc root t = | Mu (id,t) -> let%bind t' = loop root t in return @@ Mu (id,t') + | IntList -> assert false in let%bind t' = loop root t in constrain_well_formed t' >> return t' @@ -474,6 +481,7 @@ let rec split_type loc p = return @@ (Tuple tl1,Tuple tl2) | Ref (t,o) -> split_mem o t P.deref tref | Array (t,o) -> split_mem o t P.elem tarray + | IntList -> assert false (** Constrain to types to be pointwse constrained by the generator rel, which @@ -558,6 +566,7 @@ let rec max_type = function miter max_type tl | Ref (t,o) -> max_ovar o >> max_type t + | IntList -> assert false let process_call e_id c = let%bind arg_types = mmap (lkp_split @@ SCall e_id) c.arg_names diff --git a/src/simpleChecker.ml b/src/simpleChecker.ml index 5e5dc1d7..2f785f3e 100644 --- a/src/simpleChecker.ml +++ b/src/simpleChecker.ml @@ -57,6 +57,7 @@ let rec string_of_typ = function | `Int -> "int" | `Tuple pl -> Printf.sprintf "(%s)" @@ String.concat ", " @@ List.map string_of_typ pl | `Array t' -> Printf.sprintf "[%s]" @@ string_of_typ t' + | `IntList -> "int list" [@@ocaml.warning "-32"] @@ -165,6 +166,7 @@ let abstract_type sub_ctxt t = | `Tuple tl -> `Tuple (List.map loop tl |> List.map [%cast: typ]) | `Array t -> `Array ((loop (t :> SimpleTypes.r_typ)) :> typ) + | `IntList -> `IntList in loop t @@ -254,6 +256,7 @@ let rec unify ~loc sub_ctxt t1 t2 = unify_tycons ~loc sub_ctxt c1 c2 | `Array t1',`Array t2' -> unify ~loc sub_ctxt t1' t2' + | `IntList,`IntList -> () | t1',t2' -> raise_ill_typed_error t1' t2' and unify_tycons ~loc sub_ctxt c1 c2 = @@ -293,6 +296,7 @@ module IS = Std.IntSet appears in this set, instead of resolving the reference contents, the continuation is immediately invoked with arguments {i} (tvar i); i.e., reference i is recursive. *) +(* If this function is to resolve recursive types, you can omit this step by proposing fold/unfold *) let rec resolve_with_rec sub v_set k t = match canonicalize sub t with | `Int -> k IS.empty `Int @@ -330,6 +334,7 @@ let rec resolve_with_rec sub v_set k t = | `Int -> k is @@ `Array `Int | _ -> failwith "Only integer arrays are supported" ) t' + | `IntList -> k IS.empty `IntList let process_call ~loc lkp ctxt { callee; arg_names; _ } = let sorted_args = List.fast_sort String.compare arg_names in @@ -583,6 +588,7 @@ requires a fold or unfold. Simply put, we walk the assigned type, and see if (the canonical representation of) c appears anywhere in t'. If it does, this is a folding or unfolding assignment/read. *) +(* If this function is to resolve recursive types, you can omit this step by proposing fold/unfold *) let is_rec_assign sub c t' = let canon_c = TyConsUF.find sub.cons_uf c in let rec check_loop h_rec t = @@ -603,9 +609,11 @@ let is_rec_assign sub c t' = | `Tuple tl -> List.exists (check_loop h_rec) tl | `Array t' -> check_loop h_rec t' + | `IntList -> false in check_loop IS.empty t' +(* If this function is to resolve recursive types, you can omit this step by proposing fold/unfold *) let get_rec_loc sub p_ops = List.fold_left (fun acc (i,c,t') -> if is_rec_assign sub c t' then diff --git a/src/simpleTypes.ml b/src/simpleTypes.ml index cd5bc53e..edc27a4b 100644 --- a/src/simpleTypes.ml +++ b/src/simpleTypes.ml @@ -7,6 +7,7 @@ type r_typ = [ | `Ref of r_typ | `Mu of int * r_typ | `Array of a_typ + | `IntList ] and a_typ = [ `Int ] [@@deriving sexp] @@ -24,6 +25,7 @@ let unfold_simple_type i t = | `Tuple tl -> `Tuple (List.map loop tl) | `Ref t -> `Ref (loop t) | `Array `Int -> `Array `Int + | `IntList -> `IntList | `TVar _ | `Mu (_,_) -> failwith "Malformed recursive type" in @@ -36,6 +38,7 @@ let rec type_to_string = function | `Mu (v,t) -> Printf.sprintf "(%s '%d.%s)" Greek.mu v @@ type_to_string t | `TVar v -> Printf.sprintf "'%d" v | `Array at -> Printf.sprintf "[%s]" @@ array_type_to_string at + | `IntList -> "int list" and array_type_to_string = function | `Int -> "int" diff --git a/src/simpleTypes.mli b/src/simpleTypes.mli index 4ee00515..e77a2763 100644 --- a/src/simpleTypes.mli +++ b/src/simpleTypes.mli @@ -5,6 +5,7 @@ type r_typ = [ | `Ref of r_typ | `Mu of int * r_typ | `Array of a_typ + | `IntList ] and a_typ = [ `Int ][@@deriving sexp] type 'a _funtyp = { From 979bad4fe69233414e0676c6c1bec2cbc19330d6 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 22 May 2023 13:12:08 +0900 Subject: [PATCH 020/108] fix --- src/ownershipInference.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index b584ed35..5877bfb2 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -236,6 +236,7 @@ let rec unfold_simple arg mu = | `Array `Int -> `Array `Int | `Tuple tl_list -> `Tuple (List.map (unfold_simple arg mu) tl_list) | `Mu (id,t) -> `Mu (id, unfold_simple arg mu t) + | `IntList -> assert false (** Walk a type, constraining the first occurrence of an ownership variable to be well-formed w.r.t [o]. From 2225a4f4424ab9eb1282f91c8807beb21572ccef Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 22 May 2023 13:33:41 +0900 Subject: [PATCH 021/108] complete simple type checking and fix test --- src/consort.ml | 2 ++ src/flowInference.ml | 1 + src/test/list/cons.imp | 2 +- src/test/list/match.imp | 4 ++-- src/test/list/nil.imp | 2 +- 5 files changed, 7 insertions(+), 4 deletions(-) diff --git a/src/consort.ml b/src/consort.ml index a0ada1b2..ea5f73c2 100644 --- a/src/consort.ml +++ b/src/consort.ml @@ -82,6 +82,8 @@ let print_program ~o_map ~o_printer r ast = (ul print_type) t | TVar id -> pf "'%d" id + | IntList -> + ps "int list" in let print_type_binding (k, t) = pb [pf "%s: " k; print_type t] in let print_type_sep t = List.map print_type t |> psep_gen (pf ",@ ") in diff --git a/src/flowInference.ml b/src/flowInference.ml index cb36f44b..cd152549 100644 --- a/src/flowInference.ml +++ b/src/flowInference.ml @@ -243,6 +243,7 @@ let rec simple_to_fltype ?tvar = function assert (Option.map ((=) id) tvar |> Option.value ~default:false); `TVar | `Tuple tl -> `Tuple (List.map (simple_to_fltype ?tvar) tl) + | `IntList -> assert false let%lq get_function_type f_name ctxt = let { f_type; _ } = StringMap.find f_name ctxt.fenv in diff --git a/src/test/list/cons.imp b/src/test/list/cons.imp index 38defab4..7557ecd9 100644 --- a/src/test/list/cons.imp +++ b/src/test/list/cons.imp @@ -1,5 +1,5 @@ { let x = Cons 1 Nil in let y = Cons 1 (Cons 2 (Cons 3 Nil)) in - assert(y = Cons 1 (Cons 2 (Cons 3 Nil))) + () } \ No newline at end of file diff --git a/src/test/list/match.imp b/src/test/list/match.imp index a4e7cacb..c76a2052 100644 --- a/src/test/list/match.imp +++ b/src/test/list/match.imp @@ -2,8 +2,8 @@ sum(l, s) { match l with Nil -> s | Cons h r -> { - let s = s + h in - sum(r, s) + let s2 = s + h in + sum(r, s2) } } diff --git a/src/test/list/nil.imp b/src/test/list/nil.imp index 613912a0..c45099be 100644 --- a/src/test/list/nil.imp +++ b/src/test/list/nil.imp @@ -1,4 +1,4 @@ { let x = Nil in - assert(x = Nil) + () } \ No newline at end of file From d723acc447be12d3c71a4d49acb022003701df87 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 22 May 2023 17:28:07 +0900 Subject: [PATCH 022/108] handle IntList (WIP) --- src/ownershipInference.ml | 6 +++--- src/simpleChecker.ml | 3 ++- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 5877bfb2..3c88ed16 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -342,7 +342,7 @@ let lift_to_ownership loc root t_simp = simple_lift ~unfld (P.t_ind root i) t ) tl in return @@ Tuple tl' - | `IntList -> assert false + | `IntList -> return IntList in let%bind t = simple_lift ~unfld:IntSet.empty root t_simp in constrain_well_formed t >> return t @@ -727,8 +727,8 @@ let rec process_expr ~output ((e_id,_),expr) = ) t_init in return @@ Tuple tl | Call c -> process_call e_id c - | Cons _ -> assert false - | Nil -> assert false + | Cons _ + | Nil -> return IntList in let rec assign_patt_loop acc patt ty = match patt,ty with diff --git a/src/simpleChecker.ml b/src/simpleChecker.ml index 2f785f3e..aa5d4c0e 100644 --- a/src/simpleChecker.ml +++ b/src/simpleChecker.ml @@ -540,7 +540,7 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = unify_var b @@ `Array cont; same cont (* Types of Cons and Nil is "folded" so they are handled as IntList, simply *) - | Cons _ -> same `IntList + | Cons _ | Nil -> same `IntList in let rec unify_patt acc p t = @@ -574,6 +574,7 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = unify_var v1 `IntList; (* No need a constraint to be the return type of e2 and e3 are the same because they share the "ret_type". *) process_expr ret_type ctxt e2 res_acc + (* Unfold an IntList type to a pair of Int and IntList type. *) |&| process_expr ret_type (add_var h `Int (add_var r `IntList ctxt)) e3 let constrain_fn sub fenv acc ({ name; body; _ } as fn) = From 0cbea1c0a490b792b7b257af7c634ce07d6c965b Mon Sep 17 00:00:00 2001 From: artoy Date: Wed, 24 May 2023 17:01:25 +0900 Subject: [PATCH 023/108] print variables and their types binded in match --- src/astPrinter.ml | 6 +++--- src/consort.ml | 7 ++++++- src/simpleChecker.ml | 26 ++++++++++++++++++-------- src/simpleChecker.mli | 3 ++- 4 files changed, 29 insertions(+), 13 deletions(-) diff --git a/src/astPrinter.ml b/src/astPrinter.ml index 4da7b998..dbdcd779 100644 --- a/src/astPrinter.ml +++ b/src/astPrinter.ml @@ -172,11 +172,11 @@ let rec pp_expr ~ip:((po_id,pr_id) as ip) ~annot (id,e) = | Fail -> ps "fail" | Match (e1, e2, h, r, e3) -> pl [ - pf "match %a with" (ul pp_lhs) e1; - pf "| Nil -> {"; + pf "match %a with " (ul pp_lhs) e1; + pf "| Nil -> { "; pp_expr ~ip ~annot e2; ps "}"; - pf "| Cons(%s,%s) -> {" h r; + pf "| Cons(%s,%s) -> { " h r; pp_expr ~ip ~annot e3; ps "}"; ] diff --git a/src/consort.ml b/src/consort.ml index ea5f73c2..edd87296 100644 --- a/src/consort.ml +++ b/src/consort.ml @@ -166,7 +166,12 @@ let print_typecheck (f_types, side) ast = let annot (id, _) e = match Std.IntMap.find_opt id side.let_types, e with | Some ty, Let (patt, _, _) -> from_ty_patt ty patt - | _ -> null in + | _ -> ( + match Std.IntMap.find_opt id side.match_bindings, e with + | Some l, Match _ -> pl [ps "/* "; pl @@ List.map (fun (v, t) -> pf "%s: %s; " v @@ type_to_string t) l; ps "*/"; newline] + | _ -> null + ) + in AstPrinter.pretty_print_program ~annot_fn ~annot stdout ast let to_hint o_res record = diff --git a/src/simpleChecker.ml b/src/simpleChecker.ml index aa5d4c0e..047050e5 100644 --- a/src/simpleChecker.ml +++ b/src/simpleChecker.ml @@ -129,13 +129,15 @@ type side_results = { deref_locs: ptr_op list; let_types: typ Std.IntMap.t; (* let_types gives the type of the RHS of every let expression (by id). This is used to know what type to give a null constant *) + match_bindings: (string * typ) list Std.IntMap.t; (* match_binded gives binding information in match statement *) } module SideAnalysis = struct type results = { unfold_locs: Std.IntSet.t; fold_locs: Std.IntSet.t; - let_types: SimpleTypes.r_typ Std.IntMap.t + let_types: SimpleTypes.r_typ Std.IntMap.t; + match_bindings: (string * SimpleTypes.r_typ) list Std.IntMap.t; } end @@ -407,6 +409,9 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = let save_let ty acc = { acc with let_types = Std.IntMap.add id ty acc.let_types } in + let save_match_binding list acc = + { acc with match_bindings = Std.IntMap.add id list acc.match_bindings } + in let (|&|) (a,r1) b = let (a',r2) = b a in a',(r1 && r2) @@ -539,7 +544,6 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = let cont = fresh_var () in unify_var b @@ `Array cont; same cont - (* Types of Cons and Nil is "folded" so they are handled as IntList, simply *) | Cons _ | Nil -> same `IntList in @@ -573,9 +577,9 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = in unify_var v1 `IntList; (* No need a constraint to be the return type of e2 and e3 are the same because they share the "ret_type". *) - process_expr ret_type ctxt e2 res_acc - (* Unfold an IntList type to a pair of Int and IntList type. *) - |&| process_expr ret_type (add_var h `Int (add_var r `IntList ctxt)) e3 + let acc1, b1 = process_expr ret_type ctxt e2 res_acc in + let acc2, b2 = process_expr ret_type (add_var h `Int (add_var r `IntList ctxt)) e3 @@ save_match_binding [(h, `Int); (r, `IntList)] acc1 in + acc2, b1 && b2 let constrain_fn sub fenv acc ({ name; body; _ } as fn) = let tyenv = init_tyenv fenv fn in @@ -649,7 +653,8 @@ let typecheck_prog intr_types (fns,body) = t_cons = []; assign_locs = []; deref_locs = []; - let_types = Std.IntMap.empty + let_types = Std.IntMap.empty; + match_bindings = Std.IntMap.empty; } fns in let (acc',_) = process_expr None { @@ -676,8 +681,12 @@ let typecheck_prog intr_types (fns,body) = l' in let fold_locs = distinct_list_to_set @@ get_rec_loc sub acc'.assign_locs in - let unfold_locs = distinct_list_to_set @@ get_rec_loc sub acc'.deref_locs in + let unfold_locs = distinct_list_to_set @@ get_rec_loc sub acc'.deref_locs in let get_soln = resolve_with_rec sub IS.empty (fun _ t -> t) in + let rec get_soln_with_var_name = function + | [] -> [] + | (var, ty) :: r -> (var, get_soln ty) :: get_soln_with_var_name r + in (List.fold_left (fun acc { name; _ } -> let { arg_types_v; ret_type_v } = StringMap.find name fenv in let arg_types = List.map get_soln @@ List.map (fun x -> `Var x) arg_types_v in @@ -686,5 +695,6 @@ let typecheck_prog intr_types (fns,body) = ) StringMap.empty fns),SideAnalysis.( { unfold_locs; fold_locs; - let_types = Std.IntMap.map get_soln acc'.let_types + let_types = Std.IntMap.map get_soln acc'.let_types; + match_bindings = Std.IntMap.map get_soln_with_var_name acc'.match_bindings; }) diff --git a/src/simpleChecker.mli b/src/simpleChecker.mli index 48394512..3a21431c 100644 --- a/src/simpleChecker.mli +++ b/src/simpleChecker.mli @@ -3,7 +3,8 @@ module SideAnalysis: sig type results = { unfold_locs: Std.IntSet.t; fold_locs: Std.IntSet.t; - let_types: SimpleTypes.r_typ Std.IntMap.t + let_types: SimpleTypes.r_typ Std.IntMap.t; + match_bindings: (string * SimpleTypes.r_typ) list Std.IntMap.t; } end From 0fbd1a6c1f4ea848eb492d38c87f4a2c7aa0f813 Mon Sep 17 00:00:00 2001 From: artoy Date: Wed, 24 May 2023 17:06:29 +0900 Subject: [PATCH 024/108] fix print --- src/astPrinter.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/astPrinter.ml b/src/astPrinter.ml index dbdcd779..d35f5a09 100644 --- a/src/astPrinter.ml +++ b/src/astPrinter.ml @@ -173,9 +173,9 @@ let rec pp_expr ~ip:((po_id,pr_id) as ip) ~annot (id,e) = | Match (e1, e2, h, r, e3) -> pl [ pf "match %a with " (ul pp_lhs) e1; - pf "| Nil -> { "; + pf "Nil -> { "; pp_expr ~ip ~annot e2; - ps "}"; + ps " } "; pf "| Cons(%s,%s) -> { " h r; pp_expr ~ip ~annot e3; ps "}"; From 589bcdbd3ab31bbd930d83c0b3ff748f434d1c10 Mon Sep 17 00:00:00 2001 From: artoy Date: Thu, 25 May 2023 18:20:54 +0900 Subject: [PATCH 025/108] update test for linked list --- src/test/list/cons.imp | 5 +++-- src/test/list/match.imp | 8 ++++++-- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/src/test/list/cons.imp b/src/test/list/cons.imp index 7557ecd9..0b96548b 100644 --- a/src/test/list/cons.imp +++ b/src/test/list/cons.imp @@ -1,5 +1,6 @@ { - let x = Cons 1 Nil in - let y = Cons 1 (Cons 2 (Cons 3 Nil)) in + let x = mkref Nil in + let y = mkref (Cons 1 x) in + let z = mkref (Cons 2 y) in () } \ No newline at end of file diff --git a/src/test/list/match.imp b/src/test/list/match.imp index c76a2052..cc64ac75 100644 --- a/src/test/list/match.imp +++ b/src/test/list/match.imp @@ -3,12 +3,16 @@ sum(l, s) { Nil -> s | Cons h r -> { let s2 = s + h in - sum(r, s2) + let r2 = *r in + sum(r2, s2) } } { - let l = Cons 1 (Cons 2 (Cons 3 Nil)) in + let x = mkref Nil in + let y = mkref (Cons 1 x) in + let z = mkref (Cons 2 y) in + let l = mkref (Cons 3 z) in let s = sum(l, 0) in assert(s = 6) } \ No newline at end of file From 3021ea6c0151a251ae9183a506e10d11a2da27bb Mon Sep 17 00:00:00 2001 From: artoy Date: Sun, 28 May 2023 23:43:23 +0900 Subject: [PATCH 026/108] change TyCons to Ref (WIP) --- src/simpleChecker.ml | 78 +++++--------------------------------------- src/simpleTypes.ml | 5 +-- 2 files changed, 9 insertions(+), 74 deletions(-) diff --git a/src/simpleChecker.ml b/src/simpleChecker.ml index 047050e5..c30004b5 100644 --- a/src/simpleChecker.ml +++ b/src/simpleChecker.ml @@ -27,33 +27,9 @@ type funtyp_v = { ret_type_v: int } -module TyCons : sig - type t[@@immediate][@@deriving sexp] - val equal : t -> t -> bool - val hash : t -> int - val fresh : unit -> t - val to_string : t -> string - val unwrap : t -> int - val weight : t -> int -end = struct - type t = int [@@deriving sexp] - let _ref = ref 0;; - - let equal = (=) - let hash i = i - let fresh () = - let i = !_ref in - incr _ref; - i - - let to_string = string_of_int - let unwrap i = i - let weight = unwrap -end - let rec string_of_typ = function | `Var i -> Printf.sprintf "'%d" i - | `TyCons t -> Printf.sprintf "$%s" @@ TyCons.to_string t + | `Ref t -> Printf.sprintf "ref %s" @@ string_of_typ t | `Int -> "int" | `Tuple pl -> Printf.sprintf "(%s)" @@ String.concat ", " @@ List.map string_of_typ pl | `Array t' -> Printf.sprintf "[%s]" @@ string_of_typ t' @@ -63,7 +39,7 @@ let rec string_of_typ = function type 'a c_typ = [ | `Int - | `TyCons of TyCons.t + | `Ref of 'a | `Tuple of 'a list | `Array of 'a | `IntList @@ -76,10 +52,6 @@ type typ = [ type refined_typ = typ c_typ - -module TyConsUF = UnionFind.Make(TyCons) -module TyConsResolv = Hashtbl.Make(TyCons) - module SM = StringMap module StringSet = Std.StringSet @@ -108,9 +80,7 @@ type tuple_cons = {var: int; ind: int; unif: int; loc: Lexing.position} type sub_ctxt = { uf: UnionFind.t; - cons_uf: TyConsUF.t; resolv: resolv_map; - cons_arg: typ TyConsResolv.t; fn_name : string; } @@ -149,21 +119,12 @@ type fn_ctxt = { tyenv: tyenv; } -let fresh_cons_id sub_ctxt t = - let id = TyCons.fresh () in - TyConsResolv.add sub_ctxt.cons_arg id t; - TyConsUF.register sub_ctxt.cons_uf id; - id - -let fresh_cons sub_ctxt t = - `TyCons (fresh_cons_id sub_ctxt t) - (* Abstracts a simple type into an inference type (used to give types to instrinsics) *) let abstract_type sub_ctxt t = let rec loop = function | `TVar _ -> failwith "Not supported" | `Mu _ -> failwith "Not supported" - | `Ref t -> fresh_cons sub_ctxt ((loop t) : refined_typ :> typ) + | `Ref t -> `Ref (loop t) | `Int -> `Int | `Tuple tl -> `Tuple (List.map loop tl |> List.map [%cast: typ]) @@ -199,7 +160,6 @@ let add_var v t ctxt = (* For type variables or type constructors, find the representative id as recorded in the corresponding UF) *) let canonicalize sub = function | `Var v -> `Var (UnionFind.find sub.uf v) - | `TyCons v -> `TyCons (TyConsUF.find sub.cons_uf v) | t' -> t' let rec occurs_check sub v (t2: typ) = @@ -207,12 +167,12 @@ let rec occurs_check sub v (t2: typ) = | `Var v' when v' = v -> failwith "Malformed recursive type" | `Tuple tl -> List.iter (occurs_check sub v) tl | `Array t' -> occurs_check sub v t' + | `Ref t -> occurs_check sub v t | `IntList | `Var _ - | `Int + | `Int -> () (* Notice that we do not check reference contents for recursion. Recursion under a reference constructor is fine *) (* TODO: Probably, TyCons is going to be deleted *) - | `TyCons _ -> () let assign sub var t = occurs_check sub var (t :> typ); @@ -252,35 +212,13 @@ let rec unify ~loc sub_ctxt t1 t2 = raise_ill_typed_error t1' t2' else List.iter2 (unify ~loc sub_ctxt) tl1 tl2 - (* in this case, we now unify the two reference types, indirecting through that - union find/resolution map *) - | `TyCons c1,`TyCons c2 -> - unify_tycons ~loc sub_ctxt c1 c2 + | `Ref t1',`Ref t2' -> + unify ~loc sub_ctxt t1' t2' | `Array t1',`Array t2' -> unify ~loc sub_ctxt t1' t2' | `IntList,`IntList -> () | t1',t2' -> raise_ill_typed_error t1' t2' -and unify_tycons ~loc sub_ctxt c1 c2 = - let c1' = TyConsUF.find sub_ctxt.cons_uf c1 in - let c2' = TyConsUF.find sub_ctxt.cons_uf c2 in - (* If the two constructors are already unified to the same representative, - then we must have unified these references already, in which case we can stop, - we know the contents are equal *) - if TyCons.equal c1' c2' then - () - else - let a1 = TyConsResolv.find sub_ctxt.cons_arg c1' in - let a2 = TyConsResolv.find sub_ctxt.cons_arg c2' in - (* notice that we are unifying BEFORE recursing into the unification - of the reference contents. Effectively, this says: _under the assumption - constructors c1' and c2' are equivalent_, prove the contents of the - references are equivalent, i.e., a coinductive style proof. In other words, - while unifying the contents of c1' and c2', if we reach c1' and c2' we can halt - unification (as above) because we've assumed that they are already "equivalent". - *) - TyConsUF.union sub_ctxt.cons_uf c1' c2'; - unify ~loc sub_ctxt a1 a2 module IS = Std.IntSet @@ -378,7 +316,7 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = in let unify_var n typ = unify ~loc ctxt.sub (lkp n) typ in let unify_ref v t = - unify ~loc ctxt.sub (lkp v) @@ fresh_cons ctxt.sub t + unify ~loc ctxt.sub (lkp v) @@ t in let fresh_var () = let t = UnionFind.new_node ctxt.sub.uf in diff --git a/src/simpleTypes.ml b/src/simpleTypes.ml index edc27a4b..7f069a72 100644 --- a/src/simpleTypes.ml +++ b/src/simpleTypes.ml @@ -5,7 +5,6 @@ type r_typ = [ | `TVar of int | `Tuple of r_typ list | `Ref of r_typ - | `Mu of int * r_typ | `Array of a_typ | `IntList ] @@ -26,8 +25,7 @@ let unfold_simple_type i t = | `Ref t -> `Ref (loop t) | `Array `Int -> `Array `Int | `IntList -> `IntList - | `TVar _ - | `Mu (_,_) -> failwith "Malformed recursive type" + | `TVar _ -> failwith "Malformed recursive type" in loop t @@ -35,7 +33,6 @@ let rec type_to_string = function | `Int -> "int" | `Ref t -> Printf.sprintf "%s ref" @@ type_to_string t | `Tuple tl -> Printf.sprintf "(%s)" @@ String.concat ", " @@ List.map type_to_string tl - | `Mu (v,t) -> Printf.sprintf "(%s '%d.%s)" Greek.mu v @@ type_to_string t | `TVar v -> Printf.sprintf "'%d" v | `Array at -> Printf.sprintf "[%s]" @@ array_type_to_string at | `IntList -> "int list" From e1ca19332d127b73fae39bbc22fca7478bcdc6a6 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 29 May 2023 14:34:12 +0900 Subject: [PATCH 027/108] delete Mu (WIP) --- src/simpleChecker.ml | 178 +++++++++--------------------------------- src/simpleChecker.mli | 2 - src/simpleTypes.ml | 12 --- src/simpleTypes.mli | 2 - 4 files changed, 35 insertions(+), 159 deletions(-) diff --git a/src/simpleChecker.ml b/src/simpleChecker.ml index c30004b5..55c18aca 100644 --- a/src/simpleChecker.ml +++ b/src/simpleChecker.ml @@ -84,19 +84,10 @@ type sub_ctxt = { fn_name : string; } -(* A pointer op (ptr_op) (id,cons,t) represents a read or write from the reference associated - with the reference type cons. The type read or written is given by t, id is the expression - id of the expression. These ptr ops are analyzed later to flag expressions (by their id) that - require fold/unfolds (see is_rec_assign) -*) -type ptr_op = (int * TyCons.t * typ) - (* Results accumulated during type inference: the tuple constraints (explained above), the read and write pointer operations, and the let types *) type side_results = { t_cons: tuple_cons list; - assign_locs: ptr_op list; - deref_locs: ptr_op list; let_types: typ Std.IntMap.t; (* let_types gives the type of the RHS of every let expression (by id). This is used to know what type to give a null constant *) match_bindings: (string * typ) list Std.IntMap.t; (* match_binded gives binding information in match statement *) @@ -104,8 +95,6 @@ type side_results = { module SideAnalysis = struct type results = { - unfold_locs: Std.IntSet.t; - fold_locs: Std.IntSet.t; let_types: SimpleTypes.r_typ Std.IntMap.t; match_bindings: (string * SimpleTypes.r_typ) list Std.IntMap.t; } @@ -120,10 +109,9 @@ type fn_ctxt = { } (* Abstracts a simple type into an inference type (used to give types to instrinsics) *) -let abstract_type sub_ctxt t = +let abstract_type t = let rec loop = function | `TVar _ -> failwith "Not supported" - | `Mu _ -> failwith "Not supported" | `Ref t -> `Ref (loop t) | `Int -> `Int | `Tuple tl -> @@ -222,59 +210,33 @@ let rec unify ~loc sub_ctxt t1 t2 = module IS = Std.IntSet -(* translates a inference type into a fully concrete simple type. - Recursion is detected by means of the v_set and the continuation k. - - In general, k takes two arguments, a set of recursive ids (see below) and the - translated type. The set of recursive ids communicates to the caller any type constructors - which were found to be recursive during resolution. If the result of resolving the contents - of reference type constructor i returns a set containing i, then the reference should be wrapped in a recursive - mu binder (see the else branch of the TyCons case below). - - The argument v_set contains the (canonical) ids of all reference type constructors - being currently resolved. When resolving a type constructor with id i, if i - appears in this set, instead of resolving the reference contents, the continuation is immediately - invoked with arguments {i} (tvar i); i.e., reference i is recursive. -*) -(* If this function is to resolve recursive types, you can omit this step by proposing fold/unfold *) -let rec resolve_with_rec sub v_set k t = +(* translates a inference type into a fully concrete simple type. *) +let rec resolve sub k t = match canonicalize sub t with - | `Int -> k IS.empty `Int - | `TyCons t -> - let id = TyCons.unwrap t in - if IS.mem id v_set then - k (IS.singleton id) @@ `TVar id - else - let arg_type = TyConsResolv.find sub.cons_arg t in - resolve_with_rec sub (IS.add id v_set) (fun is t -> - if IS.mem id is then - k (IS.remove id is) @@ `Mu (id,`Ref t) - else - k is @@ `Ref t - ) arg_type + | `Int -> k `Int + | `Ref t -> k @@ `Ref t | `Tuple tl -> List.fold_left (fun k_acc t -> - (fun l is_acc -> - resolve_with_rec sub v_set (fun is t' -> - k_acc (t'::l) (IS.union is_acc is) - ) t - ) - ) - (fun l is -> - k is @@ `Tuple l - ) tl [] IS.empty - | `Var v when not @@ Hashtbl.mem sub.resolv v -> - k IS.empty `Int + (fun l -> + resolve sub (fun t' -> + k_acc (t'::l) + ) t + ) + ) + (fun l -> + k @@ `Tuple l + ) tl [] + | `Var v when not @@ Hashtbl.mem sub.resolv v -> k `Int | `Var v -> let t' = Hashtbl.find sub.resolv v in - resolve_with_rec sub v_set k (t' :> typ) + resolve sub k (t' :> typ) | `Array t' -> - resolve_with_rec sub v_set (fun is t_lift -> + resolve sub (fun t_lift -> match t_lift with - | `Int -> k is @@ `Array `Int + | `Int -> k @@ `Array `Int | _ -> failwith "Only integer arrays are supported" ) t' - | `IntList -> k IS.empty `IntList + | `IntList -> k `IntList let process_call ~loc lkp ctxt { callee; arg_names; _ } = let sorted_args = List.fast_sort String.compare arg_names in @@ -325,18 +287,6 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = let unify t1 t2 = unify ~loc ctxt.sub t1 t2 in - let fresh_cons t1 = - fresh_cons ctxt.sub t1 - in - let save_assign v = - let assign_t = lkp v in - let c_id = fresh_cons_id ctxt.sub @@ assign_t in - { res_acc with assign_locs = (id,c_id,assign_t)::res_acc.assign_locs },c_id - in - let record_read ty res_acc = - let c_id = fresh_cons_id ctxt.sub ty in - { res_acc with deref_locs = (id,c_id,ty)::res_acc.deref_locs },c_id - in let record_tcons = let open Std.StateMonad in let%lm impl tup_var ind pvar acc = @@ -382,16 +332,15 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = unify_ref v1 `Int; process_expr ret_type ctxt e res_acc | Assign (v1,IVar v2,e) -> - let acc,c_id = save_assign v2 in - unify_var v1 @@ `TyCons c_id; - process_expr ret_type ctxt e acc + unify_var v1 @@ `Ref (lkp v2); + process_expr ret_type ctxt e res_acc | Update (v1,ind,u,e) -> let d = fresh_var () in unify_var v1 @@ `Array d; unify_var ind `Int; unify_var u @@ d; process_expr ret_type ctxt e res_acc - | Alias (ap1, ap2 ,e) -> + | Alias (ap1, ap2 ,e) -> let fresh_node () = UnionFind.new_node ctxt.sub.uf in let find (ap : Paths.concr_ap) = let open Paths in @@ -430,8 +379,8 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = process_expr ret_type ctxt e res_acc | Fail -> res_acc,true | Let (PVar v,Mkref (RVar v'),expr) -> - let acc,c_id = save_assign v' in - process_expr ret_type (add_var v (`TyCons c_id) ctxt) expr @@ save_let (`TyCons c_id) acc + unify_var v @@ `Ref (lkp v'); + process_expr ret_type (add_var v (`Ref (lkp v')) ctxt) expr @@ save_let (`Ref (lkp v')) res_acc | Let (p,lhs,expr) -> let res_acc',v_type = let same t = res_acc,t in @@ -441,9 +390,8 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = | Mkref i -> same @@ begin match i with | RNone - | RInt _ -> fresh_cons `Int - | RVar v -> - fresh_cons (lkp v) + | RInt _ -> `Ref `Int + | RVar v -> `Ref (lkp v) end | Call c -> same @@ process_call ~loc lkp ctxt c | Nondet _ -> same `Int @@ -453,10 +401,9 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = same @@ `Int | Deref p -> let tv = fresh_var () in - let acc',c_id = record_read tv res_acc in - unify_var p @@ `TyCons c_id; - acc',tv - | Null -> same @@ fresh_cons @@ fresh_var () + unify_var p @@ `Ref tv; + res_acc,tv + | Null -> same @@ `Ref( fresh_var ()) | Tuple tl -> let _ = List.fold_left (fun acc r -> match r with @@ -516,7 +463,7 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = unify_var v1 `IntList; (* No need a constraint to be the return type of e2 and e3 are the same because they share the "ret_type". *) let acc1, b1 = process_expr ret_type ctxt e2 res_acc in - let acc2, b2 = process_expr ret_type (add_var h `Int (add_var r `IntList ctxt)) e3 @@ save_match_binding [(h, `Int); (r, `IntList)] acc1 in + let acc2, b2 = process_expr ret_type (add_var h `Int (add_var r (`Ref `IntList) ctxt)) e3 @@ save_match_binding [(h, `Int); (r, `Ref `IntList)] acc1 in acc2, b1 && b2 let constrain_fn sub fenv acc ({ name; body; _ } as fn) = @@ -525,59 +472,17 @@ let constrain_fn sub fenv acc ({ name; body; _ } as fn) = let acc',_ = process_expr (Option.some @@ `Var (StringMap.find name fenv).ret_type_v) ctxt body acc in acc' -(* -checks whether an assignemnt to (or read from) of type t' to constructor c -requires a fold or unfold. Simply put, we walk the assigned type, and see -if (the canonical representation of) c appears anywhere in t'. If it does, this is -a folding or unfolding assignment/read. -*) -(* If this function is to resolve recursive types, you can omit this step by proposing fold/unfold *) -let is_rec_assign sub c t' = - let canon_c = TyConsUF.find sub.cons_uf c in - let rec check_loop h_rec t = - match canonicalize sub t with - | `Var v -> - Hashtbl.find_opt sub.resolv v - |> Option.map [%cast: typ] - |> Option.map @@ check_loop h_rec - |> Option.value ~default:true - | `Int -> false - | `TyCons c -> - let c_id = TyCons.unwrap c in - if c = canon_c then true - else if IS.mem c_id h_rec then - false - else - check_loop (IS.add c_id h_rec) @@ TyConsResolv.find sub.cons_arg c - | `Tuple tl -> - List.exists (check_loop h_rec) tl - | `Array t' -> check_loop h_rec t' - | `IntList -> false - in - check_loop IS.empty t' - -(* If this function is to resolve recursive types, you can omit this step by proposing fold/unfold *) -let get_rec_loc sub p_ops = - List.fold_left (fun acc (i,c,t') -> - if is_rec_assign sub c t' then - i::acc - else - acc - ) [] p_ops - let typecheck_prog intr_types (fns,body) = let (resolv : (int,refined_typ) Hashtbl.t) = Hashtbl.create 10 in - let cons_arg = TyConsResolv.create 10 in let uf = UnionFind.mk () in - let cons_uf = TyConsUF.mk () in let sub = { - uf; cons_uf; resolv; cons_arg; fn_name = ""; + uf; resolv; fn_name = ""; } in let fenv_ : funenv = make_fenv uf fns in let fenv = let lift_const t = let t_id = UnionFind.new_node uf in - Hashtbl.add resolv t_id @@ abstract_type sub t; + Hashtbl.add resolv t_id @@ abstract_type t; t_id in StringMap.fold (fun k { arg_types; ret_type } -> @@ -589,14 +494,12 @@ let typecheck_prog intr_types (fns,body) = in let acc = List.fold_left (constrain_fn sub fenv) { t_cons = []; - assign_locs = []; - deref_locs = []; let_types = Std.IntMap.empty; match_bindings = Std.IntMap.empty; } fns in let (acc',_) = process_expr None { - sub = { sub with fn_name = "
" }; fenv; tyenv = StringMap.empty; + sub = { sub with fn_name = "
" }; fenv; tyenv = StringMap.empty; } body acc in List.iter (fun { var; ind; unif; loc } -> @@ -611,16 +514,7 @@ let typecheck_prog intr_types (fns,body) = unify ~loc sub (`Var unif) @@ List.nth tl ind | Some t' -> Locations.raise_errorf ~loc "Ill-typed: expected tuple, got %s" @@ string_of_typ (t' :> typ) ) acc'.t_cons; - let distinct_list_to_set l = - let l' = Std.IntSet.of_list l in - if (List.compare_length_with l @@ Std.IntSet.cardinal l') <> 0 then - failwith "Multiple recursive type operations at the same point" - else - l' - in - let fold_locs = distinct_list_to_set @@ get_rec_loc sub acc'.assign_locs in - let unfold_locs = distinct_list_to_set @@ get_rec_loc sub acc'.deref_locs in - let get_soln = resolve_with_rec sub IS.empty (fun _ t -> t) in + let get_soln = resolve sub (fun t -> t) in let rec get_soln_with_var_name = function | [] -> [] | (var, ty) :: r -> (var, get_soln ty) :: get_soln_with_var_name r @@ -631,8 +525,6 @@ let typecheck_prog intr_types (fns,body) = let ret_type = get_soln @@ `Var ret_type_v in StringMap.add name { arg_types; ret_type } acc ) StringMap.empty fns),SideAnalysis.( - { unfold_locs; - fold_locs; - let_types = Std.IntMap.map get_soln acc'.let_types; + { let_types = Std.IntMap.map get_soln acc'.let_types; match_bindings = Std.IntMap.map get_soln_with_var_name acc'.match_bindings; }) diff --git a/src/simpleChecker.mli b/src/simpleChecker.mli index 3a21431c..cd40df1c 100644 --- a/src/simpleChecker.mli +++ b/src/simpleChecker.mli @@ -1,8 +1,6 @@ module SideAnalysis: sig type results = { - unfold_locs: Std.IntSet.t; - fold_locs: Std.IntSet.t; let_types: SimpleTypes.r_typ Std.IntMap.t; match_bindings: (string * SimpleTypes.r_typ) list Std.IntMap.t; } diff --git a/src/simpleTypes.ml b/src/simpleTypes.ml index 7f069a72..67e677d2 100644 --- a/src/simpleTypes.ml +++ b/src/simpleTypes.ml @@ -17,18 +17,6 @@ type 'a _funtyp = { type funtyp = r_typ _funtyp -let unfold_simple_type i t = - let rec loop = function - | `Int -> `Int - | `TVar j when i = j -> `Mu (i,t) - | `Tuple tl -> `Tuple (List.map loop tl) - | `Ref t -> `Ref (loop t) - | `Array `Int -> `Array `Int - | `IntList -> `IntList - | `TVar _ -> failwith "Malformed recursive type" - in - loop t - let rec type_to_string = function | `Int -> "int" | `Ref t -> Printf.sprintf "%s ref" @@ type_to_string t diff --git a/src/simpleTypes.mli b/src/simpleTypes.mli index e77a2763..79c8f126 100644 --- a/src/simpleTypes.mli +++ b/src/simpleTypes.mli @@ -3,7 +3,6 @@ type r_typ = [ | `TVar of int | `Tuple of r_typ list | `Ref of r_typ - | `Mu of int * r_typ | `Array of a_typ | `IntList ] and a_typ = [ `Int ][@@deriving sexp] @@ -15,6 +14,5 @@ type 'a _funtyp = { type funtyp = r_typ _funtyp -val unfold_simple_type : int -> r_typ -> r_typ val type_to_string: r_typ -> string val fntype_to_string: funtyp -> string From f5fbb73f69b4f01cbe3cd4eed4d2061ea4378176 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 29 May 2023 15:34:57 +0900 Subject: [PATCH 028/108] complete simpleChecker --- src/simpleChecker.ml | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/src/simpleChecker.ml b/src/simpleChecker.ml index 55c18aca..5d29f1e9 100644 --- a/src/simpleChecker.ml +++ b/src/simpleChecker.ml @@ -21,7 +21,7 @@ type. (Note all other recursion is forbidden). open Ast open SimpleTypes open Sexplib.Std - + type funtyp_v = { arg_types_v: int list; ret_type_v: int @@ -72,7 +72,7 @@ let _sexp_of_resolv_map r = Hashtbl.fold (fun k v acc -> Instead, if the tuple size is not yet known, we save a tuple constraint, which consists of the type variable (var) representing the tuple, the index (ind), and the - type variable to unify with type at ind (unif). + type variable to unify with type at ind (unif). After the rest of type inference is completed, we resolve var, and (assuming it has been properly refined to a concrete length tuple) perform the unification with unif at ind. *) @@ -112,11 +112,11 @@ type fn_ctxt = { let abstract_type t = let rec loop = function | `TVar _ -> failwith "Not supported" - | `Ref t -> `Ref (loop t) + | `Ref t -> `Ref ((loop t) :> typ) | `Int -> `Int | `Tuple tl -> `Tuple (List.map loop tl |> List.map [%cast: typ]) - | `Array t -> `Array ((loop (t :> SimpleTypes.r_typ)) :> typ) + | `Array t -> `Array ((loop (t :> SimpleTypes.r_typ)) : refined_typ :> typ) | `IntList -> `IntList in loop t @@ -164,7 +164,7 @@ let rec occurs_check sub v (t2: typ) = let assign sub var t = occurs_check sub var (t :> typ); - Hashtbl.add sub.resolv var t + Hashtbl.add sub.resolv var t (* unify and unify_tycons are mutually recursive, the former unifies types (typ) and the latter unifies reference type constructors *) @@ -214,7 +214,7 @@ module IS = Std.IntSet let rec resolve sub k t = match canonicalize sub t with | `Int -> k `Int - | `Ref t -> k @@ `Ref t + | `Ref t -> k @@ `Ref (resolve sub (fun t -> t) t) | `Tuple tl -> List.fold_left (fun k_acc t -> (fun l -> @@ -287,7 +287,7 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = let unify t1 t2 = unify ~loc ctxt.sub t1 t2 in - let record_tcons = + let record_tcons = let open Std.StateMonad in let%lm impl tup_var ind pvar acc = { acc with t_cons = { var = tup_var; ind; unif = pvar; loc }::acc.t_cons } @@ -354,8 +354,7 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = unify_var v tau; return () | `Deref::rest -> - let%bind c_id = record_read tau in - let ty = `TyCons c_id in + let ty = `Ref tau in find_loop ty rest | `Proj i::rest -> let tuple_v = fresh_node () in From e646c7711b0b4212084e81abcdc96ce7fced988c Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Tue, 30 May 2023 15:13:19 +0900 Subject: [PATCH 029/108] delete flow inference and verifying with solver --- src/consort.ml | 46 +- src/dune | 3 +- src/flowBackend.ml | 301 ---- src/flowInference.ml | 3045 ------------------------------------- src/flowInference.mli | 52 - src/ownershipInference.ml | 56 +- src/parser.mly | 6 +- 7 files changed, 55 insertions(+), 3454 deletions(-) delete mode 100644 src/flowBackend.ml delete mode 100644 src/flowInference.ml delete mode 100644 src/flowInference.mli diff --git a/src/consort.ml b/src/consort.ml index edd87296..fe1bfbba 100644 --- a/src/consort.ml +++ b/src/consort.ml @@ -29,7 +29,7 @@ let result_to_string = function | Verified -> "VERIFIED" | Unverified r -> Printf.sprintf "UNVERIFIED (%s)" @@ reason_to_string r true -let solver_result_to_check_result = +(* let solver_result_to_check_result = let open Solver in function | Unsat -> Unverified Unsafe @@ -37,9 +37,9 @@ let solver_result_to_check_result = | Timeout -> Unverified Timeout | Unhandled msg -> Unverified (UnhandledSolverOutput msg) | Error msg -> Unverified (SolverError msg) - | Unknown -> Unverified Unknown + | Unknown -> Unverified Unknown *) -let choose_solver = +(* let choose_solver = let open ArgOptions.Solver in function | Eldarica -> EldaricaBackend.solve @@ -47,13 +47,13 @@ let choose_solver = | Null -> NullSolver.solve | Parallel -> ParallelBackend.solve | Spacer -> HornBackend.solve - | Z3SMT -> SmtBackend.solve + | Z3SMT -> SmtBackend.solve *) let pcomment ~body = let open PrettyPrint in pblock ~nl:true ~op:(ps "/*") ~body ~close:(ps "*/") -let print_program ~o_map ~o_printer r ast = +(* let print_program ~o_map ~o_printer r ast = let open PrettyPrint in let open OwnershipInference.Result in let rec print_type = @@ -113,25 +113,25 @@ let print_program ~o_map ~o_printer r ast = newline ] in - AstPrinter.pretty_print_program ~annot:pp_ty_env ~annot_fn:pp_f_type stdout ast + AstPrinter.pretty_print_program ~annot:pp_ty_env ~annot_fn:pp_f_type stdout ast *) -let print_fold_locations simple_res = +(* let print_fold_locations simple_res = let open SimpleChecker.SideAnalysis in let _, side = simple_res in print_endline "FOLD LOCATIONS >>>"; Std.IntSet.iter (Printf.printf "* %d\n") side.fold_locs; - print_endline "<<<" + print_endline "<<<" *) -let print_inference infer_res ast = +(* let print_inference infer_res ast = let open PrettyPrint in let open OwnershipInference in let o_map o = o in let o_printer = function | OConst o -> pf "%f" o | OVar v -> pf "$%d" v in - print_program ~o_map ~o_printer infer_res ast + print_program ~o_map ~o_printer infer_res ast *) -let print_ownership ownership_res infer_res ast = +(* let print_ownership ownership_res infer_res ast = let open PrettyPrint in let open OwnershipInference in match ownership_res with @@ -141,7 +141,7 @@ let print_ownership ownership_res infer_res ast = | OConst o -> o | OVar o -> List.assoc o o_res in let o_printer = pf "%f" in - print_program ~o_map ~o_printer infer_res ast + print_program ~o_map ~o_printer infer_res ast *) let print_typecheck (f_types, side) ast = let open Ast in @@ -174,7 +174,7 @@ let print_typecheck (f_types, side) ast = in AstPrinter.pretty_print_program ~annot_fn ~annot stdout ast -let to_hint o_res record = +(* let to_hint o_res record = let open OwnershipInference in let o_map = function | OVar v -> List.assoc v o_res @@ -183,22 +183,23 @@ let to_hint o_res record = { splits = SplitMap.map s_map record.splits; gen = GenMap.map o_map record.gen - } + } *) -let get_solve ~opts = +(* let get_solve ~opts = let open ArgOptions in let module Backend = struct let solve = choose_solver opts.solver end in let module S = FlowBackend.Make(Backend) in - S.solve + S.solve *) let consort ~opts file = let ast = AstUtil.parse_file file in let intr_op = (ArgOptions.get_intr opts).op_interp in let simple_typing = RefinementTypes.to_simple_funenv intr_op in - let simple_res = SimpleChecker.typecheck_prog simple_typing ast in - let infer_res = OwnershipInference.infer ~opts simple_res ast in + let _ = SimpleChecker.typecheck_prog simple_typing ast in + assert false + (* let infer_res = OwnershipInference.infer ~opts simple_res ast in let ownership_res = OwnershipSolver.solve_ownership ~opts infer_res in match ownership_res with | None -> Unverified Aliasing @@ -206,21 +207,22 @@ let consort ~opts file = let o_hint = to_hint o_res infer_res.op_record in let solve = get_solve ~opts in let ans = solve ~opts simple_res o_hint ast in - solver_result_to_check_result ans + solver_result_to_check_result ans *) let ownership ~opts file = let ast = AstUtil.parse_file file in let intr_op = (ArgOptions.get_intr opts).op_interp in let simple_op = RefinementTypes.to_simple_funenv intr_op in - let simple_res = SimpleChecker.typecheck_prog simple_op ast in - print_fold_locations simple_res; + let _ = SimpleChecker.typecheck_prog simple_op ast in + assert false + (* print_fold_locations simple_res; let infer_res = OwnershipInference.infer ~opts simple_res ast in print_inference infer_res ast; let ownership_res = OwnershipSolver.solve_ownership ~opts infer_res in print_ownership ownership_res infer_res ast; match ownership_res with | None -> Unverified Aliasing - | Some _ -> Verified + | Some _ -> Verified *) let typecheck ~opts file = let ast = AstUtil.parse_file file in diff --git a/src/dune b/src/dune index 5f0c7b54..40360bb9 100644 --- a/src/dune +++ b/src/dune @@ -43,8 +43,7 @@ (modules HornBackend SmtBackend Z3BasedBackend Consort HoiceBackend NullSolver - ExternalFileBackend EldaricaBackend ParallelBackend - FlowInference FlowBackend)) + ExternalFileBackend EldaricaBackend ParallelBackend)) (executable (name test) diff --git a/src/flowBackend.ml b/src/flowBackend.ml deleted file mode 100644 index 0aa4c6fc..00000000 --- a/src/flowBackend.ml +++ /dev/null @@ -1,301 +0,0 @@ - -(* TODO: factor this out better *) -module Make(C : Solver.SOLVER_BACKEND) = struct - type t = unit - open SexpPrinter - open FlowInference - open Std.StateMonad - - include (val Log.located ~where:"FB") - - module RT = RefinementTypes - - let pp_ap p = pl @@ Paths.to_z3_ident p - - let pp_ztype = function - | ZInt -> pl "Int" - | ZBool -> pl "Bool" - - let pp_imm = function - | Ap p -> pl @@ Paths.to_z3_ident p - | IConst i -> pl @@ string_of_int i - | BConst b -> pl @@ Bool.to_string b - | _ -> assert false - - let add_ident path ty map = - (Paths.PathMap.update path (function - | None -> Some ty - | Some ty' -> if ty' <> ty then failwith @@ Printf.sprintf "Something has gone wrong for path %s" (Paths.to_z3_ident path) else Some ty' - ) map),() - - let context_at = Printf.sprintf "ctxt$%d" - - let choice_counter = ref 0 - - let pp_int i = - if i < 0 then - ll [ pl "-"; pl @@ string_of_int @@ ~-i ] - else - pl @@ string_of_int i - - - let close_and_print ~opts ~fgen clause = - let rel_op = (ArgOptions.get_intr opts).rel_interp in - let rec pp_arg ty = function - | Ap p -> add_ident p ty >> return @@ pp_ap p - | IConst i -> return @@ pp_int i - | BConst b -> return @@ pl @@ Bool.to_string b - | KeyedChoice (b,a1,a2) -> - let%bind a1_pp = pp_arg ty a1 in - let%bind a2_pp = pp_arg ty a2 in - add_ident b ZBool >> - return @@ pg "ite" [ - pp_ap b; - a1_pp; - a2_pp - ] - in - match clause with - | Relation (p,ty) -> - let%bind p1 = pp_arg ty p.rel_op1 in - let%bind p2 = pp_arg ty p.rel_op2 in - return RefinementTypes.( - let rel_sym = StringMap.find p.rel_cond rel_op in - pg rel_sym [ - p1; - p2 - ] - ) - | NamedRel (name,args) -> - miter (function - | Ap p -> add_ident p ZInt - | _ -> return () - ) args >> - return @@ pg name @@ List.map pp_imm args - | NullCons (p1,p2) -> - let%bind p1 = pp_arg ZBool p1 in - let%bind p2 = pp_arg ZBool p2 in - return @@ pg "=>" [ - p1; - p2 - ] - - | PRelation ((name,formals,_),subst,ctxt_shift) -> - let pred = fgen name in - let subst_map = List.fold_left (fun acc (k,v) -> - Paths.PathMap.add k v acc - ) Paths.PathMap.empty subst - in - let%bind val_args = - mmap (fun (arg_path,ty) -> - if pred arg_path then - let subst = Paths.PathMap.find_opt arg_path subst_map in - match subst with - | None -> add_ident arg_path ty >> return @@ Some (pp_ap arg_path) - | Some subst -> let%bind a = pp_arg ty subst in return (Some a) - else - return None - ) formals - in - let val_args = List.filter_map Fun.id val_args in - let%bind ctxt_args = - if opts.cfa = 0 then - return [] - else - let tl_adj = Option.fold ~none:0 ~some:(Fun.const 1) ctxt_shift in - let%bind tail = List.init (opts.cfa - tl_adj) context_at |> List.map P.var |> mmap (fun ap -> - add_ident ap ZInt >> return @@ pp_ap ap - ) in - match ctxt_shift with - | None -> return tail - | Some i -> return @@ (pl @@ string_of_int i)::tail - in - let args = ctxt_args @ val_args in - if (List.compare_length_with args 0) > 0 then - return @@ pg name args - else - return @@ pl name - - let close_impl ~opts ~fgen ante conseq = - let path_types = Paths.PathMap.empty in - let path_types,ante_k = mmap (close_and_print ~opts ~fgen) ante path_types in - let ante_k = match ante_k with - | [] -> pl "true" - | _ -> pg "and" ante_k - in - let path_types,conseq_k = close_and_print ~opts ~fgen conseq path_types in - (path_types,ante_k,conseq_k) - - let pp_impl ~opts ~fgen (ante,conseq) ff = - let (args,ante_k,conseq_k) = close_impl ~opts ~fgen ante conseq in - let quantif = Paths.PathMap.bindings args |> List.map (fun (s,t) -> - ll [ pp_ap s; pp_ztype t ] - ) in - if (List.compare_length_with quantif 0) > 0 then - pg "assert" [ - pg "forall" [ - ll quantif; - pg "=>" [ - ante_k; - conseq_k - ] - ] - ] ff.printer - else - pg "assert" [ - pg "=>" [ - ante_k; - conseq_k - ] - ] ff.printer - - let solve_constraints ~opts ~fgen rel impl start_relation = - let ff = SexpPrinter.fresh () in - let cfa = opts.ArgOptions.cfa in - let ctxt_args = List.init cfa (fun _ -> pp_ztype ZInt) in - let grounded = - if cfa = 0 then - pl start_relation - else - pg start_relation @@ List.init cfa (fun _ -> pl "0") - in - let () = - List.iter (fun (nm,args,_) -> - pg "declare-fun" [ - pl nm; - ll @@ ctxt_args @ ( - let pred = fgen nm in - List.filter_map (fun (p,ty) -> - if pred p then - Option.some @@ pp_ztype ty - else - None - ) args - ); - pl "Bool" - ] ff.printer; - break ff - ) rel; - List.iter (fun imp -> - pp_impl ~opts ~fgen imp ff; - break ff - ) impl; - - (* now ground the entry point *) - pg "assert" [ - pg "forall" [ - ll [ ll [ pl "dummy"; pl "Int" ] ]; - grounded - ] - ] ff.printer; - break ff - in - SexpPrinter.finish ff; - ff - - let pprint_annot = - let open PrettyPrint in - fun m (i,_) _ -> - let { gamma; relation; mu_relations } = Std.IntMap.find i m in - let vars = - let bindings = List.map (fun (k, t) -> - pf !"%s: %{FlowInference.fltype_to_string}" k t - ) gamma |> psep_gen newline - in - pblock ~nl:false ~op:(ps "+ Variable Types:") ~body:bindings ~close:null - in - let pp_rel (name,args,_) = - let args = List.map (fun (p,_) -> ps @@ P.to_z3_ident p) args |> psep_gen (pf ",@ ") in - pl [ - pf "%s(" name; - pb [ args ]; - ps ")" - ] - in - let mu_rel = - let body = P.PathMap.bindings mu_relations |> List.map (fun (s,rel) -> - pb [ - pf !"%{P}:@ " s; - pp_rel rel; - ] - ) |> psep_gen newline - in - pblock ~op:(ps "+ Mu Relations:") ~body ~close:null - in - let relation = - pb [ - pf "+ Relation:@ "; - pp_rel relation - ] - in - let body = psep_gen null [ vars; mu_rel; relation ] in - pblock ~nl:true ~op:(ps "/*") ~body ~close:(ps "*/") - - let output_endline out s = output_string out (s ^ "\n") - let show_annot ~opts snap ast = - let print out = - AstPrinter.pretty_print_program - ~with_labels:true ~annot:(pprint_annot snap) out ast in - ArgOptions.show ~opts opts.show_annot print - let show_ast ~opts (program_types,_) ast = - let print out = - AstPrinter.pretty_print_program out ast; - StringMap.iter (fun n a -> - output_endline out - @@ Printf.sprintf "%s: %s" n @@ SimpleTypes.fntype_to_string a - ) program_types in - ArgOptions.show ~opts opts.show_ast print - let show_cons ~opts cons = - let print out = - let def_file = (ArgOptions.get_intr opts).def_file in - output_endline out @@ "; Sending constraints >>>"; - output_endline out @@ "; Intrinsic definitions"; - output_endline out - @@ Option.fold ~none:"" ~some:Files.string_of_file def_file; - output_endline out @@ "; Constraints"; - output_endline out @@ SexpPrinter.to_string cons; - output_endline out @@ "; <<<" in - ArgOptions.show ~opts opts.show_cons print - let show_ir ~opts snap ast rel = - let print out = - let open Std in - let open Sexplib.Std in - let mu_bind = - IntMap.bindings snap - |> ListMonad.bind (fun (i,pmap) -> - P.PathMap.bindings pmap.mu_relations - |> List.map (fun (p,rel) -> (i,p,rel))) in - let sexp = [%sexp_of: Ast.prog * - FlowInference.relation list * - (int * P.concr_ap * relation) list - ] (ast,rel,mu_bind) in - Sexplib.Sexp.output_hum out sexp in - ArgOptions.show ~opts opts.show_ir print - let show_model ~opts ans = - let print out = - match ans with - | Solver.Sat Some m -> output_endline out m - | _ -> () in - ArgOptions.show ~opts opts.show_model print - - let solve ~opts simple_res o_hints ast = - let rel,impl,snap,start,omit = - FlowInference.infer ~opts simple_res o_hints ast in - let fgen = - if opts.relaxed_max then - (fun s -> - StringMap.find_opt s omit - |> Option.map (fun s -> - (fun p -> not @@ P.PathSet.mem p s)) - |> Option.value ~default:(fun _ -> true)) - else (fun _ _ -> true) in - let cons = solve_constraints ~opts ~fgen rel impl start in - let ans = C.solve ~opts cons in - show_annot ~opts snap ast; - show_ast ~opts simple_res ast; - show_cons ~opts cons; - show_ir ~opts snap ast rel; - show_model ~opts ans; - ArgOptions.close_output ~opts; - ans -end diff --git a/src/flowInference.ml b/src/flowInference.ml deleted file mode 100644 index cd152549..00000000 --- a/src/flowInference.ml +++ /dev/null @@ -1,3045 +0,0 @@ -(** - The "refinement" inference. Strictly speaking, we are not actually inferring refinements - on individual variables (that was the purview of the now deleted inference.ml). Instead we are - inferring relations that summarize the entire program state at each program point (with some extra - relations for recursive types, explained later). - - We call this module "flowInference" because our encoding gives a symbolic description of the flow - states (as abstracted by the relations) through the program. - - For the rest of this file to make any sense, you need to understand the following key concepts. - - {3 Relations} - Ignoring for the moment the handling of recursive types and how to encode null pointers, the set of possible - states at each program point p is characterized by a relation Rp(...). The arguments to this relation - are the values of all integer values "reachable" from the current state. In the simplest case, we would characterize - a state with integer variables x and y with the predicate Rp(x, y). Intuitively, a state is where x takes value v1 and - y takes value v2 is feasible if Rp(v1, v2). We encode the transformation of states by implications between these - relations, i.e., suppose we are in a state at p with integer x, and we bind y to x + 1 for the state at p', then we would - generate the implication Rp(x) => Rp'(x, x + 1), i.e., if we can reach p in a state where x takes value v, then we can - reach p' in a state where y has value v + 1. So far, so hoare. - - Leaving aside the question of null pointer (see below) references are just another integer value. Assuming no recursive types (again, see below), - we can easily enumerate the set of symbolic names (expressed as access paths) for every integer value stored in memory (NB: Lacking - recursive types every reference type must eventually "bottom out" at some integer, and as we don't refine memory locations, we characterize - our states entirely by the contents of references. Put another way, we don't distinguish between a state where x contains an address a which - points to 3 vs. a state where x contains an address a' which also points to 3; in both cases, x ultimately points to a value 3.) So, extending - our example from above, suppose we bound y to mkref x + 1; the implication actually remains the same, but the formal definition of Rp' would - be R( x, y->* ) indicating the latter integer is stored in a memory cell pointed to by y. - - Leaving aside the complicating factors of havocing, null pointers, and recursive types (though their complexity should not be understated), - at its core the encoding is quite simple: compute which values from one state can flow to another, and set up an implication from Rp to Rp' - reflecting these flows (see, e.g., compute_flows). - - {3 Null Handling} - Null pointers complicate the above simple view of values; sometimes y may not actually hold a value; what should we provide as the second - argument of Rp' in the above? One possible idea is to pick some arbitrary value held in every null pointer, say 0. This is sound, albeit - imprecise. For one, the following program is, technically speaking, safe: [let y = null in assert( *y = 1)] (The assertion is never actually - violated because the program aborts with a NPE first.) However, our naive semantics above will spuriously state the assertion fails because *y is 0. - - A more subtle issue is handling when pointers may be null conditionally (this is often the case with recursive data structures). Suppose we want - to maintain the invariant that x > 0 is always less than the contents of some (possibly null) reference y. However, if we model y's nullness - with the dummy value 0, Z3 will conclude that it is not the case x < *y, which may prevent verification. - - The issue lies that any refinement that mentions the contents of a reference must be qualified with "if the containing reference is not null, then...". - To restate our desired condition from the above paragraph, we should say more precisely that: for some x > 0, if y is non-null, then x < *y. - But this does not characterize the states where y is null. In that case, x should have no relationship with the contents of y (because, strictly - speaking, there are none.) - - This case-splitting on the nullity of y gives the intuition for how we handle nullity. For every reference at path p, - we generate a nullity flag, denoted p?null. This is one of many "shadow state" variables that we introduce. In this case, this - flag corresponds to the (maybe implicit) runtime tag maintained by the runtime for each reference indicating whether it is null. - The object language exposes access to this flag with the ifnull, but it is otherwise inaccessible. However, we explicitly model - it in our static semantics. - - The nullity flag is just another value; flowing along with integers when pointers are assigned or moved. However, they are treated - specially at certain operations. First, when a reference r is definitely null in some state p, the flag r?null is set to true, - all null flags reachable from r are set to true, and _all integer values reachable from r are havoced_. When we say havoc, we mean - the integer values contained within the pointer are left unconstrained, meaning Z3 or another solver may assume they may take any value. - A reference can definitively proved to be null at assignments of the null pointer constant and the true branch of an ifnull statement. - For example, if y has simple type int ref in e, we model the binding [let y = null in e], we omit the constraint Rp(...) => Rp'(..., true, * ), where - * represents a nondeterministic value and Rp' has the arguments of Rp extended with y->* and y?null. - - Dually, as a precondition, we can constrain the null flag to be false when we know the reference must be non-null. - This is the case when a pointer is either read - or written, the null flag of the read/written reference may be assumed false, because the operation will fail if the pointer is null. - - Returning to our example [let y = null in assert( *y = 1)], after desugaring we have [let y = null in let t = *y in assert(t = 0)]. The - The set of states that reach [let t = *y in ...] are characterized by Rp( true, * ). Using the insight described above, we have the - states of the body of the second let are described by Rp'( y?null, y->*, t) where Rp( false, y->* ) => Rp'( false, y->*, y->* ). However - There is no state which satisfies the precondition on Rp (the pointer must be null after all), and thus no state reaches Rp', and by extension, the - (incorrect) assertion. - - {3 Havocing} - The eagle-eyed will notice that given the definition described so far, Z3 may infer relationships between immutable variables and reference contents, - treating the reference contents as mutable variables. However, due to aliasing, an update through one reference may update the values - of multiple static names. This is where ownership, and _havocing_ comes in to play. Recall that for a write to a reference, the ownership - of all aliasies must be 0. The flowInference module tracks the set of access paths that occur under 0 ownership references. At each write, the - set of all havoced paths are havoced. Further, whenever reference's ownership drops to zero, the contents of that reference are havoced. - As with the null pointers above, havocing refers to leaving the value of an access path totally unconstrained, i.e., Z3 or another - solver may assume it takes any value. - - Intuitively, this havocing corresponds to what the Top refinement indicates; we know the simple type of the access path but - no further information about its contents. Notice too that this constrains the type of inferences solvers may draw about the relationship - between immutable storage and mutable cells. For example, suppose the solver concludes y = x->* at some point. - Then, after an assignment, the ownership of x drops to zero, whereby its contents are havoced. The solver must then conclude that y and x->* - are not necessarily equal. This conclusion is correct; if x has zero ownership, the memory cell it points to may be written to through - and alias, so our inference about y = x->* should no longer be assume valid. A non-trivial portion of the inference infrastructure is devoted - to tracking which paths are havoced when, and ensuring they are havoced correctly. - - {4 Mu Relations and Recursive Types} - See the documentation for RecRelations and RecursiveRefinements. -*) - -open Ast - -open Sexplib.Std - -open Std -open Std.StateMonad -open SimpleTypes - -module SM = StringMap -module SS = StringSet -module P = Paths -module OI = OwnershipInference -module RT = RefinementTypes - -open (val Log.located ~where:"FLOW" : Log.LocatedD) [@@ocaml.warning "-33"] - -type z3_types = - | ZBool - | ZInt [@@deriving sexp] - -(** An explanatory value explaining what a relation describes. The AliasUnfold relation is explained in the Alias case, and the ExprMu case is used to describe a mu relation *) -type relation_source = - | Expr of int - | Fun of string * [`In | `Out] - | FunMu of string * [`In | `Out] * P.concr_ap - | ExprMu of int * P.concr_ap * [`Null | `Join | `Flow] - | AliasUnfold of int - | Start [@@deriving sexp] - -(** Describes the flows from a source state to the output state. Compiled into substitutions on relation arguments *) -type flow = - | Havoc of P.concr_ap (** Havoc (i.e., make non-deterministic) the value at thegiven path *) - | Copy of P.concr_ap * P.concr_ap (** copy the value from the first path to the second *) - | Const of P.concr_ap * int (** Set the value at path p to the constant i *) - | NullConst of P.concr_ap * bool (** The value at the null path p to the null flag constant b *) - -(** A relation, which may describe the entirety of the program state at a program point, or a recursive relationship. - The first element is a unique name for the relation, the third element gives the arguments names and types, and the third - is for debugging cex generation purposes. - *) -type relation = string * (P.concr_ap * z3_types) list * relation_source [@@deriving sexp] - -(** Possible values to substitute for arguments to a relation *) -type concr_arg = - | Ap of P.concr_ap (** Another symbolic path name *) - | BConst of bool (** A boolean constant *) - | IConst of int (** integer constant *) - | KeyedChoice of P.concr_ap * concr_arg * concr_arg (** An ite expression which gives a1 if p is true, a2 other wise *) [@@deriving sexp] - -(** Formulae that appear as the components of a CHC *) -type clause = - | PRelation of relation * ((P.concr_ap * concr_arg) list) * int option (** An application of the given relation, with a substitution described by the second argument, and an option context shift given by the third *) - | Relation of (concr_arg,concr_arg) RT.relation * z3_types (** A logical relation (as described in refinement types) between two concrete arguments of type (z3_types) *) - | NamedRel of string * (concr_arg list) (** A named relation with the given arguments. Generated by intrinsics; the smt function name is assumed to be built in or defined in the smt definition file for instrinsics *) - | NullCons of concr_arg * concr_arg (** A null "well-formedness" condition, i.e., if the null flag indicated by p1 is true, then the null flag p2 must be true as well (i.e., null pointers cannot point to null pointers *) - -type fltype = [ - | `IntArray - | `Ref of bool * fltype (** The boolean flag here indicates whether this reference was under a mu binder which has since been unfolded *) - | `Int - | `Tuple of fltype list - | `Mu of fltype - | `TVar -] - -let rec fltype_to_string = function - | `IntArray -> "[int]" - | `Mu t -> Printf.sprintf "(%s %s.%s)" Greek.mu Greek.alpha @@ fltype_to_string t - | `Ref (_,t) -> Printf.sprintf "%s ref" @@ fltype_to_string t - | `Int -> "int" - | `Tuple tl -> Printf.sprintf "(%s)" @@ String.concat ", " @@ List.map fltype_to_string tl - | `TVar -> Greek.alpha - -type funtype = fltype _funtyp - - (** A map from from a mu binder path to a recursive mu relation, which describes the recursive relationship that holds between the - values under the binder, and all values reachable by unfolding the recursive type (see above) *) -type recursive_ref_map = relation P.PathMap.t - -type function_info = { - in_rel : relation; (** The relation describe pre-states (or preconditions) *) - out_rel : relation; (** The out state, which includes the return type *) - f_type: funtype; - in_recursive_rel: recursive_ref_map; (** The map from mu binders in the arguments to mu relations *) - out_recursive_rel : recursive_ref_map; (** The same, but for output results *) -} - -type state_snapshot = { - mu_relations : recursive_ref_map; - gamma : (string * fltype) list; - relation : relation -} - -type ctxt = { - null_checks: bool; (** whether to emit checks that all read/written pointers are provably null *) - relations: relation list; (** List of all defined relations *) - impl: (clause list * clause) list; (** List of CHC implications, represented by a list of preconditions (clauses) and a single conclusion (a clause) *) - o_hints: float OI.ownership_ops; - fenv: function_info SM.t; - curr_fun : string option; - let_types: fltype IntMap.t; - bif_types : RefinementTypes.funtype SM.t; - havoc_set : P.PathSet.t; (** Havoc set is the set of havoced access paths, i.e., the set of access paths under a 0 ownership pointer. - We track this explicitly because we must re-havoc these paths on each assignment. If we did not, the following - program would (incorrectly) type check: [let x = ... in let y = x in let t = *x in y := 4; assert(t = *x)] *) - unfold_iso: IntSet.t; - fold_iso: IntSet.t; - recursive_rel : recursive_ref_map; (** The set of mu relations at each mu binder *) - snapshots : state_snapshot IntMap.t; - omit_set: P.PathSet.t StringMap.t; -} - -type res_t = - relation list (* the list of all relations generated *) - * (clause list * clause) list (* implications *) - * state_snapshot Std.IntMap.t (* snapshots at each location (for annotation) *) - * string (* entry point relation *) - * P.PathSet.t StringMap.t (* omit sets (used in relax mode only) *) - - -let rec unfold_fltype subst = function - | `TVar -> subst - | `Mu _ -> assert false - | `Int -> `Int - | `Ref (false,t) -> `Ref (false,unfold_fltype subst t) - | `Ref (true,_) -> failwith "Already unfolded ref under a mu binder?!?!?" - | `Tuple tl -> `Tuple (List.map (unfold_fltype subst) tl) - | `IntArray -> `IntArray - -(** walks the type, unfolding all mu binders once *) -let rec deep_type_normalization = function - | `Mu (`Ref (false,t)) -> - `Ref (true,unfold_fltype (`Mu (`Ref (false,t))) t) - | `Mu (`Ref (true,_)) -> failwith "broken invariant" - | `Mu _ -> assert false - | `Int -> `Int - | `Tuple tl -> `Tuple (List.map deep_type_normalization tl) - | `Ref (b,t) -> `Ref (b, deep_type_normalization t) - | `IntArray -> `IntArray - | `TVar -> assert false - -let rec simple_to_fltype ?tvar = function - | `Mu (id,t) -> - assert (tvar = None); - `Mu (simple_to_fltype ~tvar:id t) - | `Int -> `Int - | `Array `Int -> `IntArray - | `Ref t -> `Ref (false, simple_to_fltype ?tvar t) - | `TVar id -> - assert (Option.map ((=) id) tvar |> Option.value ~default:false); - `TVar - | `Tuple tl -> `Tuple (List.map (simple_to_fltype ?tvar) tl) - | `IntList -> assert false - -let%lq get_function_type f_name ctxt = - let { f_type; _ } = StringMap.find f_name ctxt.fenv in - f_type - -let%lq get_in_relation f_name ctxt = - let { in_rel = ir; _} = StringMap.find f_name ctxt.fenv in - ir - -let%lq get_out_relation f_name ctxt = - let { out_rel = o_rel; _ } = StringMap.find f_name ctxt.fenv in - o_rel - -let%lq get_function_info f_name ctxt = - StringMap.find f_name ctxt.fenv - -let%lq copy_state ctxt = ctxt - -let get_relation_ident ((n, _, _) : relation) = n - -let merge_havoc_omit rel set omit_map = - StringMap.update rel (function - | None -> Some set - | Some x -> Some (P.PathSet.union x set) - ) omit_map - -let%lm set_havoc_state ~rel havoc_state ctxt = { ctxt with havoc_set = havoc_state; omit_set = merge_havoc_omit rel havoc_state ctxt.omit_set } - -let%lq get_havoc_state ctxt = ctxt.havoc_set - -let%lq get_bound_type e_id ctxt = IntMap.find e_id ctxt.let_types - -let mk_relation lhs op rhs = RT.({ - rel_op1 = lhs; - rel_cond = op; - rel_op2 = rhs - }) - -(** [ty] tracks the type of the arguments (used for "type inference" when dumping SMT clauses) *) -let rel ~ty k = Relation (k,ty) - -(* TODO: make this function actually useful... *) -let path_type p = if P.is_nullity p then ZBool else ZInt - -let%lm add_assert op1 cond op2 curr_relation ctxt = - let ante = [ PRelation (curr_relation,[],None) ] in - let relation = rel ~ty:ZInt @@ mk_relation op1 cond op2 in - { ctxt with impl = (ante,relation)::ctxt.impl } - -let add_assert_cond assert_cond curr_relation = - let lift_to_imm = function - | IVar v -> Ap (P.var v) - | IInt i -> IConst i - in - add_assert - (lift_to_imm assert_cond.rop1) - assert_cond.cond - (lift_to_imm assert_cond.rop2) - curr_relation - -(** One of the two "oracles" used to translate from ownership operations on reference types - to access paths pointing to concrete integers. Flow inference does not track ownership explicitly, - simply the paths TO INTEGER VALUES that are havoced. By contrast, the ownership inference only tracks - the ownership results at each ownership operation; these results give the ownership of a reference, - which has no representation in the abstract state. - - The translation works as follows. For a value path at some generation operation, we walk the path upwards - until we reach the first path to a reference constructor. We then look that path up in the ownership_ops map - produced by the ownership inference. - - This process is, unfortunately, _extremely_ brittle; it's quite easy to pass in a path that is not - rooted in the desired path. Of _particular_ importance is the distinction between the havoc state of the path - to reference r, and the havoc state of paths "beneath" r. In the former case, the havoc state of r (and indeed, r's null flag) - is determined by the containing path of r. Thus, the null flag of a local variable [v] is *never* havoced, even if - the ownership of the reference stored at [v] drops to 0; that ownership describes the havoc status of all paths - _below_ [v], whereas there is no containing reference for [v] itself. It is unfortunate that the path denoting the - null flag of [v] happens to be represented as an extension (and thus "beneath") [v]; this requires an annoying special - case when doing havoc queries, but *believe me*, it's far more annoying to use another strategy. - *) -let rec havoc_oracle ctxt ml p = - Log.debug ~src:"FLOW-OWN" !"Looking for %{P} @ %{sexp:OI.magic_loc}" p ml; - let from_path p_ = - let o = OI.GenMap.find (ml,p_) ctxt.o_hints.OI.gen in - o = 0.0 - in - match P.tail p with - | Some `Deref - | Some `Ind - | Some `Elem -> from_path @@ P.parent p - | Some _ -> havoc_oracle ctxt ml @@ P.parent p - | None -> false - -let%lq split_oracle sl ctxt = - let from_path p = - Log.debug ~src:"FLOW-OWN" !"Splitting %{P} @ %{sexp:OI.split_loc}" p sl; - let (f1,f2) = OI.SplitMap.find (sl,p) ctxt.o_hints.OI.splits in - let to_flag b = if b then `Havoc else `Stable in - (to_flag (f1 = 0.0), to_flag (f2 = 0.0)) - in - let rec loop p1 p2 = - match (P.tail p1),(P.tail p2) with - | None,_ -> (`Trivial,`Trivial) - | _,None -> (`Trivial, `Trivial) - | Some a,Some b -> - let () = assert (a = b) in - if a = `Deref || a = `Ind || a = `Elem then - from_path @@ P.parent p1 - else - loop (P.parent p1) (P.parent p2) - in - loop - -let%lq gen_for_alias e_id ctxt = - havoc_oracle ctxt (OI.MAlias e_id) - -let%lq gen_oracle ml ctxt = - havoc_oracle ctxt ml - -let rec lift_refinement ?(map=Fun.id) ?nu_arg = - let lift_symbolic_ap = map in - let lift_symbolic_imm = function - | RT.RConst i -> IConst i - | RT.RAp p -> Ap (lift_symbolic_ap p) - in - RT.(function - | Top -> [] - | And (r1, r2) -> lift_refinement ~map ?nu_arg r1 @ lift_refinement ~map ?nu_arg r2 - | ConstEq i -> - [ rel ~ty:ZInt @@ mk_relation (Ap (Option.get nu_arg)) "=" (IConst i) ] - | Relation r when r.rel_op1 = Nu -> - [ rel ~ty:ZInt { r with rel_op1 = Ap (Option.get nu_arg); rel_op2 = lift_symbolic_imm r.rel_op2 } ] - | Relation ({ rel_op1 = RImm i; _ } as r) -> - [ rel ~ty:ZInt { r with rel_op1 = (lift_symbolic_imm i); rel_op2 = lift_symbolic_imm r.rel_op2 } ] - | NamedPred (nm,sym_names) -> - let nu_arg = Option.get nu_arg in - let named_args = List.map lift_symbolic_ap sym_names in - let val_args = List.map (fun l -> Ap l) @@ nu_arg::named_args in - [ NamedRel (nm,val_args) ] - | _ -> failwith "Refinement form not supported") - -(** Extract the type referred to by the [path] in [tyenv] *) -let path_simple_type tyenv path = - let rec loop (path: P.path) k = - match P.tail path with - | None -> begin - match (path : P.path :> P.root * 'a * 'b) with - | (P.Var v,_,_) -> k @@ List.assoc v tyenv - | _ -> failwith "not supported" - end - | Some `Deref -> - loop (P.parent path) (function - | `Ref (_,t) -> k t - | t -> failwith @@ Printf.sprintf "Unexpected simple type %s for path %s" (fltype_to_string t) (P.to_z3_ident path) - ) - | Some (`Proj i) -> - loop (P.parent path) (function - | `Tuple tl -> k @@ List.nth tl i - | _ -> assert false - ) - | _ -> failwith "Not supported" - in - loop path (fun i -> i) - -let is_null_flag = true -let is_nonnull_flag = false - -let%lm add_null_path_check curr_rel null_flag_path ctxt = - if not ctxt.null_checks then - ctxt - else - { ctxt with impl = ([ PRelation (curr_rel, [], None) ], rel ~ty:ZBool @@ mk_relation (Ap null_flag_path) "=" (BConst is_nonnull_flag))::ctxt.impl } - -let add_null_check curr_rel pointer_path = - add_null_path_check curr_rel @@ P.to_null pointer_path - -(** Generate nullity well-formedness conditions for the relation - arguments, using the argument subst. Iterates the arguments looking for null-flags, - finds the null flag of the enclosing reference (if any) and then generates a well-formedness - condition. -*) -let null_pre (_,args,_) subst = - let subst_ap p = - if List.mem_assoc p subst then - List.assoc p subst - else - Ap p - in - let rec parent_null_loop p = - match P.tail p with - | None -> None - | Some `Deref -> - Some (P.to_null @@ P.parent p) - | Some _ -> parent_null_loop @@ P.parent p - in - List.filter_map (fun (p,_) -> - if not @@ P.is_nullity p then - None - else - P.parent p - |> parent_null_loop - |> Option.map (fun parent -> - (NullCons (subst_ap parent, subst_ap p)) - ) - ) args - -(** To havoc an access path, we simply generate a fresh name, - universally quantify over it, and leave it completely unconstrained. - This is accomplished by simply generating a fresh name not generated by - "regular" program analysis. -*) -let to_havoc d = Printf.sprintf "havoc!%d!%s" d - -let havoc_ap d p = - P.map_root (to_havoc d) @@ - if P.is_template p then - P.root_at ~child:p ~parent:(P.var "$tmp") - else - p - -(** "Passthrough access paths" or (pass ap) are used for "weak" copies - of summary values. Generally when copying a value from x to y, - it is sufficient to substitution x for y in the output relation. However, - this implies that x and y *must* be equal; if x and y are summary locations this leads - to all sorts of problems. Suppose x is refined in current relation R, and - we want to (weakly) x to the freshly created variable y. Then, it suffices to - to the following: R(x) /\ R(y) => Q(x, y). x and y are not necessarily equal, but both - satisfy the same properties. However, suppose y is already in scope at the time of the copy, - then we will have: - - R(x, y) /\ R(y, y) => Q(x, y) - - Which causes all sorts of problems (in particular, it implies that only values - that satisfy the current and new refinements are acceptable. - Thus we have the *passthrough* access paths which are used as dummy values here. - So, in the example above, we would have: - - R(x, y!pass) /\ R(y, y!pass) => Q(x, y) - - Pass aps are also used as a kind of priming mechanism, to generate a version of the access - path that won't be used for anything else. They are used in aliasing and recursive - refinements. -*) - -let to_pass_ap = P.map_root (fun s -> "pass!" ^ s) - -let lift_copy (s,d) = (s, Ap d) - -let%lm add_implication ante conseq ctxt = - {ctxt with impl = (ante,conseq)::ctxt.impl } - -(** The flow datatype represents high level flows which - are then compiled down to the necessary substitutions on the output - relation. -*) -let flow_to_subst i = function - | Havoc p -> p,Ap (havoc_ap i p) - | Const (p,c) -> (p,IConst c) - | Copy (p1,p2) -> (p2,Ap p1) - | NullConst (p,b) -> (p,BConst b) - -let%lm add_relation_flow ?out_ctxt ?(pre=[]) subst in_rel out_rel ctxt = - let lifted_subst = List.mapi flow_to_subst subst in - let ante = PRelation (in_rel,[],None)::pre in - let conseq = PRelation (out_rel,lifted_subst,out_ctxt) in - { - ctxt with impl = ((ante,conseq)::ctxt.impl) - } - -(** For a given type, generate all paths to "address" values - of that type. In other words, given a root variable of type t, - what are the access paths of the values reachable from that root variable. -*) -let type_to_paths ?(pre=false) root (ty: fltype) = - let add_path pre under_ref under_mu acc p = - let paths = - (if under_ref && not under_mu && pre then - [P.pre p] else []) @ - [p] - in - paths @ acc - in - let rec loop under_ref under_mu acc p = function - | `Int -> add_path pre under_ref under_mu acc p - | `Ref (_,t) -> - let acc = add_path pre under_ref under_mu acc (P.to_null p) in - loop true under_mu acc (P.deref p) t - | `Tuple tl -> - fold_lefti (fun i acc t -> - loop under_ref under_mu acc (P.t_ind p i) t - ) acc tl - | `IntArray -> - List.fold_left (add_path false under_ref under_mu) acc [(P.len p);(P.ind p);(P.elem p)] - | `Mu t -> loop under_ref true acc p t - | `TVar -> acc - in - loop false false [] root ty - -(** state stepper for extending a path via type walking; see below *) -let path_step k p = match k with - | `Ind -> P.ind p - | `Length -> P.len p - | `Elem -> P.elem p - | `Tuple i -> P.t_ind p i - | `Ref -> P.deref p - | `Null -> P.to_null p - (* pseudo-path elements *) - | `Mu -> p - | `Summ -> p - | `Array -> p - -(** - Walk a type, using a callback mechanism to control the walk. - - This takes two functions, a stepper, and an processor. The processor is called - for the terminal locations in a type, namely: - + the length of an array - + the contents of an array - + the index of an arry - + the nullity of a reference - + any integer types - - At these terminal locations, the processor function [f] is called with the current state - (see below) and the accumulator. This accumulator is returned as the result of the walk. - - During the walk, during each step this function calls the [step] function to either update the state or short circuit the walk. - The initial state of the walk is given by the [st] argument. The behavior of the walk is described to the [step] function - by passing in the current state as the second argument, and a variant type with the following values, describing the the traversal. - - The step function may return a variant with three possible tags: - + `K, which has a function that expects the current type, the accumulator; the return value is immediately returned as the result of the walk (no further walking) - + `Cont st -> continue the walk with the new state [st] - + `ContWith (f,st) -> a combination of the above. The first element is a function as described in `K; the second element is as described in `Cont. The - function is first applied to give the new accumulator, and the walk continues with the new accumulator and new state. -*) -let rec walk_type ty step f st acc = - let continue ~acc mst k = - match mst with - | `K f_ -> f_ ty acc - | `ContWith (f,st) -> let acc = f ty acc in k st acc - | `Cont st -> k st acc - in - match ty with - | `Int -> f st acc - | `Ref (false, t) -> - let mst = step `Null st in - continue ~acc mst (fun st' acc -> - let acc = f st' acc in - let mst = step `Ref st in - continue ~acc mst (walk_type t step f) - ) - | `Ref (true,t) -> - let mst = step `Null st in - continue ~acc mst (fun st' acc -> - let acc = f st' acc in - let mst = step `Summ st in - continue ~acc mst (fun st' acc -> - let mst = step `Ref st' in - continue ~acc mst (walk_type t step f) - ) - ) - | `Tuple tl -> - fold_lefti (fun i acc t -> - let mst = step (`Tuple i) st in - continue ~acc mst (walk_type t step f) - ) acc tl - | `TVar -> acc - | `Mu t -> - let mst = step `Mu st in - continue ~acc mst (walk_type t step f) - | `IntArray -> - let mst = step `Length st in - continue ~acc mst (fun st' acc -> - let acc = f st' acc in - let mst = step `Array st in - continue ~acc mst (fun st acc -> - let mst = step `Ind st in - continue ~acc mst (fun st' acc -> - let acc = f st' acc in - let mst = step `Elem st in - continue ~acc mst f - ) - ) - ) - -(** Walk two paths in parallel according to the type ty. Unlike type_walk, this - walk function only calls the step function when: - + entering an unfolded ref (see [get_recursive_roots]) - + stepping under a ref - + stepping under a mu - + stepping into array memory - - In addition, this walker extends the state to automatically track the paths from in_ap and out_ap - during the walk of the type. The step function return type is the same as in [walk_type], however - it may additionally return [`ContPath (in_ap,out_ap, st)] which continues the walk in a new state [st], - but overriding the two current paths with in_ap and out_ap respectively. -*) -let parallel_type_walk in_ap out_ap ty step f st acc = - walk_type ty (fun k (in_ap,out_ap,st) -> - let user_step constr kind = - let mst = step kind (in_ap,out_ap) st in - match mst with - | `K f -> `K f - | `ContWith (f,st) -> `ContWith (f,(constr in_ap, constr out_ap, st)) - | `Cont st -> `Cont (constr in_ap,constr out_ap,st) - | `ContPath (in_ap,out_ap, st) -> `Cont (in_ap, out_ap, st) - in - let parallel_step constr = - `Cont (constr in_ap, constr out_ap, st) - in - match k with - | `Ref -> user_step P.deref `Ref - | `Mu -> user_step Fun.id `Mu - | `Array -> user_step Fun.id `Array - | `Ind -> parallel_step P.ind - | `Elem -> parallel_step P.elem - | `Length -> parallel_step P.len - | `Tuple i -> parallel_step ((Fun.flip P.t_ind) i) - | `Null -> parallel_step P.to_null - | `Summ -> user_step Fun.id `Summ - ) (fun (in_ap, out_ap, st) acc -> - f st in_ap out_ap acc - ) (in_ap, out_ap, st) acc - -(** A module for tracking the recursive relations attached to mu binders. - These recursive relations describe the relationship between values underneath - a mu binder and the values yielded by a one-level unfolding of that mu type. - - These are tracked separately from the monolithic program state relations -*) -module RecRelations = struct - - (** Mu chain is designed to track the access paths to elements under a mu - binder. In particular, a mu chain splits an access path into two components, - the path to the mu binder, and then the path to the value in question with respect - to the mu binder. - - MuChains may be converted easily to regular access paths with the to_concr method. - The most convenient way to construct one is to use the raw_stepper as the state stepper - for the [walk_type] function. - *) - module MuChain = struct - type t = (P.concr_ap * P.concr_ap option) [@@ocaml.warning "-34"] - let to_concr (s,p) = - Option.fold ~none:s ~some:(fun parent -> - P.root_at ~child:s ~parent - ) p - - let step_mu (s,p) = - assert (p = None); - (P.template, Some s) - - let get_mu_path (s,p) = - Option.map (fun p -> - (s,p) - ) p - - let raw_stepper k (s,p) = match k with - | `Mu -> `Cont (step_mu (s,p)) - | _ -> `Cont (path_step k s, p) - end - - (** Get the paths to all recursive roots. The _root_ of a recursive - type is the ref type constructor yielded by a one-level unfolding of a recursive type. - These ref constructors have the second element set to true, and this causes the `Summ step to be - emitted by the type walker. The paths to these ref types are collected, along with the types *) - let get_recursive_roots root ty = - walk_type ty (fun k s -> - match k with - | `Summ -> `K (fun ty acc -> (s,ty)::acc) - | _ -> `Cont (path_step k s) - ) (fun _ acc -> acc) root [] - - (** Get the paths to all mu binders in the type that is rooted in path [root] *) - let get_mu_binders root ty = - walk_type ty (fun k s -> - match k with - | `Mu -> `K (fun _ acc -> s::acc) - | _ -> `Cont (path_step k s) - ) (fun _ acc -> acc) root [] - - let mu_transposition_of ~ty path = - get_mu_binders P.template ty |> List.map (fun binders -> - P.root_at ~child:path ~parent:binders - ) - - let update_rel_map dst rel = - P.PathMap.add dst rel - - let set_recursive_rel dst rel ctxt = - { ctxt with recursive_rel = update_rel_map dst rel ctxt.recursive_rel } - - (** Because a mu relation may be freely duplicated between mu binders on copies, we - do not generate the paths with respect to a concrete root, but rather a template. - *) - let recursive_rel_for ~e_id ty dst ctxt = - let name = - Printf.sprintf !"%{P}-%d-%s" dst e_id "mu" - in - let args = type_to_paths P.template ty |> List.map (fun p -> p, path_type p) in - let rel = (name, args, ExprMu (e_id, dst, `Flow)) in - let ctxt = set_recursive_rel dst rel @@ { ctxt with relations = rel :: ctxt.relations } in - ctxt,rel - - (** Assuming a path [p] is given from a mu binder to some value, the mu transposition - for [p] gives all paths which point to the same relative position underneath all - mu-binders that appear after a one level unfolding of the enclosing mu binder. In other words, - after unfolding a recursive type, the mu transposition of [p] gives the same relative position - in all new instances of the mu binder in the unfolded type. - *) - let recursive_havoc_subst ty havoc_paths = - havoc_paths |> ListMonad.bind (fun p -> - p::(mu_transposition_of ~ty p) - ) |> List.mapi (fun i s -> (s, Ap (havoc_ap i s))) - - (** Add an implication with clauses given by [ante] to the mu relation given by [dst_rel]. - The dst_root is the concrete path of to the mu binder described by [dst_rel], it is - used to look up havoc information in the [by_havoc] map. This havoc information indicates - which elements in the unfolding must be havoced; this is computed by the recursive_havoc_subst. - *) - let impl_with_havoc ?out_shift ~by_havoc ~ante dst_root dst_rel ctxt = - let havoc_subst = - P.PathMap.find_opt dst_root by_havoc - |> Option.map (fun (ty,havoc_paths) -> - recursive_havoc_subst ty @@ P.PathSet.elements havoc_paths - ) - |> Option.value ~default:[] - in - let omit_paths = List.fold_left (fun acc (p,_) -> P.PathSet.add p acc) P.PathSet.empty havoc_subst in - { ctxt with impl = (ante, PRelation (dst_rel, havoc_subst, out_shift))::ctxt.impl; omit_set = merge_havoc_omit (get_relation_ident dst_rel) omit_paths ctxt.omit_set } - - (** Generate a fresh recursive relation for the mu binder at dst_root, and then generate an implication - from [ante] *) - let recursive_rel_with_havoc ~by_havoc ~e_id ~ante dst_root ty (ctxt : ctxt) = - let ctxt,rel = recursive_rel_for ~e_id ty dst_root ctxt in - impl_with_havoc ~by_havoc ~ante dst_root rel ctxt - - let%lm null_for_var ~e_id ~ty var ctxt = - get_recursive_roots (P.var var) ty - |> List.fold_left (fun ctxt (root,ty) -> - let args = type_to_paths P.template ty |> List.map (fun p -> p, path_type p) in - get_mu_binders root ty |> List.fold_left (fun ctxt bind -> - let name = Printf.sprintf !"null-%d-%{P}-%s" e_id bind "mu" in - let rel = (name, args, ExprMu (e_id, bind, `Null)) in - let grounding_subst = List.filter_map (fun (s, p) -> - match p with - | ZBool -> - let () = assert (P.is_nullity s) in - Some (s, BConst is_null_flag) - | _ -> None - ) args in - set_recursive_rel - bind rel - { ctxt with - relations = rel::ctxt.relations; - impl = ([], PRelation (rel, grounding_subst, None))::ctxt.impl - } - ) ctxt - ) ctxt -end - -(** A copy specification describes how to copy values from one location to another *) -type copy_spec = { - direct_copies: (P.concr_ap * P.concr_ap) list; (** copy concrete value v at path p1 to path at p2 *) - weak_copies: (P.concr_ap * P.concr_ap * fltype) list (** Copy a recursive type of type [t] rooted at [p1] to [p2] - NB that the [root] of a recursive type is the reference yielded by the - unfolding of a recursive type (all mu binders appear underneath - a reference type *) -} - -let empty_copy = { - direct_copies = []; - weak_copies = []; -} - -let add_weak src dst ty cs = { - cs with weak_copies = (src,dst,ty)::cs.weak_copies -} - -let add_direct src dst cs = { - cs with direct_copies = (src,dst)::cs.direct_copies -} - -let ccat a1 a2 = { - direct_copies = a1.direct_copies @ a2.direct_copies; - weak_copies = a1.weak_copies @ a2.weak_copies -} - -let compute_copies in_ap out_ap ty : copy_spec = - parallel_type_walk in_ap out_ap ty (fun k (in_ap,out_ap) () -> - match k with - | `Summ -> `K (fun ty -> add_weak in_ap out_ap ty) - | _ -> `Cont () - ) (fun () -> add_direct) () empty_copy - -(** Transforms a copy spec into a stream of atomic transfer specifications - Each atomic transfer specification indicates that a value described at path p - should be copied (strongly or weakly) to path q. The third component is either `Direct, - in which case the copy is "strong", of `Mu in which case the copy should be weak. The mu tag - has three elements: the path from the mu binder to the element being copied, the - source path to the enclosing mu binder, the destination path to the enclosing mu binder, - and the [ty] at the root of the recursive type instance (i.e., the type given after unfolding - the mu). -*) -let to_copy_stream { direct_copies; weak_copies } = - let l = List.map (fun (s,d) -> - s,d,`Direct - ) direct_copies - in - List.fold_left (fun acc (s,d,ty) -> - parallel_type_walk s d ty (fun k (in_ap,dst_ap) stack -> - match k with - | `Mu -> `ContPath (P.template, dst_ap, Some (in_ap, dst_ap)) - | `Summ | `Ref | `Array -> `Cont stack - ) (fun stack in_ap out_ap acc -> - let s = (in_ap, Option.map fst stack) in - let concr_in = RecRelations.MuChain.to_concr s in - let acc' = (concr_in, out_ap, `Direct)::acc in - Option.fold ~none:acc' ~some:(fun (in_mu,out_mu) -> - (concr_in,out_ap, `Mu (in_ap, in_mu,out_mu, ty))::acc - ) stack - ) None acc - ) l weak_copies - -(** Compute the positions of the mu binders transfered from source to destination as described - by [weak_copies]. This stream is later used to copy/transfer recursive relation information *) -let to_mu_copies { weak_copies; _ } = - ListMonad.bind (fun (s,d,ty) -> - RecRelations.get_mu_binders P.template ty - |> List.map (fun st -> - (st, - P.root_at ~child:st ~parent:s, - P.root_at ~child:st ~parent:d,ty) - ) - ) weak_copies - -let compute_patt_copies path patt ty = - let rec loop patt path ty acc = - match patt,ty with - | PNone,_ -> acc - | PVar v,`Int -> - add_direct path (P.var v) acc - | PVar v,ty -> - ccat (compute_copies path (P.var v) ty) acc - | PTuple t,`Tuple tl -> - fold_left2i (fun i acc p t -> - loop p (P.t_ind path i) t acc - ) acc t tl - | PTuple _,_ -> assert false - in - loop patt path ty empty_copy - -module Havoc = struct - (** This mu_havoc type is the type used for the by_havoc map described above *) - type mu_havoc = (fltype * P.PathSet.t) P.PathMap.t - - (** A type to track which paths are stable (i.e., not havoced) and those that are havoced by an ownership operation. *) - type havoc_state = { - havoc: P.PathSet.t; (** These paths are havoced *) - stable: P.PathSet.t; (** These paths are stable *) - mu_havoc: mu_havoc (** The havocing under a mu binder is as described above *) - } - - let empty_havoc_state = { - havoc = P.PathSet.empty; - stable = P.PathSet.empty; - mu_havoc = P.PathMap.empty; - } - - (** if flag [f] is true, then flag [p] as havoc, otherwise, treat it at stable *) - let add_havoc p f m = - if f then - { m with havoc = P.PathSet.add p m.havoc } - else - { m with stable = P.PathSet.add p m.stable } - - (** If [f] is havoced, then for the [binder] whose unfolded type is [ty], treat the mu path - as havoced *) - let add_mu_havoc ~binder ~ty p f m = - if f then - { m with mu_havoc = - P.PathMap.update binder (function - | None -> Some (ty, P.PathSet.singleton p) - | Some (ty',set) -> - let () = assert (ty = ty') in - Some (ty, P.PathSet.add p set) - ) m.mu_havoc - } - else - m - - let to_rec_havoc { mu_havoc; _ } = mu_havoc - - (** Compute the havoc state for a reference type ascribed to null *) - let%lm update_null_havoc ~e_id ~ty var ctxt = - let ref_havoc p = (OI.GenMap.find (OI.MGen e_id, p) ctxt.o_hints.OI.gen) = 0.0 in - let hstate = - walk_type ty (fun k (f,p) -> - let f = - match k with - | `Ref | `Array -> ref_havoc p - | _ -> f - in - `Cont (f, path_step k p) - ) (fun (f, p) acc -> - add_havoc p f acc - ) (false, P.var var) empty_havoc_state - in - { ctxt with havoc_set = P.PathSet.union hstate.havoc @@ P.PathSet.diff ctxt.havoc_set hstate.stable } -end - -module H = Havoc - -(** For a set of flows (represented by an output substitution), augment it with a rehavocing of all havoced - locations -*) -let augment_havocs flows havoc_set = - List.filter (fun (p,_) -> not (P.PathSet.mem p havoc_set)) flows |> P.PathSet.fold (fun p acc -> - (p, Ap (havoc_ap 0 p))::acc - ) havoc_set - -(** - Compute the the substitutions necessary for the copy spec as described below. - - This function returns a 4-ary tuple: (hstate, rename_copy, copy_flows, out_flows). - + hstate: the new havoc state (used in apply copies and elsewhere) describing the - havoc state after references are tranferred via the [copies]. The [sl] argument gives the ownership location - for the split operations. - + rename_copy and copy_flows: Used to implement the pass, weak copies described above. copy_flows renames the - the SOURCE location to the destination location; this is applied to the arguments of the input relation. Without - further renaming in the output, the result of this renaming becomes the new value of the location in the destination relation. - rename_copy renames the destination locations to dummy _pass_ copies. - + out_flows: these are substitutions describing the direct flow of values from inputs to outputs; to effect a copy of - a to b, we renamed b to a in the output, thereby ensuring it has the value of a as described by the input relation. -*) -let compute_flows ~sl copies ctxt = - let _,split_oracle = split_oracle sl ctxt in - to_copy_stream copies |> List.fold_left (fun (hstate,rename_copy,copy_subst,out_subst) (src,dst,k) -> - let (h_in,h_out) = split_oracle src dst in - let add_havoc p f ostate = - (* Trivial ownership transfers do not affect havoc status. These happen when a havoed value flows out from - under a reference constructor (although to be precise, we shouldn't say that a value is havoced, but a memory location - is). In that case, the havoc state of the input and output should be unchanged. *) - if f = `Trivial then ostate - else Havoc.add_havoc p (f = `Havoc) ostate - in - let hstate = add_havoc src h_in @@ add_havoc dst h_out hstate in - match k with - | `Direct -> hstate,rename_copy,copy_subst,(dst, Ap src)::out_subst - | `Mu (under_mu_path, s, d, ty) -> - let () = - assert (h_in <> `Trivial); - assert (h_out <> `Trivial) - in - let hstate = - (* recall that under_mu_path is the path relative to a mu binder, s and d are both the paths to the mu_binder, and ty is the unfolded type - of the mu binder - *) - Havoc.add_mu_havoc ~binder:s ~ty under_mu_path (h_in = `Havoc) hstate - |> Havoc.add_mu_havoc ~binder:d ~ty under_mu_path (h_out = `Havoc) - in - hstate,(dst, Ap (to_pass_ap src))::rename_copy,(src, Ap dst)::copy_subst, out_subst - - ) (Havoc.empty_havoc_state,[],[],[]) - -(** Copy the recursive relation for a mu binder at p to a mu binder at q. If there - is any havocing, we must generate a fresh relation and perform implications, otherwise - it suffices to symbolically copy the name *) -let copy_rel ~by_havoc ~e_id ~ty src_rel dst_root ctxt = - if P.PathMap.mem dst_root by_havoc then - RecRelations.recursive_rel_with_havoc ~by_havoc ~e_id ~ante:([ - PRelation (src_rel, [], None) - ]) dst_root ty ctxt - else - RecRelations.set_recursive_rel dst_root src_rel ctxt - -(** Apply the copies from [copies], including any high level flows from [flows]. - - The [havoc] flag determines whether all havoced locations should be re-havoced or only those freshly made 0. - This flag is set to true for calls and assignments to indicate uncertainty about which locations are havoced. - - [pre] is an optional list of clauses to add to the generated implication. The [in_rel] and [out_rel] - are the source and target relations. - *) -let%lm apply_copies ?out_rec_rel ~havoc:havoc_flag ~sl ?(flows=[]) ?pre copies in_rel out_rel ctxt = - let hstate,rename_copy,copy_flows,out_flows = compute_flows ~sl copies ctxt in - (* The mu binders that are copied *) - let mu_copies = to_mu_copies copies in - let havoc_set = ctxt.havoc_set in - (* update the havoc set according to the new havoc info computed by compute copies *) - let havoc_set = P.PathSet.union hstate.H.havoc @@ P.PathSet.diff havoc_set hstate.H.stable in - (* which paths should be havoc? *) - let applied_havocs = if havoc_flag then havoc_set else hstate.H.havoc in - let flows = List.mapi flow_to_subst flows in - (* the output substitution; augments direct copies with those produced by the high level flows optional argument - and the havoc information *) - let out_flows = augment_havocs (flows @ out_flows) applied_havocs in - let pre = - Option.value ~default:[] pre @ - (* if there are any weak copies, then we must use the duplication trick described with pass ap *) - if (List.compare_length_with copy_flows 0) > 0 then - [ - PRelation(in_rel, rename_copy, None); - PRelation(in_rel, rename_copy @ copy_flows, None) - ] - else - [ PRelation(in_rel, [], None) ] - in - let conseq = PRelation(out_rel, out_flows, None) in - let ctxt = - let by_havoc = H.to_rec_havoc hstate in - (* the src and dst elements here is the path to a mu binder in the source and destination respectively *) - List.fold_left (fun ctxt (_,src,dst,ty) -> - let () = - assert (P.PathMap.mem src ctxt.recursive_rel); - in - let e_id = - match sl with - | OI.SRet e_id - | OI.SBind e_id - | OI.SCall e_id -> e_id - in - let src_rel = P.PathMap.find src ctxt.recursive_rel in - (* why on earth are we copying the source relation to itself? Because if the source - ownership is dropped to 0, we have to havoc *) - let ctxt = copy_rel ~by_havoc ~e_id ~ty src_rel src ctxt in - match out_rec_rel with - | Some (direct_flow,_) -> - (* if the destination is a return value recursive relation, use that as the target of implication *) - P.PathMap.find_opt dst direct_flow - |> Option.fold ~none:ctxt ~some:(fun rel -> - RecRelations.impl_with_havoc ~by_havoc ~ante:[ - PRelation (src_rel, [], None) - ] dst rel ctxt - ) - | None -> copy_rel ~by_havoc ~e_id ~ty src_rel dst ctxt - ) ctxt mu_copies - in - let ctxt = - match out_rec_rel with - | None -> ctxt - | Some (_,extra_rec_flows) -> - (* copy the recursive relation from input arguments to output flows *) - List.fold_left (fun ctxt (src,rel) -> - let in_rel = P.PathMap.find src ctxt.recursive_rel in - { ctxt with impl = ([ PRelation(in_rel, [], None)], PRelation (rel, [], None))::ctxt.impl } - ) ctxt extra_rec_flows - in - { ctxt with havoc_set; impl = (pre, conseq)::ctxt.impl; omit_set = merge_havoc_omit (get_relation_ident out_rel) havoc_set ctxt.omit_set } - -module IdMap(M: Map.S) : sig - type t - val id_map : t - val find : M.key -> t -> M.key - val add : M.key -> M.key -> t -> t - val mem : M.key -> t -> bool - val empty : t -end = struct - type t = (M.key M.t) option - let empty = Some M.empty - let id_map = None - let add k v = function - | None -> failwith "Cannot add to infinite map" - | Some w -> Some (M.add k v w) - - let q f = fun k -> Option.fold ~none:true ~some:(f k) - let mem = q M.mem - - let l f = fun k -> Option.fold ~none:k ~some:(f k) - let find = l M.find -end - -module PPMap = IdMap(P.PathMap) - -(** - Before explaining this in detail, let's first review how we view recursive types. - - Before unfolding, suppose we have a recursive type Mu 'a.T. The collection of - terminal locations in T together describe an "element" of the recursive type. - Taking the view of recursive types being used for infinite data structures, all - components then form a single element of that data structure. For example, if we have - linked list, represented by Mu 'a.(int, 'a) ref then the null flag of the ref and the int - value collectively form an element. - - During inference, we always operated on a one-level unfolding of a recursive type, i.e., an occurence - of a mu binder must be under a ref constructor. So, returning to the list example, after a single - unfolding we have (int, Mu 'a.[(int, 'a) ref]) ref. The element outside of the mu binder is called the head - element; the intuition based on a linked list should provide some idea why. We also call - the path to the above type the _root_ of a recursive type, as all unfoldings of the above - type are related to the head element. In other words, recursive types are given their meaning - with respect to some head element. The above unfolded type has a second element under the mu binder, - we sometimes call this the summary element. - - Each element (under the mu binder or no) is represented by a [mu_frag] type, which is a fragment - of the entire recursive type. - - A recursive refinement is represented with multiple components. The relationship between the - concrete _head_ elements and all elements yielded by all future unfoldings of the type are - represented in the monolithic program relation. Returning to our linked list example, we have - that the value of the (concrete) integer in the head and all integer values in the tail/summary elements - are given by R(hd, tl). In the case with multiple occurrences of a type variable, as in the case of a binary - tree, the relationship is given by, e.g., R(hd, right, left), where _right_ represents all integer values reachable - in the right sub tree, and left stands in for all values reachable in the left subtree. - - The above encoding only gives the relationship between the single, concrete head element and all values in - child/tail/etc. elements. We also need to represent the relationship between the immediate - children/successor/etc. of the head and the values reachable from their children, the relationship between those children, etc. etc. - - Representing this relationship is the role of the recursive mu_relations described above. Each mu binder in a type - is associated with a relation between the element under that type and the elements given by a single unfolding of the recursive - type. For example, let us consider the recursive type describing a binary tree: - - (hd: int, left: mu 'a.[(hd: int, 'a, 'a) ref], right: mu 'a.[(hd: int, 'a, 'a) ref]) ref - - The two mu binders for left and right are both associated with a relation. - They represent the relationship between the _concrete_ elements underneath the mu binders (i.e., left->hd and right->hd) - and the elements reachable via future unfoldings (i.e., left->left->hd, left->right->hd, left->left->hd, right->left->hd, etc.) - - Notice that with the above type representation, any concrete values for left->hd and right->hd are still hypothetical; - currently, they are both still summarized under the mu binder. The recursive relations described above are - used during unfolding, when fresh, concrete values are chosen for the (now concrete) right->hd and left->hd locations. - This is discussed further in the documentation below. - - In short, recursive refinement is represented by a relation between concrete head elements and all elements - yielded by unfolding, plus relations describing the relationship between the concrete values yielded by some - unfolding and "future" values yielded by yet more unfolding. -*) -module RecursiveRefinements = struct - (** a mu fragment. Represented by the path to an element (head or summary) and the type from that fragment. *) - type mu_frag = P.path * fltype - - (** A complete representation of a recursive type. hd is the mu fragment of the head element, recurse is - a map from paths to a mu fragment. It is not necessarily the case that the path used as a key into the map is - the path in the mu fragment. In fact, almost (?) always the paths in the mu_frag will be a template - path describing a path relative to the root of the recursive type to a mu binder. *) - type rooted_mu = { - hd: mu_frag; - recurse: mu_frag P.PathMap.t; - } - - module Subst = struct - let rec concr_arg_to_string = function - | Ap p -> P.to_z3_ident p - | BConst b -> Bool.to_string b - | IConst i -> string_of_int i - | KeyedChoice (p,a1,a2) -> - Printf.sprintf "[? %s %s %s]" (P.to_z3_ident p) (concr_arg_to_string a1) (concr_arg_to_string a2) - - let to_string l = List.map (fun (p,a) -> - Printf.sprintf !"%{P} |-> %s" p @@ concr_arg_to_string a - ) l |> String.concat "; " |> Printf.sprintf "[ %s ]" - [@@ocaml.warning "-32"] - end - - (** Generate a mu template based on a recursive type root, i.e., a - reference type with the recursion flag set to true. The hd of the recursive - type is a mu fragment whose path is the template type. - - - The occurrences of the mu binders are both keyed by and represented - in the mu_fragments by paths relative to the recursive type root. - *) - let to_mu_template ty = - let recurse = walk_type ty (fun k ap -> - match k with - | `Summ -> `Cont ap - | `Mu -> `K (fun ty acc -> (ap,ty)::acc) - | _ -> `Cont (path_step k ap) - ) (fun _ acc -> acc) P.template [] - in - let recurse = List.fold_left (fun acc (p,ty) -> - P.PathMap.add p (p,ty) acc - ) P.PathMap.empty recurse - in - { - hd = (P.template, ty); - recurse - } - - (** - root a template created by the above at a concrete path. The keys in the recurse map remain - relative to the root of the recursive type, but the paths in fragment are concretized with respect to the - [path] argument. - *) - let root_template_at tmpl path = - let root_frag (p,ty) = - (P.root_at ~child:p ~parent:path, ty) - in - { - hd = root_frag tmpl.hd; - recurse = P.PathMap.map root_frag tmpl.recurse - } - - (** Takes a series of indexed substitutions and generates the proper - low-level relation argument substitutions. An indexed substitution - generates conditional substitutions, where the symbolic name substituted - for a relation argument is non-deterministically chosen by Z3. However, - the substitutions generated here are such that if - two substitutions are tagged with the the same index, then Z3 - must choose those two substitutions together. - *) - let to_multi_subst substs indexed_subst = - fold_lefti (fun i acc sub_group -> - let indexed_sub = List.fold_left (fun acc (ind,substs) -> - List.fold_left (fun acc (s,d) -> - P.PathMap.update s (fun curr -> - Some ((ind,d)::(Option.value ~default:[] curr)) - ) acc - ) acc substs - ) P.PathMap.empty sub_group in - let keyed_ap j = - (P.var @@ Printf.sprintf "star!%d!%d" i j) - in - let to_unary_subst sorted = - match sorted with - | [] -> assert false - | l -> - let l = List.sort (fun (k1,_) (k2,_) -> - k2 - k1 - ) l - in - let (_,hd) = List.hd l in - let tl = List.tl l in - fold_lefti (fun i acc (_,ap) -> - KeyedChoice (keyed_ap i, Ap ap, acc) - ) (Ap hd) tl - in - P.PathMap.fold (fun s dlist acc -> - (s,to_unary_subst dlist)::acc - ) indexed_sub acc - ) (List.map lift_copy substs) indexed_subst - - (** Compute a substitution from the source fragment to the destination fragment. - The generated substitution does NOT descend into mu binders so a substitution for - a head element will not include tail elements. - The skip ref flag indicates that the top level ref constructor should be skipped - during substitution, and the substitution from src should begin under the ref - constructor. This is used when generating a substitution from values in the - head element into local variables (for unfolding), or vice versa (for folding). - *) - let compute_frag_subst ?(acc=[]) ~skip_ref src_frag dst_frag = - let ty,src,dst = - if skip_ref then - match snd src_frag with - | `Ref (_,t) -> t,(P.deref @@ fst src_frag),(fst dst_frag) - | _ -> assert false - else - (snd src_frag),fst src_frag,fst dst_frag - in - let ty = match ty with - | `Mu t -> t - | _ -> ty - in - parallel_type_walk src dst ty (fun k _ () -> - match k with - | `Mu -> `K (fun _ acc -> acc) - | `Summ | `Array | `Ref -> `Cont () - ) (fun () in_ap out_ap acc -> - (in_ap, out_ap)::acc - ) () acc - - (** Generate a substitution map for instantiating the arguments of a recursive relation - with the concrete paths used in unfolding *) - let compute_mu_template_subst { hd = (path,ty); _ } = - parallel_type_walk P.template path ty (fun _ _ () -> `Cont ()) (fun () in_ap out_ap acc -> - (in_ap, Ap out_ap)::acc - ) () [] - - (** Compute a multi subst from the source template to the given head fragment - and tail fragments. The substitution of the head element is made with respect to - the the hfrag. The subsitutiion for the tail elements - is determined by the [tl] map; it maps from a (relative) path to each mu binder - in [src_templ] to a list of fragments to be multi-substituted into that place. - In other words, a substitution is generated such that Z3 nondeterministically - chooses symbolic name from one of the possibilities in the tail map. - However, by virtue of the mutli subst, if the choice is made for one path in - in target fragment a, all other paths under the same binder will choose - their symbolic name from a as well. - *) - let compute_mu_multi_subst ?(skip_hd_ref=false) src_templ ~hd:hfrag ~tl:tfrags = - let subst = compute_frag_subst ~skip_ref:skip_hd_ref src_templ.hd hfrag in - let indexed_subst = P.PathMap.fold (fun bind_path src_frag acc -> - let dst_frags = P.PathMap.find bind_path tfrags in - let sub_group = fold_lefti (fun i acc dst_frag -> - let s = compute_frag_subst ~skip_ref:false src_frag dst_frag in - (i,s)::acc - ) [] dst_frags in - sub_group::acc - ) src_templ.recurse [] - in - to_multi_subst subst indexed_subst - - (** Compute mu substitution sourc template to the hd mu fragment given by [hd]. - The choice of target for the tail fragments is given by the [tl] map argument, - which is keyed by the relative path to the mu binder in the source template. - *) - let compute_mu_subst src_templ ~hd:hfrag ~tl:tfrags = - let subst = compute_frag_subst ~skip_ref:false src_templ.hd hfrag in - P.PathMap.fold (fun path src_frag acc -> - let dst_frag = P.PathMap.find path tfrags in - compute_frag_subst ~skip_ref:false ~acc src_frag dst_frag - ) src_templ.recurse subst - |> List.map lift_copy - - (** Generate a substitution for a type, starting at src and dst, but not descending - under mu binders *) - let partial_subst src dst ty = - parallel_type_walk src dst ty (fun k _ () -> match k with - | `Mu -> `K (fun _ acc -> acc) - | _ -> `Cont () - ) (fun () in_ap out_ap acc -> (in_ap, out_ap)::acc) () [] - - let relation_subst rel subst = - PRelation (rel, subst, None) - - - (** Here we go! - - Some background. [root] is path to the root type of the recursive type, i.e., the type - at the root of the recursive type. target is the path to which the unfolded - type information should be transferred. All substitutions are made with respect - to [target], before generation the result paths are pre-processed - with [out_mapping]. This greatly simplifies the implementation to handle - unfolding which has a tuple pattern as the LHS; we unfold with respect to a - dummy root variable, and then translate from the dummy paths into the output - paths. Note that if a result path does not appear in out_mapping, it is - ommitted from the substitution. We refer to finding the final result of a substitution - (or omitting it) "normalization". - - Note that the target path is assumed to point to a variable of type T, where root - is of type ref T; i.e., target is assumed to hold the contents of root (after unfolding). - - The [with_havoc] flag determines if the assignment represented by the unfolding - should be treated as an ownership operation. This is almost always true, - with the exception of the dummy unfolding used by the aliasing operation. See - that code for details. - *) - let unfold_to ~with_havoc ?(out_mapping=PPMap.id_map) ~e_id ref_ty root target in_rel out_rel ctxt = - (** Normalize the paths to be havoced/stabilized *) - let normalize_ap p = - if PPMap.mem p out_mapping then - PPMap.find p out_mapping - else - p - in - let normalize_havoc pset = P.PathSet.map normalize_ap pset in - (** Normalize a substitution, walking into keyed choices as necessary *) - let rec deep_normalize = function - | Ap p -> Ap (normalize_ap p) - | BConst c -> BConst c - | IConst i -> IConst i - | KeyedChoice (p,a1,a2) -> - KeyedChoice (normalize_ap p, deep_normalize a1, deep_normalize a2) - in - let normalize_subst subst = - List.map (fun (s,d) -> - (s, deep_normalize d) - ) subst - in - - (** The type under the ref *) - let cont_ty = match ref_ty with - | `Ref (_,t) -> t - | _ -> assert false - in - - let source_path = root in - let template = to_mu_template ref_ty in - let source_mu = root_template_at template source_path in - let target_path = target in - - (* We unfold the relation input R(hd, tl) for a recursive linked list type as follows: - - R(hd, tl!pass) /\ R(hd, tl) /\ R(hd, tl->tl) /\ hd(tl, tl->tl) => Q(hd, tl!pass, hd, tl, tl->tl) - hd(x,y) => tl(x, y) - - R here encodes a relationship between hd and all tail elements, i.e. elements reachable from the tail pointer of hd. - Thus, in the precondition, R is used to relate tl, the (concrete) value chosen as the - new head element yielded by unfolding, and tl->tl, the (summary) value representing - all values reachable from tl. The relationship between tl and all values reachable - from its tail pointer is encoded with an application of hd(tl, tl->tl). Here hd encodes - the recursive refinement. - - Notice that we've said that the "pointwise" relationship between tl and all "further" - element is the same relationship that holds between all further heads and their - successors (hd => tl). - - NB: the weak copy from tl to the new concrete head. - - For a more complicated example, let us consider the unfolding of the sorted tree type. - - We have: - (hd:int, left: mu (hd:int, 'a, 'a), left: mu (hd:int, 'a, 'a) - - The type variable bindings and ref constructors are omitted to save space. - - After unfolding, there will be two new summary locations under left and right, - and one new concrete location under the same. The input relation is: - - R(hd, left->hd, right->hd) - - When unfolding we generate the following preconditions: - R(hd, left->hd, right->hd) /\ - R(hd, left->left->hd, right->hd) /\ - R(hd, left->right->hd, right->hd) /\ - R(hd, left->hd, right->right->hd) /\ ... - - That is, all possible combinations of substitutions for values (concrete or summary) - underneath the right and left labels in the source type. (A good question is why - we don't use the multi subst here, the answer is: I don't actually remember. I did - use it originally, but something about it didn't work. A mystery for you, dear reader, - to solve.) - - Then, we relate the new head locations (right->hd and left->hd) to the new summary - locations with the respective recursive refinements: - right(right->hd, right->left->hd, right->right->hd) and - left(left->hd, left->left->hd, left->right->hd) - - The recursive refinements have been named by the symbolic name of their mu binder location. - - The result is als follows: - - Q(hd, right->hd!pass, left->hd!pass, right->hd, right->left->hd, right->right->hd, - left->hd, left->left->hd, left->right->hd) - - (with the null flags omitted). The recursive refinements are propagated as well: - right => right->right - right => right->left - left => left->right - left => left->left - *) - - (* After unfolding, the location of the mu binders in the source type will become - roots of recursive type instances. These recursive type isntances will have exactly - the same type/structure as the source type being unfolded. This walks the content type - and generates a mu map, which is an association list from the relative paths of the - mu binders in the source type to the (concrete) output paths that will hold the unfolding - of those mu binders. *) - let mu_mapping = parallel_type_walk (P.deref @@ P.template) target_path cont_ty (fun k (in_ap,out_ap) () -> - match k with - | `Mu -> `K (fun _ acc -> - (in_ap, root_template_at template out_ap)::acc - ) - | _ -> `Cont () - ) (fun _ _ _ acc -> acc) () [] - in - - (* We now compute the R(hd, tl) /\ R(hd, tl->tl) and R(hd, left->hd, right->hd) /\ ... - substitution. The unfolding mu type here gives, for each mu binder in the source type, - the set of mu fragments corresponding to each element under that binder, i.e., - the newly concretized head and the (new) tail elements.*) - let unfolding_mu = List.fold_left (fun acc (src_mu, target_mu) -> - (* The target mu hd, and all possible fragments under all binders *) - let l = target_mu.hd :: (P.PathMap.bindings target_mu.recurse |> List.map snd) in - P.PathMap.add src_mu l acc - ) P.PathMap.empty mu_mapping - in - - let rec combination_loop l = - match l with - | [] -> [P.PathMap.empty] - | (src_mu,possibilities)::t -> - let comb = combination_loop t in - ListMonad.bind (fun mu -> - List.map (fun m -> - P.PathMap.add src_mu mu m - ) comb - ) possibilities - in - let combinatorial_subst = - P.PathMap.bindings unfolding_mu - |> combination_loop - (* Ultimately this yields a list of substitutions, each of which has a different possible - choice for element under a binder *) - |> List.map (fun m -> - (* Why the head? because this substitution is applied in the precondition, so we - want the relationship to be w.r.t the (concrete) source head elements) *) - compute_mu_subst source_mu ~hd:source_mu.hd ~tl:m - ) - in - - let recursive_substs = List.map (fun (in_ap, out_mu) -> - (* get the relation for the source mu binder, and then generate a substition to - instantiate the arguments of the recursive refinement with the newly concrete - head generated by the unfolding of the source binder and the new tail elements *) - let rel = P.PathMap.find (P.root_at ~child:in_ap ~parent:source_path) ctxt.recursive_rel in - (rel, compute_mu_template_subst out_mu) - ) mu_mapping - in - - (* These are the DIRECT flow from the concrete head to whatever output exists. Thus, we do - an output substitution map, as it's fine (and even necessary) for Z3 to infer - equality between the concrete head and the result of unfolding. *) - let output_flows = partial_subst (P.deref source_path) target_path cont_ty |> List.map (fun (s,d) -> - (normalize_ap d, Ap s) - ) - in - - (* now compute the havocs (if requested) *) - let all_havocs = - if with_havoc then - (* Here we directly track the ownership status of the containing paths rather - than retraversing a path at each terminal location in the path. - In addition, this allows us to track the havoc states under a mu binder - to determine if the mu relation must be havoced (see the Havoc documentation - and RecRelations module documentation for how we represent that havoc state) *) - parallel_type_walk (P.deref @@ source_path) target_path cont_ty (fun k (in_ap,out_ap) (ih,oh,parent_mu) -> - match k with - | `Summ -> failwith "Impossible?" - (* When passing under a mu binder, switch to tracking paths relative to the mu binder; - this makes computing the mu path to havoc much easier (we save the concrete - input paths to make reconstructing the source path trivial). Note that whether the - third element of the state is None or Some _ determines whether we are under a mu - binder. *) - | `Mu -> `ContPath (P.template,P.template,(ih,oh,Some (in_ap,out_ap))) - | `Ref | `Array -> - let concr_path = Option.fold ~none:in_ap ~some:(fun (src,_) -> - P.root_at ~child:in_ap ~parent:src - ) parent_mu - in - let (ih,oh) = OI.SplitMap.find (OI.SBind e_id,concr_path) ctxt.o_hints.OI.splits in - `Cont (ih = 0.0, oh = 0.0, parent_mu) - ) (fun (ih,oh,parent_mu) in_ap out_ap acc -> - - match parent_mu with - | None -> - (* then we have not reached the mu binder yet, these are all direct copies *) - H.add_havoc in_ap ih @@ H.add_havoc out_ap oh acc - | Some (mu_ap,dst_root_ap) -> - (* Get the concrete paths *) - let in_path = P.root_at ~child:in_ap ~parent:mu_ap in - let out_hd = P.root_at ~child:out_ap ~parent:dst_root_ap in - let acc = - H.add_havoc out_hd oh acc - |> H.add_havoc in_path ih - |> H.add_mu_havoc ~binder:mu_ap ~ty:ref_ty in_ap ih - in - (* However, if we havoc in the unfolding, then the mu element havoc - must be given with respect to the (new) location of the binders in - the unfolding (recall that the mu_ap is the mu binder in the source - type, and the dst_root_ap is now the root of a recursive type. so - below we compute the new (absolute) paths of the mu binders in the unfolded - type, and set the havoc state with respect to those binders. - *) - RecRelations.get_mu_binders P.template ref_ty |> List.fold_left (fun acc binder -> - let binder = normalize_ap @@ P.root_at ~child:binder ~parent:dst_root_ap in - H.add_mu_havoc ~binder ~ty:ref_ty out_ap oh acc - ) acc - ) (false, false, None) H.empty_havoc_state - else - H.empty_havoc_state - in - - let all_havocs = { all_havocs with havoc = normalize_havoc all_havocs.havoc } in - - let rec_havocs = H.to_rec_havoc all_havocs in - (* Here we generate the hd => tl or right => right->right implications *) - (* Again, due to duplication, under each mu binder in the source, we compute the - new locations of the mu binders in the (unfolded) output, and copy the - binder from the source to the target. Note that if the output binder - does not actually appear in the normalization map, no copying takes place *) - let ctxt = List.fold_left (fun ctxt (binder_path,target_mu) -> - let source_mu = (P.root_at ~child:binder_path ~parent:source_path) in - let src_rel = P.PathMap.find source_mu ctxt.recursive_rel in - let ctxt = copy_rel ~by_havoc:rec_havocs ~e_id src_rel ~ty:ref_ty source_mu ctxt in - let dst_root = fst target_mu.hd in - RecRelations.get_mu_binders P.template ref_ty |> List.fold_left (fun ctxt binder -> - let target_mu = P.root_at ~child:binder ~parent:dst_root in - if PPMap.mem target_mu out_mapping then - let target_mu = PPMap.find target_mu out_mapping in - copy_rel ~by_havoc:rec_havocs ~e_id ~ty:ref_ty src_rel target_mu ctxt - else - ctxt - ) ctxt - ) ctxt mu_mapping - in - - let pre_flows = [ - rel ~ty:ZBool @@ mk_relation (Ap (P.to_null source_path)) "=" (BConst is_nonnull_flag); - relation_subst in_rel []; - ] @ List.map (fun (rel, subst) -> - PRelation (rel, normalize_subst subst, None) - ) recursive_substs - @ List.map (fun subst -> - PRelation (in_rel, normalize_subst subst, None) - ) combinatorial_subst - in - let output_subst = augment_havocs output_flows all_havocs.havoc in - - let unfold_impl = (pre_flows @ null_pre out_rel output_subst, PRelation (out_rel, output_subst, None)) in - let havoc_set = P.PathSet.union ctxt.havoc_set all_havocs.havoc in - { ctxt with impl = unfold_impl::ctxt.impl; havoc_set; omit_set = merge_havoc_omit (get_relation_ident out_rel) havoc_set ctxt.omit_set } - - type ap_subst = (P.concr_ap * P.concr_ap) list - - (* This copy policy will be documented as soon as I remember how on earth it works *) - type copy_policy = - | Weak - | Custom of { rename_src: ap_subst; rename_weak: ap_subst; rename_out: ap_subst } - - (** - Folds the path pointed to by target_root into the recursive type rooted at src_root. The [target_root] should have type [ref_ty] which is a root of a recursive - type, i.e., a reference type constructor with the recursion flag set to true. The source root meanwhile, should refer to a type which is the _content type_ - of ref_ty after a one level unfolding of the recursive types in ref_ty. - - The havoc status of the paths before and after folding are determined by the oracle - argument. havoc_ext is an optional function for extending the computed - havoc state. It is used in the aliasing. - - [rec_ext] is an (optional) map from mu binders in the destination to "recursive - implication extensions". These recursive implication extensions are applied when - the recursive refinement is being generated for the mu binder at the given path. - - An extension is a 2-ary tuple where the first element is a substitution to apply - when generating the implication for the head element and the immeidate successors. - Thus, it can turn R(hd, tl, x) => hd(hd, tl) into R(hd, tl, hd) => hd(hd, tl). This - is used when you know some other symbolic variable in scope must have the same - value as these arguments, i.e., during an alias. - - The second element is a map concrete paths mu binders in the destination to a list - of clauses. This is used if you know that the invariants satisfied by a mu binder in the - source type must be also satisfy another relationsio, i.e., again during aliasing. - *) - let fold_to ~oracle:(dst_oracle,src_oracle) ~e_id ~copy_policy ?rec_ext ?havoc_ext ref_ty (src_root: P.concr_ap) (target_root : P.concr_ap) in_rel out_rel ctxt = - let src_ap = src_root in - (* The content type. The type of target_root should be the result of a deep_type_normalization of this *) - let cont_ty = match ref_ty with - | `Ref (_,t) -> t - | _ -> assert false - in - let mu_template = to_mu_template ref_ty in - let target_ap = target_root in - let target_mu = root_template_at mu_template target_root in - (* This mu map in some sense inverts the role served by the similarly named variable in the unfold function. - - This produces a map from (relative) mu binders paths to the roots of [unfolded] types to be folded into the - given mu binder. - - For example, suppose we want to fold (x, (hd, tl)) into (hd', mu (tl', 'a)). Then we have to - generate the constraint: - - R(x, hd, tl) => Q(x, [? hd' tl']) - - In otherwise, the (currently) concrete head element is collapsed with its own summary pieces. - As a result any relation Q(x, tl'') derived by Z3 must be a relationship that holds between x and hd, and - between x and any values reachable from hd's tail, i.e. tl. This matches the intuition given for the representation - of recursive refinements given in unfold. - *) - let mu_map = parallel_type_walk (P.deref @@ P.template) src_root cont_ty (fun k (in_ap, out_ap) () -> - match k with - | `Mu -> `K (fun _ acc -> - (in_ap, root_template_at mu_template out_ap)::acc - ) - | _ -> `Cont () - ) (fun () _ _ acc -> acc) () [] - in - - (* This associates with each mu binder identifying a summary element in the folded target the elements (concrete and - otherwise) in the unfolded source. *) - let fold_up_map = List.fold_left (fun acc (out_binder,input_mu) -> - let l = input_mu.hd :: (P.PathMap.bindings input_mu.recurse |> List.map snd) in - P.PathMap.add out_binder l acc - ) P.PathMap.empty mu_map - in - - (* This generates a multi substitution; the head element is given by the (conrete) elements reachable from the src ap *) - let fold_up_subst = compute_mu_multi_subst ~skip_hd_ref:true target_mu ~hd:(src_ap, cont_ty) ~tl:fold_up_map in - - (* Determines how the copying of the tail elements from the input relation to the output. By default, - the strategy is to weakly copy the summary locations from the source mu binders to the output. - - Returning to the example above, assuming x, hd, and tail do not go out of scope, we will actually have - R(x, hd, tl) /\ R(x, hd, tl!pass) => Q(x, hd, tl!pass, x, [? hd tl]) - *) - - let (rename_src,rename_weak,rename_out) = - match copy_policy with - | Weak -> - let weak = ListMonad.bind (fun (_,mu) -> - compute_copies (fst mu.hd) (fst mu.hd) (snd mu.hd) |> to_copy_stream |> List.filter_map (fun (a,b,k) -> - if k = `Direct then - None - else - Some (a, to_pass_ap b) - ) - ) mu_map - - in - ([], weak, weak) - | Custom { rename_src; rename_weak; rename_out } -> (rename_src, rename_weak, rename_out) - in - - (* handles a terminal locations. Look up the concrete path in the given havoc oracle. - The state is a mu chain which is managed by the MuChain.raw_stepper. By the invariant, the optional mu - path is Some only when under a mu binder; when it is we also update the mu havoc. - *) - let handle_term oracle st acc = - let full_path = RecRelations.MuChain.to_concr st in - let flg = oracle full_path in - let acc = H.add_havoc full_path flg acc in - Option.fold ~none:acc ~some:(fun (p,binder) -> - H.add_mu_havoc ~binder ~ty:ref_ty p flg acc - ) @@ RecRelations.MuChain.get_mu_path st - in - let hstate = - walk_type cont_ty RecRelations.MuChain.raw_stepper (handle_term dst_oracle) (P.deref target_root, None) H.empty_havoc_state - |> walk_type (deep_type_normalization cont_ty) RecRelations.MuChain.raw_stepper (handle_term src_oracle) (src_ap, None) - in - - let by_havoc = H.to_rec_havoc hstate in - (* Now we compute the recursive refinements for the new mu binders *) - let ctxt = List.fold_left (fun ctxt (dst_binder,src_folded) -> - (* The absolute path of the output mu binder *) - let target_mu = P.root_at ~child:dst_binder ~parent:target_ap in - (* rel is the new element *) - let ctxt,rel = RecRelations.recursive_rel_for ~e_id ref_ty target_mu ctxt in - let with_havoc ante ctxt = - RecRelations.impl_with_havoc ~ante ~by_havoc target_mu rel ctxt - in - let (hd_subst,conj_ind) = - Option.bind rec_ext (P.PathMap.find_opt dst_binder) - |> Option.value ~default:([], P.PathMap.empty) - in - let ctxt = - (* Get the absolute paths of the mu binders under the recursive type - being folded into mu binders rooted at target_mu *) - RecRelations.get_mu_binders (fst src_folded.hd) (snd src_folded.hd) - |> List.fold_left (fun ctxt mu_path -> - (* for each such path, get the relation describing the - relationship under the mu binder *) - let input_rec = P.PathMap.find mu_path ctxt.recursive_rel in - let input_rec = PRelation (input_rec, [], None) in - (* we also grab an optional recursive relation as specified by the conj_ind which - itself was read from the rec_ext. *) - (* add that any relationship admitted by this "sub" mu relation is admitted by - the folded relation. *) - let ante = input_rec :: (Option.to_list @@ P.PathMap.find_opt mu_path conj_ind) in - (* with havoc applies the implication describe above, providing all the - necessary common arguments to impl_with_havoc *) - with_havoc ante ctxt - ) ctxt - in - (* in addition, say that the relationship between the (to be folded) head - and it's successor/tail elements (as described by the monolithic relation) are - also admitted by the new recursive relation *) - let subst = compute_mu_template_subst src_folded |> List.map (function - | (src, Ap dst) -> (dst, Ap src) - | _ -> assert false - ) in - with_havoc [ PRelation (in_rel, subst @ hd_subst, None) ] ctxt - ) ctxt mu_map - in - (* as in the unfold, copy the mu binders from the source to themselves; this copy - is necessary to havoc the input relations *) - let ctxt = List.fold_left (fun ctxt (_, src_folded) -> - RecRelations.get_mu_binders (fst src_folded.hd) (snd src_folded.hd) - |> List.fold_left (fun ctxt src_mu -> - let src_rel = P.PathMap.find src_mu ctxt.recursive_rel in - copy_rel ~by_havoc ~e_id ~ty:ref_ty src_rel src_mu ctxt - ) ctxt - ) ctxt mu_map - in - - let hstate = match havoc_ext with - | Some f -> - let havoc,stable = f ~havoc:hstate.havoc ~stable:hstate.stable in - { hstate with havoc; stable } - | None -> hstate - in - let havoc_set = P.PathSet.union hstate.havoc @@ P.PathSet.diff ctxt.havoc_set hstate.stable in - - let output_flows flow_subst = - augment_havocs (flow_subst @ List.map lift_copy rename_out) havoc_set - in - let ante = [ - PRelation (in_rel, List.map lift_copy rename_weak, None); - rel ~ty:ZBool @@ mk_relation (Ap (P.to_null target_root)) "=" (BConst is_nonnull_flag); - PRelation (in_rel, List.map lift_copy rename_src, None) - ] in - let fold_impl = - let flows = output_flows fold_up_subst in - let null_ante = null_pre out_rel fold_up_subst in - let conseq = relation_subst out_rel flows in - (ante @ null_ante, conseq) - in - { ctxt with impl = (fold_impl :: ctxt.impl); havoc_set; omit_set = merge_havoc_omit (get_relation_ident out_rel) havoc_set ctxt.omit_set } -end - - -(* ty is the type of the src variable (including the reference constructor *) -let%lm do_unfold_copy ~with_havoc ?(out_mapping=PPMap.id_map) ~e_id src_var dst_var (ref_ty: fltype) in_rel out_rel ctxt = - RecursiveRefinements.unfold_to ~e_id ~with_havoc ~out_mapping ref_ty (P.var src_var) (P.var dst_var) in_rel out_rel ctxt - -(* folded ty is the type under the reference after the fold, i.e., the - type of in_ap after folding. - out_ap is under a ref, i.e. the location in memory where we are folding to. - *) -let%lm do_fold_copy ~e_id in_ap out_ap folded_ty in_rel out_rel ctxt = - let dst_oracle = havoc_oracle ctxt (OI.MGen e_id) in - let ctxt,so = split_oracle (OI.SBind e_id) ctxt in - let src_oracle p = - let (f1,_) = so p p in - f1 = `Havoc - in - RecursiveRefinements.fold_to ~oracle:(dst_oracle,src_oracle) ~e_id ~copy_policy:RecursiveRefinements.Weak folded_ty (P.var in_ap) (P.var out_ap) in_rel out_rel ctxt - -let apply_identity_flow ?pre = add_relation_flow ?pre [] - -let const_assign lhs const in_rel out_rel = - let%bind havoc_state = get_havoc_state in - let flows = P.PathSet.elements havoc_state |> - List.fold_left (fun acc p -> - Havoc p::acc - ) [ Const (lhs,const) ] - in - add_relation_flow flows in_rel out_rel >> - set_havoc_state ~rel:(get_relation_ident out_rel) havoc_state - -let vderef v = P.deref @@ P.var v - -(** This simply determines whether a path needs a pre version. - Constant locations do not need a pre version *) -let rec is_pre_path p = - match P.tail p with - | None -> false - | Some `Deref -> true - | Some `Len - | Some `Proj _ -> is_pre_path @@ P.parent p - | Some _ -> false - -(** the mega argument tuple records the following information - + the access paths havoced after the call - + the access paths stable after the call - + the argument substitutions to apply to the function input relations - + the argument substitutions to apply to the function output relation - + the substitutions to apply to the call substitution, which is used in - the output to compute in/out summaries (see below) - - actual is the path of the argument, formal is the path of the argument. -*) -let bind_arg ~fn ~cid ~e_id (havoc,stable,in_bind,out_bind,pre_bind) actual formal ty = - let copies = compute_copies actual formal ty in - let direct_copies = to_copy_stream copies in - let%bind split_oracle = split_oracle (SCall e_id) in - let%bind fun_info = get_function_info fn in - - (* Here we compute the set of ID paths, i.e., paths - that must NOT change during execution of the function. These - are access paths that are not havoced by splitting the argument. - We exploit this to conclude that the value before/after execution must be unchanged, - giving extra precision. - *) - let hstate = List.fold_left (fun acc (src,dst,k) -> - let (havoc,dst_havoc) = split_oracle src dst in - let acc = - match k with - | `Mu (under_mu_path, _, dst_binder, ty) -> - (* here we save whether the destination for the mu relation is to be havoced. - This is used when we perform the implication for mu_relations into - the function; we have to havoc those explicitly during the implication. - *) - H.add_mu_havoc ~ty ~binder:dst_binder under_mu_path (dst_havoc = `Havoc) acc - | _ -> acc - in - H.add_havoc src (havoc = `Havoc) acc - ) H.empty_havoc_state direct_copies - in - let id_paths = hstate.H.stable in - - (* Here we generate the substitution maps for the functions input relations. For - input arguments that are direct (not weak) copies and which are pre paths (Those - in mutable storage) are also substituted as pre paths. - - To explain pre paths: - To track input and output behavior, we introduce shadow values that - represent the values of all mutable, concrete locations at function entry. These - are treated as dummy variables that are totally opaque to the program, but which are - threaded through with the rest of the state. - - For a function which mutates a pointer argument, we will have f-in(x->*, x->*!pre) - representing the value of x->* at method entry, which is tranformed, interrogated, etc. - by the function, and the pre path x->*!pre which is equal to x->* at entry, but is - immutable through program execution. - - Accordingly, when generating the input relation substitutions, if the formal - argument is y we would generate the substitution [y->*/x->*;y->*/x->*!pre]. - *) - let in_bind = List.fold_left (fun in_bind (src,dst,k) -> - let in_bind = (dst, Ap src)::in_bind in - if is_pre_path src && (k = `Direct) then - (P.pre dst, Ap src)::in_bind - else - in_bind - ) in_bind direct_copies - in - - let%bind havoc_out_oracle = gen_oracle (OI.MOut fn) in - - (* dst is the access path for the argument *) - let (havoc,stable,out_bind,pre_bind) = List.fold_left (fun (havoc,stable,out_bind,pre_bind) (src,dst,k) -> - let is_pre = is_pre_path src && k = `Direct in - let is_id = P.PathSet.mem src id_paths in - (* just because the output path is havoced, if we have some residual ownership - in the argument path, then the value itself is immutable and NOT havoced *) - let havoc_out = havoc_out_oracle dst && (not is_id) in - let (havoc,stable) = - if havoc_out then - (P.PathSet.add src havoc),stable - else - havoc,(P.PathSet.add src stable) - in - - let out_copy = (dst,Ap src) in - let pre_path = P.map_root (fun p -> p ^ "!call") src in - let pre_copy = (src,Ap pre_path) in - - (* to understand what's happening below, let the input state with a single argument x be IN(x). - The successour state is SUCC(x) and the output predicate is OUT. OUT may (or may not) have - a pre argument, with formal names $0 and $0!pre *) - - (* now compute the out flows, let's do the easy case first *) - if (not is_pre) && is_id then - (* Then this is an argument that may not change during execution and for which we do not track - pre-states then no pre-substitutions are necessary *) - - (* Then we want to do the following IN(x) /\ OUT(x) => SUCC(x), i.e. the values are all the same. - out copy is $0 -> x *) - (havoc,stable,out_copy::out_bind,pre_bind) - else if (not is_pre) then - (* this argument may change during execution, and we do not track pre-states. Then create a fresh - name for the input value (using pre) *) - - (* Then we have IN(x') /\ OUT(x) => SUCC(x). Pre_copy here renames x in IN to x' - and out_copy is $0 -> x' *) - (havoc,stable,out_copy::out_bind,pre_copy::pre_bind) - else if is_pre && is_id then - (* we track pre states but the argument won't change during execution. - So constrain the pre-value to be equal to the output argument (do not rename pre) *) - - (* Then we have IN(x) /\ OUT(x,x) => SUCC(x) out_copy is as above, and the second substitution gives $0!pre -> x *) - (havoc,stable,(P.pre dst,Ap src)::out_copy::out_bind,pre_bind) - else - (* finally, we track pre states, and the value may change. - rename the name in the prestate to be pre, - and rename the pre path in the output *) - - (* Then we have IN(x') /\ OUT(x, x') => SUCC(x) - - Our out substitutions are $0!pre -> x' and $0 -> x, and our precopy renames x in IN to x' *) - (havoc,stable,(P.pre dst,Ap pre_path)::out_copy::out_bind,pre_copy::pre_bind) - ) (havoc,stable,out_bind,pre_bind) direct_copies - in - let mu_copy = to_mu_copies copies in - let%lm update_in_rel susp (_,src_mu, dst_mu, _) ctxt = - let ctxt,() = susp ctxt in - let in_rel = P.PathMap.find src_mu ctxt.recursive_rel in - let out_rel = P.PathMap.find dst_mu fun_info.in_recursive_rel in - RecRelations.impl_with_havoc ~out_shift:cid ~by_havoc:hstate.mu_havoc ~ante:[ - PRelation (in_rel, [], None) - ] dst_mu out_rel ctxt - in - let%bind () = List.fold_left update_in_rel (return ()) mu_copy in - let%lm update_out_rel susp (_, src_mu, dst_mu, ty) ctxt = - let ctxt,() = susp ctxt in - let out_rel = P.PathMap.find dst_mu fun_info.out_recursive_rel in - (* Note: we don't try to use information from the source relation. It's really - hard and annoying to figure out which paths are havoced and what not. *) - (* TODO: maybe we should conjoin if the paths are not ownership havoced. This is *really* - hard and annoying *) - let ctxt,result_rel = RecRelations.recursive_rel_for ~e_id ty src_mu ctxt in - { ctxt with impl = ([ PRelation (out_rel, [], Some cid) ], PRelation (result_rel, [], None))::ctxt.impl } - in - let%bind () = List.fold_left update_out_rel (return ()) mu_copy in - return (havoc,stable,in_bind,out_bind, pre_bind) - -(* Bind the return w.r.t some pattern. Fairly straighforward if you read the above *) -let bind_return ~fn ~e_id ~cid out_patt ret_type = - let copies = compute_patt_copies P.ret out_patt ret_type in - let direct_copies = to_copy_stream copies in - let%bind havoc_oracle = gen_oracle @@ MRet fn in - let havoc_ret = List.fold_left (fun acc (src,dst,_) -> - if havoc_oracle src then - P.PathSet.add dst acc - else - acc - ) P.PathSet.empty direct_copies in - let%bind fun_info = get_function_info fn in - let%bind () = - List.fold_left (fun m_unit (_,src_mu,dst_mu,ty) -> - (fun ctxt -> - let ctxt,() = m_unit ctxt in - let ctxt,rel = RecRelations.recursive_rel_for ~e_id ty dst_mu ctxt in - let return_rel = P.PathMap.find src_mu fun_info.out_recursive_rel in - { ctxt with impl = ([ PRelation(return_rel, [], Some cid) ], PRelation(rel, [], None))::ctxt.impl },() - ) - ) (return ()) (to_mu_copies copies) - in - return (List.map (fun (s,d,_) -> (s,Ap d)) direct_copies,havoc_ret) - -let bind_args ~e_id out_patt call_expr curr_rel body_rel = - let callee = call_expr.callee in - let%bind callee_type = get_function_type callee in - let%bind in_rel = get_in_relation callee in - let%bind out_rel = get_out_relation callee in - let args = call_expr.arg_names in - let%bind (havoc,stable,in_bindings,out_bindings,pre_bindings) = fold_left2i (fun i acc arg_name arg_ty -> - let%bind acc = acc in - bind_arg ~fn:callee ~cid:call_expr.label ~e_id acc (P.var arg_name) (P.arg i) arg_ty - ) (return (P.PathSet.empty,P.PathSet.empty,[],[],[])) args callee_type.arg_types - in - let%bind (return_bindings,havoc_bind) = bind_return ~fn:callee ~e_id ~cid:call_expr.label out_patt callee_type.ret_type in - let%bind havoc_state = get_havoc_state in - let havoc_state = P.PathSet.union havoc_bind @@ P.PathSet.union (P.PathSet.diff havoc_state stable) havoc in - - let havoc_subst = - P.PathSet.elements havoc_state |> List.mapi (fun i p -> - (p,Ap (havoc_ap i p)) - ) - in - begin%m - add_implication [ - PRelation (curr_rel,[],None) - ] @@ PRelation (in_rel,in_bindings, Some call_expr.label); - add_implication [ - (* the copy of the pre relation, which is used to provide information about the - relationships of the values at input which are the values of the pre arguments *) - PRelation (curr_rel,pre_bindings,None); - PRelation (out_rel,return_bindings @ out_bindings,Some call_expr.label) - ] @@ PRelation (body_rel,havoc_subst,None); - set_havoc_state ~rel:(get_relation_ident body_rel) havoc_state - end - -let process_intrinsic out_patt call_expr intr_type curr_rel body_rel = - (* check pre-conditions *) - (* TODO: factor this out *) - let arg_names = fold_lefti (fun i acc arg -> - StringMap.add (P.arg_name i) arg acc - ) StringMap.empty call_expr.arg_names - in - let type_fail () = failwith @@ "Cannot handle non-integer typed args in built in functions: " ^ call_expr.callee in - let%bind () = - miteri (fun i t -> - let nu_arg = P.var (List.nth call_expr.arg_names i) in - match t with - | RT.Int r -> - lift_refinement ~map:(P.map_root (fun n -> SM.find n arg_names)) ~nu_arg r - |> miter @@ add_implication [ PRelation (curr_rel,[],None) ] - | _ -> type_fail () - ) intr_type.RT.arg_types - in - match out_patt with - | PNone -> return () - | PVar v -> - let pre = - match intr_type.RT.result_type with - | Int r -> lift_refinement ~map:(P.map_root (fun n -> SM.find n arg_names)) ~nu_arg:(P.var v) r - | _ -> type_fail () - in - apply_identity_flow ~pre curr_rel body_rel - | PTuple _ -> type_fail () - - -let process_call ~e_id out_patt call_expr curr_rel body_rel = - let%bind st = copy_state in - if StringMap.mem call_expr.callee st.bif_types then - process_intrinsic out_patt call_expr (StringMap.find call_expr.callee st.bif_types) curr_rel body_rel - else - bind_args ~e_id out_patt call_expr curr_rel body_rel - -let add_indexing_assertion arr_ap ind_ap relation = - let array_len = P.len arr_ap in - let%bind () = add_implication [ PRelation(relation,[],None) ] @@ NamedRel ("valid-ind",[Ap ind_ap; Ap array_len ]) in - add_implication [ PRelation(relation,[],None) ] @@ rel ~ty:ZInt (mk_relation (Ap array_len) ">" (IConst 0)) - -let nonnull_flow p = NullConst (P.to_null p, is_nonnull_flag) - -let apply_patt ~e_id tyenv patt rhs = - match patt,rhs with - | _,Call c -> process_call ~e_id patt c - | PNone,_ -> apply_identity_flow ?pre:None - | _,Var s -> - let path = P.var s in - apply_copies ~havoc:false ~sl:(OI.SBind e_id) @@ compute_patt_copies path patt @@ path_simple_type tyenv path - | PVar s,Const n -> add_relation_flow [ Const (P.var s,n) ] - | PVar s,Mkref RNone -> - add_relation_flow [ Havoc (vderef s); (nonnull_flow @@ P.var s) ] - | PVar s,Mkref (RInt n) -> - add_relation_flow [ Const (vderef s,n); (nonnull_flow @@ P.var s) ] - | PVar s,Mkref (RVar v) -> - apply_copies ~flows:[ (nonnull_flow @@ P.var s) ] ~havoc:false ~sl:(OI.SBind e_id) @@ compute_copies (P.var v) (vderef s) @@ path_simple_type tyenv (P.var v) - - | _,Deref v -> - let copies = compute_patt_copies (vderef v) patt @@ path_simple_type tyenv (vderef v) in - (fun ir orel -> - add_null_check ir (P.var v) >> - apply_copies ~pre:[ rel ~ty:ZBool @@ mk_relation (Ap (P.to_null @@ P.var v)) "=" (BConst is_nonnull_flag) ] ~havoc:false ~sl:(OI.SBind e_id) copies ir orel - ) - - | PVar t,Tuple tl -> - let tup_root = P.var t in - let flows,copies = fold_lefti (fun i (flows,copies) r -> - let tgt_ap = P.t_ind tup_root i in - match r with - | RNone -> (Havoc tgt_ap)::flows,copies - | RInt n -> Const (tgt_ap,n)::flows,copies - | RVar v -> - let src_type = path_simple_type tyenv @@ P.var v in - flows,ccat (compute_copies (P.var v) tgt_ap src_type) copies - ) ([],empty_copy) tl - in - apply_copies ~havoc:false ~sl:(OI.SBind e_id) ~flows copies - - | PTuple _,Tuple _ -> assert false - | PTuple _,_ -> assert false - | PVar v,Nondet None -> add_relation_flow [ Havoc (P.var v) ] - | PVar v,Nondet (Some r) -> - let refinement = lift_refinement ~nu_arg:(P.var v) r in - apply_identity_flow ~pre:refinement - - | PVar v,MkArray len_var -> - (fun in_rel out_rel -> - let%bind () = add_assert (Ap (P.var len_var)) ">=" (IConst 0) in_rel in - let array_root = (P.var v) in - let l = P.var len_var in - let ind = P.ind array_root in - let elem = P.elem array_root in - let valid_sym_ind = [ - NamedRel ("valid-ind", [Ap ind; Ap l ]) - ] in - add_relation_flow ~pre:valid_sym_ind [ Const (elem, 0); Copy (l,P.len array_root) ] in_rel out_rel) - | PVar v,LengthOf arr -> - add_relation_flow ?pre:None [ Copy (P.len (P.var arr), P.var v) ] - | PVar v,Read (arr,ind) -> - (fun in_rel out_rel -> - let arr_ap = P.var arr in - let ind_ap = P.var ind in - - let array_ind = P.ind arr_ap in - let elem_ap = P.elem arr_ap in - let%bind () = add_indexing_assertion arr_ap ind_ap in_rel in - let copy_pre_cond = PRelation (in_rel,[ - (array_ind, Ap ind_ap); - (elem_ap, Ap (P.var v)) - ], None) in - let identity_cond = PRelation (in_rel, [], None) in - add_implication [ copy_pre_cond; identity_cond ] @@ PRelation (out_rel,[],None)) - | PVar v,Null -> - (fun in_rel out_rel -> - let%bind null_types = get_bound_type e_id in - let paths = type_to_paths (P.var v) null_types in - let flows = List.map (fun p -> - if P.is_nullity p then - NullConst (p, is_null_flag) - else - Havoc p - ) paths in - RecRelations.null_for_var ~e_id ~ty:null_types v >> - H.update_null_havoc ~e_id ~ty:null_types v >> - add_relation_flow ?pre:None flows in_rel out_rel) - | PVar _, Cons _ -> assert false - | PVar _, Nil -> assert false - -let relation_name ((e_id,_),expr) ctxt = - let prefix = Printf.sprintf "%s-%d-" (Option.value ~default:"main-fn" ctxt.curr_fun) e_id in - let kind = - match expr with - | Let _ -> "let" - | Seq _ -> "seq" - | Assign _ -> "assign" - | Update _ -> "update" - | Assert _ -> "assert" - | Alias _ -> "alias" - | NCond _ -> "ifnull" - | Cond _ -> "ifz" - | Unit -> "unit" - | Return _ -> "return" - | Fail -> "fail" - | Match _ -> "match" - in - prefix ^ kind - -let fresh_relation_for curr_relation (((e_id,_),_) as k) ctxt = - let rel = relation_name k ctxt in - let (_,args,_) = curr_relation in - let to_ret = (rel,args, Expr e_id) in - { ctxt with relations = to_ret::ctxt.relations },to_ret - -let fresh_alias_relation ~e_id ~name ~args ctxt = - let to_ret = name, args, AliasUnfold e_id in - { ctxt with relations = to_ret::ctxt.relations },to_ret - -let to_cont k = (Some k) - -(* This creates a relation and type environment which extends - the current relation and type environment with the result - of binding a value given by the rhs side value recorded in - the let binding map to [patt]. - - This also produces a list of paths bound by the pattern, and any mu - binders. This is used for removing any havoc information about these paths - and the recursive mu relations when these paths fall out of scope. - *) -let fresh_bind_relation e_id (relation,tyenv) patt k ctxt = - let (_,curr_args,_) = relation in - let bound_type = IntMap.find e_id ctxt.let_types in - let rec destruct_loop (tyenv,args,rec_paths) patt ty = - match patt,ty with - | PVar v,ty -> - let ty = ty in - let ty_env = (v,ty)::tyenv in - let paths = List.rev @@ type_to_paths (P.var v) ty in - let rec_paths = (RecRelations.get_mu_binders (P.var v) ty) @ rec_paths in - let args = (List.map (fun p -> (p,path_type p)) paths) @ args in - (ty_env,args,rec_paths) - | PTuple pl,`Tuple tl -> - List.fold_left2 destruct_loop (tyenv,args,rec_paths) pl tl - | PTuple _,_ -> assert false - | PNone,_ -> (tyenv,args,rec_paths) - in - let (tyenv',args,mu_paths) = destruct_loop (tyenv,[],[]) patt bound_type in - let bound_paths = List.map (fun (p,_) -> p) args |> P.PathSet.of_list in - let new_args = curr_args @ (List.rev args) in - let name = relation_name k ctxt in - let relation = (name, new_args, Expr e_id) in - { ctxt with relations = relation::ctxt.relations },(relation,tyenv',(bound_paths,mu_paths)) - -let%lq get_iso_at e_id ctxt = - let fold = IntSet.mem e_id ctxt.fold_iso in - let unfold = IntSet.mem e_id ctxt.unfold_iso in - assert ((fold <> unfold) || (not fold)); - if fold then - `IsoFold - else if unfold then - `IsoUnfold - else - `None - -(** Process expression is a monadic function that "returns" a boolean indicating - whether execution within the current function can proceed after executing e. - This is false iff e must return along all paths. The continuation indicates - what the "post state" of executing e should flow into; this is the intraprocedural - successor of e. The relation giving function outputs (which occurs at explicitly - labelled return statements) is described by the output argument. -*) -let rec process_expr ~output (((relation : relation),tyenv) as st) continuation ((e_id,_),e) = - (* execute two branches, and then bring their results into sync. analyzes branch 1, b2 analyzes branch 2 *) - let scoped_effect ~b1 ~b2 ctxt = - (* some trickery here; we abuse the context to record information about the current - thread of execution (what paths are havoced, etc.) and to accumulate the - results of the entire analysis. Usually execution is straightline so this - is actually fine, but at least at conditionals we need to "roll back" the - current execution state, namely the recursive relations and havoc sets *) - let orig_recursive_rel = ctxt.recursive_rel in - let orig_havoc_set = ctxt.havoc_set in - let ctxt1,r1 = b1 ctxt in - let roll_back = { ctxt1 with havoc_set = orig_havoc_set; recursive_rel = orig_recursive_rel } in - let ctxt2,r2 = b2 roll_back in - if r1 && r2 then - let ctxt,recursive_rel = P.PathMap.fold (fun path bind1 (ctxt,new_map) -> - let bind2 = P.PathMap.find_opt path ctxt2.recursive_rel in - let () = assert (bind2 <> None) in - let bind2 = Option.get bind2 in - if bind1 = bind2 then - (ctxt, P.PathMap.add path bind1 new_map) - else - (* if a mu binder is bound to two different relations R and P, compute the join, - by effectively unioning the relations - - (accomplished with a fresh relation U and doing R => U and also P => U) - *) - let (_,args,_) = bind1 in - let name = Printf.sprintf !"join-%d-%{P}-%s" e_id path "mu" in - let rel = (name, args, ExprMu (e_id,path,`Join)) in - let ctxt = { - ctxt with - impl = [ - ([PRelation (bind1, [], None)], PRelation(rel, [], None)); - ([PRelation (bind2, [], None)], PRelation(rel, [], None)) - ] @ ctxt.impl; - relations = rel::ctxt.relations - } - in - ctxt, P.PathMap.add path rel new_map - ) ctxt1.recursive_rel (ctxt2,P.PathMap.empty) - in - { ctxt with recursive_rel; havoc_set = P.PathSet.union ctxt1.havoc_set ctxt2.havoc_set }, r1 - else if r1 then - { ctxt2 with havoc_set = ctxt1.havoc_set; recursive_rel = ctxt1.recursive_rel }, r1 - else ctxt2, r2 - in - (* call back to massage the context that flows out of a let binding, removing the - bound by the binder from data structures that track information about those - paths (havoc and mu relations). *) - let post_bind (paths,mu_binders) f ctxt = - let pset = P.PathSet.of_list mu_binders in - let ctxt,r = f ctxt in - { ctxt with - havoc_set = P.PathSet.diff ctxt.havoc_set paths; - recursive_rel = P.PathMap.filter (fun p _ -> - not @@ P.PathSet.mem p pset - ) ctxt.recursive_rel - },r - in - let%lm save_snapshot ctxt = - { ctxt with snapshots = IntMap.add e_id { - gamma = tyenv; - relation; - mu_relations = ctxt.recursive_rel - } ctxt.snapshots - } - in - let%bind iso = get_iso_at e_id in - save_snapshot >> - match e with - | Unit -> - begin - match continuation with - | Some out_relation -> - (* intra procedural successor *) - apply_identity_flow relation out_relation >> return true - - (* should only happen at the main function *) - | None -> - return false - end - | Return v -> - let () = assert (output <> None) in - let (out_relation, ret_var, out_rec_rel) = Option.get output in - (* luckily the deep unpleasantness of copies is completely abstracted away by compute - copies and apply copies. NB the use of out_rec_rel which says - what recursive relations should be the "flow targets" of the return/output relations *) - let copies = compute_copies (P.var v) ret_var @@ path_simple_type tyenv (P.var v) in - apply_copies ~out_rec_rel ~havoc:false ~sl:(SRet e_id) copies relation out_relation - >> return false - | Fail -> - add_assert (IConst 0) "=" (IConst 1) relation >> - return false - - | Seq (e1, e2) -> - let%bind e2_rel = fresh_relation_for relation e2 in - let%bind flg = process_expr ~output st (to_cont e2_rel) e1 in - (* otherwise we have dead code *) - (assert flg); - process_expr (e2_rel,tyenv) ~output continuation e2 - - | Assign (lhs,IInt i,k) -> - let%bind k_rel = fresh_relation_for relation k in - add_null_check relation (P.var lhs) >> - const_assign (P.deref @@ P.var lhs) i relation k_rel >> - process_expr ~output (k_rel,tyenv) continuation k - - | Assign (lhs, IVar rhs,k) when iso = `IsoFold -> - let%bind k_rel = fresh_relation_for relation k in - let out_ap = P.var lhs in - let ty = path_simple_type tyenv out_ap in - add_null_check relation (P.var lhs) >> - do_fold_copy ~e_id rhs lhs ty relation k_rel >> - process_expr ~output (k_rel,tyenv) continuation k - - | Assign (lhs,IVar rhs,k) -> - let%bind k_rel = fresh_relation_for relation k in - let copies = compute_copies (P.var rhs) (vderef lhs) @@ List.assoc rhs tyenv in - add_null_check relation (P.var lhs) >> - apply_copies ~havoc:true ~sl:(SBind e_id) copies relation k_rel >> - process_expr ~output (k_rel,tyenv) continuation k - - | Update (arr,ind,rhs,k) -> - (* We model array updates by creating two implications to the successor state. The - first considers the case where the symbolic index variable is not equal to the - concrete index. In this case, the value of the array element is as in the input - relation, i.e., before this update. In the second implication the symbolic - index is constrained to be equal to the actual index to the operation, and - the corresponding array element is constrained to be equal to the rhs argument. *) - let%bind k_rel = fresh_relation_for relation k in - let array_ap = P.var arr in - let ind_ap = P.var ind in - let rhs_ap = P.var rhs in - - let sym_ind = P.ind array_ap in - let sym_elem = P.elem array_ap in - begin%m - (* asserts that the index is within bounds and the length is greater than 0 *) - add_indexing_assertion array_ap ind_ap relation; - add_implication [ - PRelation (relation,[],None) - ] @@ PRelation (k_rel,[ (sym_elem, Ap rhs_ap); (sym_ind, Ap ind_ap) ], None); - add_implication [ - PRelation (relation,[],None); - rel ~ty:ZInt @@ mk_relation (Ap sym_ind) "!=" (Ap ind_ap) - ] @@ PRelation (k_rel,[], None); - process_expr ~output (k_rel,tyenv) continuation k - end - | Cond (v,e1,e2) -> - let%bind e1_rel = fresh_relation_for relation e1 in - let%bind e2_rel = fresh_relation_for relation e2 in - - let mk_pre rel_cond = Relation (RT.({ - rel_op1 = Ap (P.var v); rel_cond; rel_op2 = IConst 0 - }), ZInt) - in - begin%m - apply_identity_flow ~pre:[ mk_pre "=" ] relation e1_rel; - apply_identity_flow ~pre:[ mk_pre "!=" ] relation e2_rel; - scoped_effect - ~b1:(process_expr ~output (e1_rel,tyenv) continuation e1) - ~b2:(process_expr ~output (e2_rel,tyenv) continuation e2) - end - | NCond (v,e1,e2) -> - let%bind e1_rel = fresh_relation_for relation e1 in - let%bind e2_rel = fresh_relation_for relation e2 in - let mk_pre null = - let null_ap = Ap (P.to_null @@ P.var v) in - Relation (RT.({ - rel_op1 = null_ap; rel_cond = "="; rel_op2 = BConst null - }), ZBool); - in - let var_type = path_simple_type tyenv @@ P.var v in - begin%m - apply_identity_flow ~pre:[ mk_pre is_null_flag ] relation e1_rel; - apply_identity_flow ~pre:[ mk_pre is_nonnull_flag ] relation e2_rel; - scoped_effect ~b1:( - (* creates arbitrary relations for every mu binder under the (provably null) variable *) - RecRelations.null_for_var ~e_id ~ty:var_type v >> - (* use the havoc state determined by the magic map *) - H.update_null_havoc ~e_id ~ty:var_type v >> - process_expr ~output (e1_rel,tyenv) continuation e1 - ) ~b2:(process_expr ~output (e2_rel,tyenv) continuation e2) - end - - | Let (PVar lhs, Mkref (RVar rhs), k) when iso = `IsoFold -> - let%bind k_rel,tyenv',bind_info = fresh_bind_relation e_id st (PVar lhs) k in - let%bind bound_ty = get_bound_type e_id in - do_fold_copy ~e_id rhs lhs bound_ty relation k_rel >> - post_bind bind_info @@ process_expr ~output (k_rel,tyenv') continuation k - - | Let (p, Deref rhs, k) when iso = `IsoUnfold -> - let ref_ty = path_simple_type tyenv @@ P.var rhs in - let%bind k_rel,tyenv',bind_info = fresh_bind_relation e_id st p k in - let%bind unfolded_type = get_bound_type e_id in - (* Rather than have unfold_to reason about patterns and so on, we generate - the unfolding to a dummy variable $uf, and the compute the assignments - from dummy variable $uf to the pattern given in the LHS. - - This latter assingment is used for the out_mapping argument. - *) - let copies = compute_patt_copies (P.var "$uf") p unfolded_type in - let out_mapping = List.fold_left (fun acc (uf,real_path,_) -> - PPMap.add uf real_path acc - ) PPMap.empty @@ to_copy_stream copies in - let out_mapping = List.fold_left (fun acc (_,uf,real_path,_) -> - PPMap.add uf real_path acc - ) out_mapping @@ to_mu_copies copies in - add_null_check relation (P.var rhs) >> - do_unfold_copy ~with_havoc:true ~e_id ~out_mapping rhs "$uf" ref_ty relation k_rel >> - post_bind bind_info @@ process_expr ~output (k_rel,tyenv') continuation k - - | Let (patt,rhs,k) -> - let%bind k_rel,tyenv',bind_info = fresh_bind_relation e_id st patt k in - apply_patt ~e_id tyenv patt rhs relation k_rel >> - post_bind bind_info @@ process_expr ~output (k_rel,tyenv') continuation k - - | Assert (assrt, k) -> - let%bind k_rel = fresh_relation_for relation k in - add_assert_cond assrt relation >> - apply_identity_flow relation k_rel >> - process_expr ~output (k_rel,tyenv) continuation k - - | Alias (lhs, rhs, k) when iso = `IsoUnfold-> - (* This means that the root of a recursive type - aliases with the mu binder under another recursive type. - Our basic strategy is as follows: - + unfold the type containing the target mu binder to a temporary relation. - Thus, the "target" of the alias has a similar shape to the "source" type. - + Immediately fold the unfolded relation back up. However, when folding back up, - we use the copy policy and rec_ext facilities of fold to to ensure that paths - in the (now unfolded mu) and the those in the "source" unfolded type are shared, - ensuring the values in the result of the fold reflects any information from the - unfolded type being aliased in. - *) - let rec has_mu_binder = function - | `Int | `TVar | `IntArray | `Ref _ -> false - | `Mu _ -> true - | `Tuple tl -> List.exists has_mu_binder tl - in - (* TODO: add null ante pre *) - (* If we have an isounfold here, then one of the alias - paths must go to a mu binder. This finds - the root of the recursive type being unfolded. - - - TODO: (This is an extremely brittle way for this to work, we should - do better) - - If the result is found, this returns the the type under the root - of the recursive type, the (reversed) list of steps followed to reach the root, - and the remaining steps to reach the mu binder - *) - let rec find_unfold_point rev t rem = - match t,rem with - | `Deref::r,`Ref (_,t) -> - if has_mu_binder t then - Some (t,r,rev) - else - find_unfold_point (`Deref::rev) r t - | `Proj i::r,`Tuple tl -> - find_unfold_point (`Proj i::rev) r (List.nth tl i) - | [],_ -> None - | _,_ -> assert false - in - (* if this path goes to a mu, return the type - under root of the containing recursive type, - the path to the root, and the path to the mu, - expressed relative to the path tot he root. - - Otherwise, simply returns the path - - - (This is either or is represented with the result type, - which uses the unfortunately named constructors Ok Error, - but really we are (ab)using it to represent one of two possible results - that has very nice interoperation with the Option module) - *) - let prepare_alias path = - let (root,steps,suff) = (path : P.concr_ap :> P.root * P.steps list * P.suff) in - let v = match root,suff with - | P.Var v,`None -> v - | _ -> assert false - in - let ty = List.assoc v tyenv in - find_unfold_point [] (List.rev steps) ty - |> Option.map (fun (t,to_mu,ctxt) -> - let p = P.var v in - let p = List.fold_left P.extend p @@ List.rev ctxt in - let to_mu = List.fold_left P.extend P.template to_mu in - (t,to_mu,p,path) - ) - |> Option.to_result ~none:path - in - let lp = prepare_alias lhs in - let rp = prepare_alias rhs in - - (* + ref_cont is the type under the root of the mu - + mu_path is the path to the mu binder, relative to path_to_ref - + path_to_ref is the path to the root of the containing recursive type - + full_path is the full path to the mu binder - + unfolded path is the path to the value to be folded by this alias - *) - let (ref_cont, mu_path, path_to_ref, full_path, unfolded_path) = - match lp, rp with - | Error unfolded_path, Ok (ref_cont, mu_path, path_to_ref, full_path) - | Ok (ref_cont, mu_path, path_to_ref, full_path), Error unfolded_path -> - (ref_cont, mu_path, path_to_ref, full_path, unfolded_path) - | _,_ -> assert false - in - let%bind k_rel = fresh_relation_for relation k in - - (* TODO: rename lhs_type to uf_type *) - (* This is the type we expect to find at path_to_ref (as expressed below) *) - let lhs_type = path_simple_type tyenv unfolded_path in - - assert ( - match lhs_type with - | `Ref (_,t') -> t' = ref_cont - | _ -> false - ); - (* In order to make the mu binders match, we need to unfold the target type, i.e. - the aliased type. Recall this is to make the target of aliasing match the shape - of the unfolded source. - *) - let aliased_type = deep_type_normalization ref_cont in - (* the unfolding is down to a dummy $uf variable *) - let temp_args = type_to_paths (P.var "$uf") aliased_type |> List.map (fun p -> - p, path_type p - ) in - let (curr_rel, curr_args,_) = relation in - let%bind temp_rel = fresh_alias_relation ~e_id ~name:(curr_rel ^ "$alias") ~args:(curr_args @ temp_args) in - let%lm alias_unfold p1 p2 ty in_rel out_rel ctxt = - RecursiveRefinements.unfold_to ~e_id ~with_havoc:false ~out_mapping:PPMap.id_map ty p1 p2 in_rel out_rel ctxt - in - (* unfold *) - let%bind () = alias_unfold path_to_ref (P.var "$uf") lhs_type relation temp_rel in - (* the path to the (now unfolded) mu in $uf *) - let flow_root = P.root_at ~child:mu_path ~parent:(P.var "$uf") in - let folded_target = full_path in - (* the aliasing can be viewed as a "copy" from the source (found at unfolded path) - and the (now unfolded) [flow_root] *) - let copies = compute_copies unfolded_path flow_root lhs_type in - let copy_stream = to_copy_stream copies in - (* Which copies are occurring under a mu, and which not? *) - let direct_copies,weak_copies = copy_stream |> List.partition (fun (_,_,k) -> - k = `Direct - ) - in - (* To copy information from the unfolded version while simultaneously copying - information from the source recursive type, we use the following trick: - - In the following, let x and y be the path of a location at the same - relative location under the mu binder in question, and let - b and c be a concrete location. The resulting - implication is generated as: - - R(b, y!pass, c, y!pass) /\ R(b, x, b, x) => Q(b, x, b, y!pass) - - So we make sure that any relationship satsified by y is satisfied by x and vice versa, - without constraining them to be equal. However, we do b and c to be equal (as the copy - is direct). - *) - - (* generate the y -> y!pass substitution *) - let pass_through_subst = (List.map (fun (s,_,_) -> - (s, to_pass_ap s) - ) weak_copies) - in - (* this rename is applied to a second copy of the input relation for weak copies. - We apply the y->y!pass and x -> y!pass substitution - - XXX: uhhhh, wanna apply the direct copies to...? - *) - let rename_weak = pass_through_subst @ List.map (fun (s,d,_) -> - (d, to_pass_ap s) - ) weak_copies in - (* rename y->y!pass and c -> b *) - let rename_out = pass_through_subst @ List.map (fun (s,d,_) -> (s,d)) direct_copies in - (* rename y -> x and c -> b, this is applied to a different copy of the input relation *) - let rename_src = List.map (fun (s,d,_) -> - (s,d) - ) copy_stream - in - - let%lm do_alias_fold ctxt = - let dst_oracle p = - (* when we fold uf back into the original type, it we will query for the havoc - state of some paths that are not actually touched by the alias (i.e., the havoc - state of the head elements in the type containing the target mu. In - that case, just call back on the current havoc state *) - if P.has_prefix ~prefix:folded_target p && (p <> (P.to_null folded_target)) then - havoc_oracle ctxt (OI.MAlias e_id) p - else - P.PathSet.mem p ctxt.havoc_set - in - (* the uf state is going to be dropped anyway *) - let src_oracle _ = true in - let havoc_oracle = havoc_oracle ctxt (OI.MAlias e_id) in - (* the havoc of the "source", already unfolded type. (called "var" because the - language grammar used to require this be rooted at a plain variable) *) - let var_havoc = copy_stream |> List.fold_left (fun acc (src,_,k) -> - let havoc = havoc_oracle src in - let acc = H.add_havoc src havoc acc in - match k with - | `Mu (under_mu_path, binder, _, ty) -> - H.add_mu_havoc ~binder ~ty under_mu_path havoc acc - | _ -> acc - ) H.empty_havoc_state - in - let by_havoc = H.to_rec_havoc var_havoc in - (* walk the source type, and generate the new, joined recursive refinements from - combinining information from the unfolded temp type. In addition, this records - the relations to conjoin in fold_to using the rec_ext functionality - *) - let ante,ctxt = to_mu_copies copies |> List.fold_left (fun (ante,ctxt) (_,src_root,dst_root,ty) -> - let src_rel = P.PathMap.find src_root ctxt.recursive_rel in - let ante = P.PathMap.add dst_root (PRelation (src_rel, [], None)) ante in - let dst_rel = P.PathMap.find dst_root ctxt.recursive_rel in - let ctxt = RecRelations.recursive_rel_with_havoc ~by_havoc ~e_id ~ante:([ - PRelation(src_rel, [], None); - PRelation(dst_rel, [], None) - ]) src_root ty ctxt - in - ante,ctxt - ) (P.PathMap.empty, ctxt) - in - (* compute the head substitution for when generating the mu relation that incorporates - the head and tails of the temp unfolded type, it should also include the - corresponding head and tails of the "source" *) - let hd_subst = parallel_type_walk P.template unfolded_path lhs_type (fun _ _ () -> `Cont ()) (fun () i o acc -> - (o, Ap i)::acc - ) () [] - in - - let havoc_ext ~havoc ~stable = - (P.PathSet.union havoc var_havoc.havoc, P.PathSet.union stable var_havoc.stable) - in - (* the extensions are only valid for the mu binder targeted by the alias expression *) - let rec_ext = P.PathMap.singleton (P.root_at ~child:mu_path ~parent:(P.deref P.template)) (hd_subst, ante) in - let open RecursiveRefinements in - (* easy! *) - let ctxt = fold_to ~oracle:(dst_oracle,src_oracle) ~e_id ~copy_policy:(Custom { rename_src; rename_out; rename_weak}) ~rec_ext ~havoc_ext lhs_type (P.var "$uf") path_to_ref temp_rel k_rel ctxt in - (* now remove all of the $uf stuff *) - let uf_root = P.var "$uf" in - let concr_root_p = Fun.negate @@ P.has_prefix ~prefix:uf_root in - let havoc_set = P.PathSet.filter concr_root_p ctxt.havoc_set in - { ctxt with - havoc_set; - recursive_rel = P.PathMap.filter (fun p _ -> - concr_root_p p - ) ctxt.recursive_rel - } - in - do_alias_fold >> process_expr ~output (k_rel,tyenv) continuation k - - | Alias (lhs_path,rhs_ap,k) -> - let null_ante_paths ap = - let rec null_ante_paths acc ap = - match P.tail ap with - | None -> acc - | Some e -> - let p = P.parent ap in - if e = `Deref then - null_ante_paths ((P.to_null p)::acc) p - else - null_ante_paths acc p - in - null_ante_paths [] ap - in - let%bind k_rel = fresh_relation_for relation k in - let lhs_type = path_simple_type tyenv lhs_path in - let rhs_subst = compute_copies lhs_path rhs_ap lhs_type in - let%bind havoc_oracle = gen_for_alias e_id in - (* The basic idea (which is reflected in the above) - is to model aliasing by introducing a constraint that all values reachable - from the operand paths must be equal (because they alias). As a consequence, Z3 - must conclude that the invariants that hold on the two locations must incorporate - information from inputs. - - left/right are used for weak copies of, you guessed it, weak locations. If - any weak locations are involed, then we use two copies of the input - relation in the antecedent, with the argument substitution - R(x, x) /\ R(y, y) => Q(x, y) (where x and y are two summary locations). - *) - let direct,left,right,hstate = List.fold_left (fun (direct,left,right,hstate) (src,dst,k) -> - let hstate = - if (P.to_null lhs_path) = src then - hstate - else - let s_havoc = havoc_oracle src in - let d_havoc = havoc_oracle dst in - let hstate = - H.add_havoc src s_havoc hstate - |> H.add_havoc dst d_havoc - in - match k with - | `Mu (under_mu_path, src_root, dst_root, ty) -> - H.add_mu_havoc ~binder:src_root ~ty under_mu_path s_havoc hstate - |> H.add_mu_havoc ~binder:dst_root ~ty under_mu_path d_havoc - | _ -> hstate - in - match k with - | `Direct -> - (src,dst)::direct,left,right,hstate - | `Mu _ -> - direct,(src,dst)::left,(dst,src)::right,hstate - ) ([],[],[],H.empty_havoc_state) @@ to_copy_stream rhs_subst in - let direct = List.map lift_copy direct in - let ante = - if left <> [] then - let () = assert (right <> []) in - [ - PRelation (relation, direct @ List.map lift_copy right, None); - PRelation (relation, direct @ List.map lift_copy left, None) - ] - else - [ PRelation (relation, direct, None) ] - in - (* for the aliasing to succeed, all references traversed must be non-null *) - let extend_nonnull nfs l = - List.fold_left (fun acc nf -> - (NullCons (Ap nf, BConst is_nonnull_flag))::acc - ) l nfs - in - let must_inhabit_paths = - (null_ante_paths lhs_path) @ (null_ante_paths rhs_ap) - in - let ante = extend_nonnull must_inhabit_paths ante in - let%bind havoc_set = get_havoc_state in - let havoc_set = P.PathSet.union hstate.havoc @@ P.PathSet.diff havoc_set hstate.stable in - let out_subst = augment_havocs direct havoc_set in - let%lm alias_recursive ctxt = - let by_havoc = H.to_rec_havoc hstate in - (* conjoin the recursive refinements, in the same way as in the - above alias case. In this case, we use the same antecedent (a conjoining - of the two mu relations) but generate two relations due - to differences in havocing. - *) - to_mu_copies rhs_subst |> List.fold_left (fun ctxt (_,src,dst,ty) -> - let src_rel = P.PathMap.find src ctxt.recursive_rel in - let dst_rel = P.PathMap.find dst ctxt.recursive_rel in - let ante = [ - PRelation (src_rel, [], None); - PRelation (dst_rel, [], None) - ] in - RecRelations.recursive_rel_with_havoc ~by_havoc ~e_id ~ante src ty ctxt - |> RecRelations.recursive_rel_with_havoc ~by_havoc ~e_id ~ante dst ty - ) ctxt - in - List.fold_left (fun seq p -> - seq >> add_null_path_check relation p - ) (return ()) must_inhabit_paths >> - set_havoc_state ~rel:(get_relation_ident k_rel) havoc_set >> - alias_recursive >> - add_implication ante @@ PRelation (k_rel,out_subst,None) >> - process_expr ~output (k_rel,tyenv) continuation k - | Match (_, _, _, _, _) -> assert false - -let analyze_function fn ctxt = - let { in_rel = (in_nm,in_args, isrc); - out_rel = (out_nm,out_args, osrc); - f_type = fn_type; - in_recursive_rel; - out_recursive_rel; - } = StringMap.find fn.name ctxt.fenv in - let initial_env = List.map2 (fun v ty -> - (v,ty) - ) fn.args fn_type.arg_types in - let arg_mapping = fold_lefti (fun i acc nm -> - StringMap.add (P.arg_name i) nm acc - ) StringMap.empty fn.args in - let map_arg_root = Paths.map_root (fun t -> - StringMap.find t arg_mapping - ) - in - let map_args = List.map (fun (p,ty) -> - let p' = map_arg_root p - in - (p',ty) - ) - in - - (* The initial havoc set as determined by the ownership operation *) - let havoc_set = fold_left2i (fun i acc nm ty -> - List.fold_left (fun acc path -> - let arg_id = P.map_root (fun _ -> P.arg_name i) path in - if havoc_oracle ctxt (OI.MArg fn.name) arg_id then - P.PathSet.add path acc - else - acc - ) acc @@ type_to_paths (P.var nm) ty - ) P.PathSet.empty fn.args fn_type.arg_types - in - let start_rel,direct_out = fold_lefti (fun i acc (arg_name,ty) -> - let mu_binders = RecRelations.get_mu_binders P.template ty in - let formal_name = P.arg i in - List.fold_left (fun (start_rel, out_list) mu_loc -> - let formal_root = P.root_at ~child:mu_loc ~parent:formal_name in - let arg_root = P.root_at ~child:mu_loc ~parent:(P.var arg_name) in - let orel = P.PathMap.find formal_root out_recursive_rel in - let irel = P.PathMap.find formal_root in_recursive_rel in - P.PathMap.add arg_root irel start_rel, (arg_root, orel)::out_list - ) acc mu_binders - ) (P.PathMap.empty, []) initial_env - in - let direct_flow = - P.PathMap.filter (fun p _ -> - P.has_prefix ~prefix:P.ret p - ) out_recursive_rel - in - let mapped_in_args = map_args in_args in - let mapped_out_args = map_args out_args in - let cont = Some ((out_nm, mapped_out_args,osrc),P.ret,(direct_flow, direct_out)) in - let add_omit nm ctxt = - StringMap.find_opt nm ctxt.omit_set - |> Option.fold ~none:ctxt ~some:(fun set -> - let set' = P.PathSet.map map_arg_root set |> P.PathSet.union set in - { ctxt with omit_set = StringMap.add nm set' ctxt.omit_set } - ) - in - let ctxt = add_omit in_nm ctxt |> add_omit out_nm in - let ctxt,_ = process_expr ((in_nm,mapped_in_args,isrc),initial_env) ~output:cont None fn.body {ctxt with curr_fun = Some fn.name; havoc_set; recursive_rel = start_rel } in - ctxt - -let analyze_main start_rel main ctxt = - let ctxt,_ = process_expr (start_rel,[]) ~output:None None main ctxt in - ctxt - -let infer ~opts (simple_theta,side_results) o_hints (fns,main) = - let lift_and_unfold = (fun p -> deep_type_normalization @@ simple_to_fltype p) in - let simple_theta = StringMap.map (fun ft -> - { - arg_types = List.map lift_and_unfold ft.arg_types; - ret_type = lift_and_unfold ft.ret_type - } - ) simple_theta in - let (fenv,relations, omit_set) = StringMap.fold (fun name ty (theta,rel,os) -> - let arg_paths = - List.mapi (fun i arg_t -> - type_to_paths ~pre:true (P.arg i) arg_t - ) ty.arg_types - in - let get_havoced_paths ml p ty = - walk_type ty (fun k path -> - match k with - | `Ref -> - let o = OI.GenMap.find (ml,path) o_hints.OI.gen in - if o = 0.0 then - `K (fun ty acc -> - match ty with - | `Ref (_,t) -> (type_to_paths (P.deref path) t) @ acc - | _ -> assert false - ) - else - `Cont (P.deref path) - | `Array -> - let o = OI.GenMap.find (ml,path) o_hints.OI.gen in - if o = 0.0 then - `K (fun _ acc -> - (P.ind path)::(P.elem path)::acc - ) - else - `Cont path - | _ -> `Cont (path_step k path) - ) (fun _ acc -> acc) p [] - in - let in_rel_types = List.map (fun p -> (p,path_type p)) @@ List.concat arg_paths in - let ret_rel = type_to_paths P.ret ty.ret_type |> List.map (fun p -> (p,path_type p)) in - let out_rel_types = in_rel_types @ ret_rel in - let in_havoc_paths = fold_lefti (fun i acc t -> - get_havoced_paths (OI.MArg name) (P.arg i) t - |> List.fold_left (fun s p -> P.PathSet.add p s) acc - ) P.PathSet.empty ty.arg_types - in - let out_havoc_paths = fold_lefti (fun i acc t -> - get_havoced_paths (OI.MOut name) (P.arg i) t - |> List.fold_left (fun s p -> P.PathSet.add p s) acc - ) P.PathSet.empty ty.arg_types - in - let in_rel = (name ^ "-in", in_rel_types, Fun (name, `In)) in - let out_rel = (name ^ "-out", out_rel_types, Fun (name, `Out)) in - let () = - assert (not @@ StringMap.mem (get_relation_ident in_rel) os); - assert (not @@ StringMap.mem (get_relation_ident out_rel) os) - in - let os = - StringMap.add (get_relation_ident in_rel) in_havoc_paths os - |> StringMap.add (get_relation_ident out_rel) out_havoc_paths - in - let in_rec_rel,out_rec_rel,rel = fold_lefti (fun i acc arg_t -> - RecRelations.get_recursive_roots (P.arg i) arg_t - |> List.fold_left (fun acc (root,ty) -> - let args = type_to_paths P.template ty |> List.map (fun p -> p, path_type p) in - RecRelations.get_mu_binders root ty |> List.fold_left (fun (in_rec_rel, out_rec_rel, rel) mu_binder -> - let f suff mu = Printf.sprintf !"%s-%s-%{P}-%s" name suff mu "mu" in - let in_name = f "in" mu_binder in - let out_name = f "out" mu_binder in - let in_rel = (in_name, args, FunMu (name, `In, mu_binder)) in - let out_rel = (out_name, args, FunMu (name, `Out, mu_binder)) in - (RecRelations.update_rel_map mu_binder in_rel in_rec_rel, - RecRelations.update_rel_map mu_binder out_rel out_rec_rel,in_rel::out_rel::rel) - ) acc - ) acc - ) (P.PathMap.empty, P.PathMap.empty, rel) ty.arg_types - in - let out_rec_rel,rel = - RecRelations.get_recursive_roots P.ret ty.ret_type - |> List.fold_left (fun acc (root,ty) -> - let args = type_to_paths P.template ty |> List.map (fun p -> p, path_type p) in - RecRelations.get_mu_binders root ty - |> List.fold_left (fun (out_rec_rel,rel) root -> - let nm = Printf.sprintf !"%s-out-%{P}-%s" name root "mu" in - let ret_rel = (nm, args, FunMu (name,`Out,root)) in - RecRelations.update_rel_map root ret_rel out_rec_rel, ret_rel::rel - ) acc - ) (out_rec_rel,rel) - in - let ftype = { - in_recursive_rel = in_rec_rel; - out_recursive_rel = out_rec_rel; - in_rel; - out_rel; - f_type = ty - } in - (StringMap.add name ftype theta,in_rel::out_rel::rel,os) - ) simple_theta (StringMap.empty, [], StringMap.empty) - in - let start_name = "program-start" in - let entry_relation = (start_name, [], Start) in - let relations = entry_relation::relations in - let empty_ctxt = { - null_checks = opts.ArgOptions.check_null; - relations; - o_hints; - curr_fun = None; - let_types = IntMap.map lift_and_unfold (side_results.SimpleChecker.SideAnalysis.let_types); - bif_types = (ArgOptions.get_intr opts).op_interp; - fenv; - impl = []; - havoc_set = P.PathSet.empty; - fold_iso = side_results.SimpleChecker.SideAnalysis.fold_locs; - unfold_iso = side_results.SimpleChecker.SideAnalysis.unfold_locs; - recursive_rel = P.PathMap.empty; - snapshots = IntMap.empty; - omit_set; - } in - let ctxt = List.fold_left (fun ctxt fn -> - analyze_function fn ctxt - ) empty_ctxt fns in - let ctxt = analyze_main entry_relation main - { ctxt with - curr_fun = None; havoc_set = P.PathSet.empty; recursive_rel = P.PathMap.empty - } - in - (ctxt.relations,ctxt.impl,ctxt.snapshots,start_name,ctxt.omit_set) diff --git a/src/flowInference.mli b/src/flowInference.mli deleted file mode 100644 index c41528b9..00000000 --- a/src/flowInference.mli +++ /dev/null @@ -1,52 +0,0 @@ -module P = Paths -module RT = RefinementTypes - - -type fltype -val fltype_to_string : fltype -> string - -type z3_types = - | ZBool - | ZInt [@@deriving sexp] - -type relation_source = - | Expr of int - | Fun of string * [`In | `Out] - | FunMu of string * [`In | `Out] * P.concr_ap - | ExprMu of int * P.concr_ap * [ `Null | `Join | `Flow ] - | AliasUnfold of int - | Start [@@deriving sexp] - -type relation = string * (P.concr_ap * z3_types) list * relation_source [@@deriving sexp] - -type state_snapshot = { - mu_relations : relation P.PathMap.t; - gamma : (string * fltype) list; - relation : relation -} - -type concr_arg = - | Ap of P.concr_ap - | BConst of bool - | IConst of int - | KeyedChoice of P.concr_ap * concr_arg * concr_arg [@@deriving sexp] - -type clause = - | PRelation of relation * ((P.concr_ap * concr_arg) list) * int option - | Relation of (concr_arg,concr_arg) RT.relation * z3_types - | NamedRel of string * (concr_arg list) - | NullCons of concr_arg * concr_arg - -type res_t = - relation list (* the list of all relations generated *) - * (clause list * clause) list (* implications *) - * state_snapshot Std.IntMap.t (* snapshots at each location (for annotation) *) - * string (* entry point relation *) - * P.PathSet.t StringMap.t (* omit sets (used in relax mode only *) - -val infer : - opts:ArgOptions.t -> - SimpleTypes.funtyp StringMap.t * SimpleChecker.SideAnalysis.results -> - float OwnershipInference.ownership_ops -> - Ast.fn list * Ast.exp -> - res_t diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 3c88ed16..603733de 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -134,7 +134,7 @@ type infr_options = bool let infr_opts_default = false -let unfold = +(* let unfold = let rec subst_once id sub = function | TVar id' when id = id' -> sub | (Int as t) @@ -159,7 +159,7 @@ let unfold = unfold_loop ~unfld:(IntSet.add id unfld) t' | IntList -> assert false in - unfold_loop ~unfld:IntSet.empty + unfold_loop ~unfld:IntSet.empty *) (** The optional relaxed argument indicates whether the passed in constraint should be applied only if the relaxed flag is in the indicated state. @@ -175,14 +175,15 @@ let%lm add_constraint ?relaxed c ctxt = (** Shuffle the ownership between two source types (t1 and t2) and two destination types (t1' and t2'). The two types must be iso-recursively equal; they are walked in parallel, at references the ownerships are shuffled with the Shuff constraint. *) -let%lm shuffle_types ~e_id ~src:(t1,t1') ~dst:(t2,t2') ctxt = +let%lm shuffle_types (*~e_id*) ~src:(t1,t1') ~dst:(t2,t2') ctxt = (* check whether we need to unfold the "destination", which in this case is t2/t2', not t1/t1'. This confusing naming arises from this functions use in returning ownership to a recursive data structure, in that case, t2/t2' represents the destination for the return operation. *) let unfold_dst = - if IntSet.mem e_id ctxt.iso.SimpleChecker.SideAnalysis.unfold_locs then + (* if IntSet.mem e_id ctxt.iso.SimpleChecker.SideAnalysis.unfold_locs then unfold - else Fun.id + else *) + Fun.id in let rec loop t1 t2 t1' t2' ctxt = match t1,t2,t1',t2' with @@ -453,9 +454,10 @@ let fresh_ap e_id (p: P.concr_ap) = ) steps (* this must record *) -let get_type_scheme e_id v ctxt = - let st = IntMap.find e_id ctxt.iso.SimpleChecker.SideAnalysis.let_types in - lift_to_ownership (MGen e_id) (P.var v) st ctxt +let get_type_scheme (*e_id v ctxt*) = + assert false + (* let st = IntMap.find e_id ctxt.iso.SimpleChecker.SideAnalysis.let_types in + lift_to_ownership (MGen e_id) (P.var v) st ctxt *) let tarray o t = Array (t,o) let tref o t = Ref (t,o) @@ -487,13 +489,13 @@ let rec split_type loc p = (** Constrain to types to be pointwse constrained by the generator rel, which takes two ownerships and returns a constraint *) -let%lm constrain_rel ~e_id ~rel ~src:t1 ~dst:t2 ctxt = +let%lm constrain_rel (*~e_id*) ~rel ~src:t1 ~dst:t2 ctxt = let dst_unfld = - let open SimpleChecker.SideAnalysis in + (* let open SimpleChecker.SideAnalysis in if (IntSet.mem e_id ctxt.iso.unfold_locs) || (IntSet.mem e_id ctxt.iso.fold_locs) then unfold t2 - else + else *) t2 in let rec loop t1 t2 ctxt = @@ -530,9 +532,9 @@ let lkp_split loc v = let%bind (t1,t2) = split_type loc (P.var v) t in update_type v t1 >> return t2 -let%lq is_unfold eid ctxt = +(* let%lq is_unfold eid ctxt = let open SimpleChecker.SideAnalysis in - IntSet.mem eid ctxt.iso.unfold_locs + IntSet.mem eid ctxt.iso.unfold_locs *) let%lq theta f ctxt = SM.find f ctxt.theta @@ -573,7 +575,7 @@ let process_call e_id c = let%bind arg_types = mmap (lkp_split @@ SCall e_id) c.arg_names and fun_type = theta c.callee in begin%m - miter (fun (i,a) -> constrain_eq ~e_id ~src:i ~dst:a) @@ List.combine arg_types fun_type.arg_types; + miter (fun (i,a) -> constrain_eq (*~e_id*) ~src:i ~dst:a) @@ List.combine arg_types fun_type.arg_types; miteri (fun i arg_name -> let%bind t = lkp arg_name in let%bind t' = make_fresh_type (MGen e_id) (P.var arg_name) t in @@ -597,10 +599,10 @@ let rec process_expr ~output ((e_id,_),expr) = let () = assert (output <> None) in let (output_types, return_type) = Option.get output in let%bind t2 = lkp_split (SRet e_id) v in - constrain_eq ~e_id ~src:t2 ~dst:return_type + constrain_eq (*~e_id*) ~src:t2 ~dst:return_type >> miter (fun (v,out_t) -> let%bind curr_t = lkp v in - constrain_eq ~e_id ~src:curr_t ~dst:out_t + constrain_eq (*~e_id*) ~src:curr_t ~dst:out_t ) output_types >> return `Return | Unit -> return `Cont @@ -630,7 +632,7 @@ let rec process_expr ~output ((e_id,_),expr) = in begin%m constrain_wf_loop o' vt'; - constrain_eq ~e_id ~src:t2 ~dst:vt'; + constrain_eq (*~e_id*) ~src:t2 ~dst:vt'; update_type v @@ Ref (vt',o'); constrain_write o; constrain_write o'; @@ -642,7 +644,7 @@ let rec process_expr ~output ((e_id,_),expr) = begin%m constrain_wf_loop o new_cts; constrain_write o; - constrain_eq ~e_id ~src:cts ~dst:new_cts; + constrain_eq (*~e_id*) ~src:cts ~dst:new_cts; update_type base @@ Array (new_cts,o); process_expr ~output nxt end @@ -650,7 +652,7 @@ let rec process_expr ~output ((e_id,_),expr) = let%bind (src_up,st,st') = fresh_ap e_id src and (dst_up,dt,dt') = fresh_ap e_id dst in begin%m - shuffle_types ~e_id ~src:(st,st') ~dst:(dt,dt'); + shuffle_types (*~e_id*) ~src:(st,st') ~dst:(dt,dt'); src_up; dst_up; process_expr ~output nxt @@ -659,17 +661,17 @@ let rec process_expr ~output ((e_id,_),expr) = | Let (PVar v,Mkref (RVar src),body) -> let%bind t2 = lkp_split (SBind e_id) src in begin - match%bind get_type_scheme e_id v with + match%bind get_type_scheme (*e_id v*) with | (Ref (ref_cont,o)) as t' -> begin%m - constrain_eq ~e_id ~src:t2 ~dst:ref_cont; + constrain_eq (*~e_id*) ~src:t2 ~dst:ref_cont; add_constraint @@ Write o; with_types [(v,t')] @@ process_expr ~output body end | _ -> assert false end | Let (PVar v,(Null | MkArray _),body) -> - let%bind t = get_type_scheme e_id v in + let%bind t = get_type_scheme (*e_id v*) in with_types [(v,t)] @@ process_expr ~output body | Let (PVar v,Mkref (RNone | RInt _), body) -> let%bind new_var = alloc_ovar (MGen e_id) (P.var v) in @@ -697,11 +699,11 @@ let rec process_expr ~output ((e_id,_),expr) = | Deref v -> let%bind (t,o) = lkp_ref v in let%bind (t1,t2_pre) = split_type (SBind e_id) (P.deref (P.var v)) t in - let%bind uf = is_unfold e_id in + (* let%bind uf = is_unfold e_id in *) let t2 = - if uf then + (* if uf then unfold t2_pre - else + else *) t2_pre in begin%m @@ -755,8 +757,8 @@ and process_conditional ~e_id ~tr_branch ~output e1 e2 ctxt = let constrain_ge = constrain_rel ~rel:(fun o1 o2 -> Ge (o1, o2)) in begin%m (* notice that we allow ownership to be discarded at join points, the reason for MJoin *) - constrain_ge ~e_id ~src:tt ~dst:t'; - constrain_ge ~e_id ~src:ft ~dst:t'; + constrain_ge (*~e_id*) ~src:tt ~dst:t'; + constrain_ge (*~e_id*) ~src:ft ~dst:t'; update_type k t' end ) (StringMap.bindings ctxt_f.gamma) { ctxt_f with gamma = StringMap.empty } in diff --git a/src/parser.mly b/src/parser.mly index 7d771143..5253416f 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -142,11 +142,7 @@ let op := | LPAREN; l = tuple_contents; RPAREN; <`Tuple> | ~ = array_expr; <`Read> | ~ = op; DOT; LENGTH; <`LengthOf> - | CONS; h = lhs; r = cons; <`Cons> - | NIL; { `Nil } - -let cons := - | LPAREN; CONS; h = lhs; r = cons; RPAREN; <`Cons> + | CONS; h = lhs; r = op; <`Cons> | NIL; { `Nil } let tuple_rest := From 218ca4bd2c803445de2ad0fbd7224eef7bf46131 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 1 Jun 2023 15:14:42 +0900 Subject: [PATCH 030/108] fix let in simple type checking --- src/simpleChecker.ml | 1 - src/test/list/cons.imp | 3 ++- src/test/list/match.imp | 3 ++- 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/simpleChecker.ml b/src/simpleChecker.ml index 5d29f1e9..623241ba 100644 --- a/src/simpleChecker.ml +++ b/src/simpleChecker.ml @@ -378,7 +378,6 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = process_expr ret_type ctxt e res_acc | Fail -> res_acc,true | Let (PVar v,Mkref (RVar v'),expr) -> - unify_var v @@ `Ref (lkp v'); process_expr ret_type (add_var v (`Ref (lkp v')) ctxt) expr @@ save_let (`Ref (lkp v')) res_acc | Let (p,lhs,expr) -> let res_acc',v_type = diff --git a/src/test/list/cons.imp b/src/test/list/cons.imp index 0b96548b..736d9a47 100644 --- a/src/test/list/cons.imp +++ b/src/test/list/cons.imp @@ -1,5 +1,6 @@ { - let x = mkref Nil in + let n = Nil in + let x = mkref n in let y = mkref (Cons 1 x) in let z = mkref (Cons 2 y) in () diff --git a/src/test/list/match.imp b/src/test/list/match.imp index cc64ac75..f2a2d717 100644 --- a/src/test/list/match.imp +++ b/src/test/list/match.imp @@ -9,7 +9,8 @@ sum(l, s) { } { - let x = mkref Nil in + let n = Nil in + let x = mkref n in let y = mkref (Cons 1 x) in let z = mkref (Cons 2 y) in let l = mkref (Cons 3 z) in From 0a8286cb9c73bb3931af6ee3444b1410f6dcd009 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 1 Jun 2023 15:27:57 +0900 Subject: [PATCH 031/108] simplify tests --- src/test/list/cons.imp | 3 +-- src/test/list/match.imp | 3 +-- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src/test/list/cons.imp b/src/test/list/cons.imp index 736d9a47..0b96548b 100644 --- a/src/test/list/cons.imp +++ b/src/test/list/cons.imp @@ -1,6 +1,5 @@ { - let n = Nil in - let x = mkref n in + let x = mkref Nil in let y = mkref (Cons 1 x) in let z = mkref (Cons 2 y) in () diff --git a/src/test/list/match.imp b/src/test/list/match.imp index f2a2d717..cc64ac75 100644 --- a/src/test/list/match.imp +++ b/src/test/list/match.imp @@ -9,8 +9,7 @@ sum(l, s) { } { - let n = Nil in - let x = mkref n in + let x = mkref Nil in let y = mkref (Cons 1 x) in let z = mkref (Cons 2 y) in let l = mkref (Cons 3 z) in From 3b2643725b98b2e05b2a217b7347be00b0a15fc9 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 1 Jun 2023 15:45:16 +0900 Subject: [PATCH 032/108] fix match test --- src/test/list/match.imp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/test/list/match.imp b/src/test/list/match.imp index cc64ac75..b625192f 100644 --- a/src/test/list/match.imp +++ b/src/test/list/match.imp @@ -12,7 +12,7 @@ sum(l, s) { let x = mkref Nil in let y = mkref (Cons 1 x) in let z = mkref (Cons 2 y) in - let l = mkref (Cons 3 z) in + let l = Cons 3 z in let s = sum(l, 0) in assert(s = 6) } \ No newline at end of file From 3df469a81ca0577bf06ca094c798d446fbbb06dc Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 1 Jun 2023 22:25:02 +0900 Subject: [PATCH 033/108] delete Mu (WIP) --- src/ownershipInference.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 603733de..b15a2161 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -34,8 +34,7 @@ type 'a otype_ = | Ref of 'a otype_ * 'a | Tuple of 'a otype_ list | TVar of int - | Mu of int * 'a otype_ - | IntList + | IntList of 'a list type otype = ownership otype_ From 6160dd38267c40e3512e20eecb428b4abe2e0883 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 5 Jun 2023 16:33:32 +0900 Subject: [PATCH 034/108] add IntList to lift_to_ownership (WIP) --- src/ownershipInference.ml | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index b15a2161..1b3da14b 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -321,7 +321,14 @@ let alloc_split,alloc_ovar = (** Lift a simple type into an ownership type (of type otype) *) (* this must record *) -let lift_to_ownership loc root t_simp = +let lift_to_ownership loc root t_simp ~o_arity = + let rec lift_list_to_ownership loc root ~o_arity = + if o_arity <= 0 then return [] + else ( + let%bind o = alloc_ovar loc root in + return (o :: lift_list_to_ownership loc root ~o_arity:(o_arity - 1)) + ) + in let rec simple_lift ~unfld root = function | `Mu (id,t) when IntSet.mem id unfld -> @@ -342,7 +349,7 @@ let lift_to_ownership loc root t_simp = simple_lift ~unfld (P.t_ind root i) t ) tl in return @@ Tuple tl' - | `IntList -> return IntList + | `IntList -> return @@ IntList (lift_list_to_ownership loc root ~o_arity) in let%bind t = simple_lift ~unfld:IntSet.empty root t_simp in constrain_well_formed t >> return t From 8fe1e3492aea573c7b1052ce472dd2472210ab29 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 5 Jun 2023 16:40:59 +0900 Subject: [PATCH 035/108] complete lift_to_ownership --- src/ownershipInference.ml | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 1b3da14b..74c6ac48 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -326,15 +326,12 @@ let lift_to_ownership loc root t_simp ~o_arity = if o_arity <= 0 then return [] else ( let%bind o = alloc_ovar loc root in - return (o :: lift_list_to_ownership loc root ~o_arity:(o_arity - 1)) + let%bind o_list = lift_list_to_ownership loc root ~o_arity:(o_arity - 1) in + return (o :: o_list) ) in let rec simple_lift ~unfld root = function - | `Mu (id,t) when IntSet.mem id unfld -> - let%bind t' = simple_lift ~unfld root t in - return @@ Mu (id, t') - | (`Mu (id,t) as mu) -> simple_lift ~unfld:(IntSet.add id unfld) root @@ unfold_simple id mu t | `Array `Int -> let%bind o = alloc_ovar loc root in return @@ Array (Int, o) @@ -349,7 +346,9 @@ let lift_to_ownership loc root t_simp ~o_arity = simple_lift ~unfld (P.t_ind root i) t ) tl in return @@ Tuple tl' - | `IntList -> return @@ IntList (lift_list_to_ownership loc root ~o_arity) + | `IntList -> + let%bind o_list = lift_list_to_ownership loc root ~o_arity in + return @@ IntList o_list in let%bind t = simple_lift ~unfld:IntSet.empty root t_simp in constrain_well_formed t >> return t From a443be6bf3b2eac12bb83890d738a83ef9670ce9 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 5 Jun 2023 18:30:04 +0900 Subject: [PATCH 036/108] wip --- src/ownershipInference.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 74c6ac48..c280b383 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -792,7 +792,7 @@ let analyze_fn ctxt fn = let infer ~opts (simple_types,iso) (fn,prog) = let lift_plist loc l = mmapi (fun i t -> - lift_to_ownership loc (P.arg i) t + lift_to_ownership loc (P.arg i) t ~o_arity ) l in let lift_simple_ft nm ft = From 854496f348c2d17e782d0c08fe380b9e97c57bb2 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Tue, 6 Jun 2023 15:07:40 +0900 Subject: [PATCH 037/108] update AST printer --- src/astPrinter.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/astPrinter.ml b/src/astPrinter.ml index d35f5a09..8492bf38 100644 --- a/src/astPrinter.ml +++ b/src/astPrinter.ml @@ -176,7 +176,7 @@ let rec pp_expr ~ip:((po_id,pr_id) as ip) ~annot (id,e) = pf "Nil -> { "; pp_expr ~ip ~annot e2; ps " } "; - pf "| Cons(%s,%s) -> { " h r; + pf "| Cons %s (%s) -> { " h r; pp_expr ~ip ~annot e3; ps "}"; ] From 73c67fd4af2ba99c84067fe0977f887a2f83a8d9 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Wed, 7 Jun 2023 11:43:06 +0900 Subject: [PATCH 038/108] add ownership arity to options --- src/argOptions.ml | 6 ++++++ src/ownershipInference.ml | 4 ++-- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/src/argOptions.ml b/src/argOptions.ml index ef811ac6..48c2fd8a 100644 --- a/src/argOptions.ml +++ b/src/argOptions.ml @@ -69,6 +69,7 @@ type t = { file_list : Arg.usage_msg list; output_channel : out_channel Cache.t; intrinsics : Intrinsics.interp_t Cache.t; + ownership_arity : int; } let default = { @@ -95,6 +96,7 @@ let default = { file_list = []; output_channel = ref None; intrinsics = ref None; + ownership_arity = 1; } let close_output ~opts = Option.iter close_out !(opts.output_channel); @@ -132,6 +134,7 @@ let parse anon_fun usage_msg = let cfa = ref default.cfa in let intrinsics_file = ref None in let file_list = ref default.file_list in + let ownership_arity = ref default.ownership_arity in let show_all () = List.iter (fun r -> r := true) show_all_flags; Log.all () in let debug s = @@ -191,6 +194,8 @@ let parse anon_fun usage_msg = "\t Load definitions of standard operations from "); ("-files", Rest (fun s -> file_list := s::!file_list), " ...\t Interpret all remaining arguments as files to test"); + ("-ownership-arity", Set_int ownership_arity, + "\t The number of different ownership variables used in recursive data structure (default: 1)"); ] in Arg.parse spec anon_fun usage_msg; { @@ -217,4 +222,5 @@ let parse anon_fun usage_msg = file_list = !file_list; output_channel = default.output_channel; intrinsics = default.intrinsics; + ownership_arity = !ownership_arity; } diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index c280b383..a78c0314 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -792,13 +792,13 @@ let analyze_fn ctxt fn = let infer ~opts (simple_types,iso) (fn,prog) = let lift_plist loc l = mmapi (fun i t -> - lift_to_ownership loc (P.arg i) t ~o_arity + lift_to_ownership loc (P.arg i) t ~o_arity:opts.ArgOptions.ownership_arity ) l in let lift_simple_ft nm ft = let%bind arg_types = lift_plist (MArg nm) ft.SimpleTypes.arg_types and output_types = lift_plist (MOut nm) ft.SimpleTypes.arg_types - and result_type = lift_to_ownership (MRet nm) P.ret ft.SimpleTypes.ret_type in + and result_type = lift_to_ownership (MRet nm) P.ret ft.SimpleTypes.ret_type ~o_arity:opts.ArgOptions.ownership_arity in return RefinementTypes.{ arg_types; output_types; result_type } in let rec lift_reft loc p = From 3f1436187513483c672b9eb793a65b4d38d09b43 Mon Sep 17 00:00:00 2001 From: artoy Date: Wed, 7 Jun 2023 23:04:19 +0900 Subject: [PATCH 039/108] change some functions --- src/ownershipInference.ml | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index a78c0314..719ec0c4 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -245,16 +245,15 @@ let rec unfold_simple arg mu = let rec constrain_wf_loop o t ctxt = match t with | TVar _ - | Int -> (ctxt,()) + | Int + | IntList _ -> (ctxt,()) | Tuple tl -> miter (constrain_wf_loop o) tl ctxt - | Mu (_,t) -> constrain_wf_loop o t ctxt | Ref (t',o') | Array (t',o') -> constrain_wf_loop o' t' { ctxt with ocons = Wf (o,o')::ctxt.ocons } - | IntList -> assert false (** Like constrain_wf_above, but only begin emitting wf constraints when the first ownership variable is encountered *) @@ -479,17 +478,14 @@ let rec split_type loc p = in function | (Int as t) - | (TVar _ as t) -> return (t,t) - | Mu (id,t) -> - let%bind (t1,t2) = split_type loc p t in - return @@ (Mu (id,t1),Mu (id,t2)) + | (TVar _ as t) + | (IntList _ as t) -> return (t,t) | Tuple tl -> let%bind split_list = mtmap p (split_type loc) tl in let (tl1,tl2) = List.split split_list in return @@ (Tuple tl1,Tuple tl2) | Ref (t,o) -> split_mem o t P.deref tref | Array (t,o) -> split_mem o t P.elem tarray - | IntList -> assert false (** Constrain to types to be pointwse constrained by the generator rel, which From c4d03a822b1ec6b0dacb588aa1cd27d709329505 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 8 Jun 2023 14:25:33 +0900 Subject: [PATCH 040/108] update constrain_rel --- src/ownershipInference.ml | 30 +++++++++++------------------- 1 file changed, 11 insertions(+), 19 deletions(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 719ec0c4..55cfe772 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -490,28 +490,20 @@ let rec split_type loc p = (** Constrain to types to be pointwse constrained by the generator rel, which takes two ownerships and returns a constraint *) -let%lm constrain_rel (*~e_id*) ~rel ~src:t1 ~dst:t2 ctxt = - let dst_unfld = - (* let open SimpleChecker.SideAnalysis in - if (IntSet.mem e_id ctxt.iso.unfold_locs) || - (IntSet.mem e_id ctxt.iso.fold_locs) then - unfold t2 - else *) - t2 - in +let%lm constrain_rel ~rel ~src:t1 ~dst:t2 ctxt = let rec loop t1 t2 ctxt = match t1, t2 with | TVar _,TVar _ - | Int, Int -> ctxt + | Int, Int + | IntList _, IntList _ -> ctxt | Ref (t1',o1), Ref (t2',o2) | Array (t1',o1), Array (t2',o2) -> loop t1' t2' { ctxt with ocons = (rel o1 o2)::ctxt.ocons } - | Mu (_,t1'), Mu (_,t2') -> loop t1' t2' ctxt | Tuple tl1,Tuple tl2 -> List.fold_left2 (fun acc t1 t2 -> loop t1 t2 acc) ctxt tl1 tl2 | _,_ -> failwith "Type mismatch (simple checker broken B?)" in - loop t1 dst_unfld ctxt + loop t1 t2 ctxt let constrain_eq = constrain_rel ~rel:(fun o1 o2 -> Eq (o1,o2)) @@ -600,10 +592,10 @@ let rec process_expr ~output ((e_id,_),expr) = let () = assert (output <> None) in let (output_types, return_type) = Option.get output in let%bind t2 = lkp_split (SRet e_id) v in - constrain_eq (*~e_id*) ~src:t2 ~dst:return_type + constrain_eq ~src:t2 ~dst:return_type >> miter (fun (v,out_t) -> let%bind curr_t = lkp v in - constrain_eq (*~e_id*) ~src:curr_t ~dst:out_t + constrain_eq ~src:curr_t ~dst:out_t ) output_types >> return `Return | Unit -> return `Cont @@ -633,7 +625,7 @@ let rec process_expr ~output ((e_id,_),expr) = in begin%m constrain_wf_loop o' vt'; - constrain_eq (*~e_id*) ~src:t2 ~dst:vt'; + constrain_eq ~src:t2 ~dst:vt'; update_type v @@ Ref (vt',o'); constrain_write o; constrain_write o'; @@ -645,7 +637,7 @@ let rec process_expr ~output ((e_id,_),expr) = begin%m constrain_wf_loop o new_cts; constrain_write o; - constrain_eq (*~e_id*) ~src:cts ~dst:new_cts; + constrain_eq ~src:cts ~dst:new_cts; update_type base @@ Array (new_cts,o); process_expr ~output nxt end @@ -653,7 +645,7 @@ let rec process_expr ~output ((e_id,_),expr) = let%bind (src_up,st,st') = fresh_ap e_id src and (dst_up,dt,dt') = fresh_ap e_id dst in begin%m - shuffle_types (*~e_id*) ~src:(st,st') ~dst:(dt,dt'); + shuffle_types ~src:(st,st') ~dst:(dt,dt'); src_up; dst_up; process_expr ~output nxt @@ -662,10 +654,10 @@ let rec process_expr ~output ((e_id,_),expr) = | Let (PVar v,Mkref (RVar src),body) -> let%bind t2 = lkp_split (SBind e_id) src in begin - match%bind get_type_scheme (*e_id v*) with + match%bind get_type_scheme with | (Ref (ref_cont,o)) as t' -> begin%m - constrain_eq (*~e_id*) ~src:t2 ~dst:ref_cont; + constrain_eq ~src:t2 ~dst:ref_cont; add_constraint @@ Write o; with_types [(v,t')] @@ process_expr ~output body end From 8ea777989de6dcdc53dd18d2dfd1fa65f34cb5e7 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Fri, 9 Jun 2023 11:54:45 +0900 Subject: [PATCH 041/108] update some functions --- src/ownershipInference.ml | 77 ++++++++++++++++----------------------- 1 file changed, 32 insertions(+), 45 deletions(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 55cfe772..d38e6a5e 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -133,33 +133,6 @@ type infr_options = bool let infr_opts_default = false -(* let unfold = - let rec subst_once id sub = function - | TVar id' when id = id' -> sub - | (Int as t) - | (TVar _ as t) -> t - | Ref (t,o) -> Ref (subst_once id sub t,o) - | Array (t,o) -> Array (subst_once id sub t,o) - | Tuple tl -> Tuple (List.map (subst_once id sub) tl) - | Mu (id',t) -> assert (id' <> id); Mu (id',subst_once id sub t) - | IntList -> assert false - in - let rec unfold_loop ~unfld = function - | TVar id -> assert (IntSet.mem id unfld); TVar id - | Int -> Int - | Ref (t,o) -> Ref (unfold_loop ~unfld t,o) - | Array (t,o) -> Array (unfold_loop ~unfld t,o) - | Mu (id,t) when IntSet.mem id unfld -> - Mu (id,unfold_loop ~unfld t) - | Tuple tl -> - Tuple (List.map (unfold_loop ~unfld) tl) - | (Mu (id,t)) as mu -> - let t' = subst_once id mu t in - unfold_loop ~unfld:(IntSet.add id unfld) t' - | IntList -> assert false - in - unfold_loop ~unfld:IntSet.empty *) - (** The optional relaxed argument indicates whether the passed in constraint should be applied only if the relaxed flag is in the indicated state. otherwise the constraint is added unconditionally.*) @@ -174,15 +147,15 @@ let%lm add_constraint ?relaxed c ctxt = (** Shuffle the ownership between two source types (t1 and t2) and two destination types (t1' and t2'). The two types must be iso-recursively equal; they are walked in parallel, at references the ownerships are shuffled with the Shuff constraint. *) -let%lm shuffle_types (*~e_id*) ~src:(t1,t1') ~dst:(t2,t2') ctxt = - (* check whether we need to unfold the "destination", which in this case is t2/t2', not t1/t1'. - This confusing naming arises from this functions use in returning ownership to a recursive - data structure, in that case, t2/t2' represents the destination for the return operation. *) - let unfold_dst = - (* if IntSet.mem e_id ctxt.iso.SimpleChecker.SideAnalysis.unfold_locs then - unfold - else *) - Fun.id +let%lm shuffle_types ~src:(t1,t1') ~dst:(t2,t2') ctxt = + let rec shuffle_intlist ol1 ol2 ol1' ol2' ctxt = + match ol1,ol2,ol1',ol2' with + | [],[],[],[] -> ctxt + | h1 :: r1, h2 :: r2, h1' :: r1', h2' :: r2' -> + shuffle_intlist r1 r2 r1' r2' @@ + { ctxt with + ocons = Shuff ((h1,h2),(h1',h2')) :: ctxt.ocons } + | _ -> failwith "Ownership arity is different between IntList types" in let rec loop t1 t2 t1' t2' ctxt = match t1,t2,t1',t2' with @@ -198,12 +171,12 @@ let%lm shuffle_types (*~e_id*) ~src:(t1,t1') ~dst:(t2,t2') ctxt = List.fold_left2 (fun ctxt' (te1,te2) (te1',te2') -> loop te1 te2 te1' te2' ctxt' ) ctxt orig_tl new_tl - | Mu (_,m1), Mu (_,m2), Mu (_,m1'), Mu (_,m2') -> - loop m1 m2 m1' m2' ctxt | TVar _, TVar _, TVar _, TVar _ -> ctxt + | IntList ol1, IntList ol2, IntList ol1', IntList ol2' -> + shuffle_intlist ol1 ol2 ol1' ol2' ctxt | _ -> failwith "Type mismatch (simple checker broken D?)" in - loop t1 (unfold_dst t2) t1' (unfold_dst t2') ctxt + loop t1 t2 t1' t2' ctxt (** Like shuffle above, but no unfolding occurs, and the destination type [out] must have an ownership equal to the "pointwise" sum of ownerships in [t1] and [t2]. *) @@ -245,8 +218,7 @@ let rec unfold_simple arg mu = let rec constrain_wf_loop o t ctxt = match t with | TVar _ - | Int - | IntList _ -> (ctxt,()) + | Int -> (ctxt,()) | Tuple tl -> miter (constrain_wf_loop o) tl ctxt | Ref (t',o') @@ -254,6 +226,15 @@ let rec constrain_wf_loop o t ctxt = constrain_wf_loop o' t' { ctxt with ocons = Wf (o,o')::ctxt.ocons } + | IntList ol -> + let rec loop ctxt = function + | [] + | [_] -> ctxt + | h1 :: h2 :: r -> loop { + ctxt with ocons = Wf (h1, h2)::ctxt.ocons + } (h2::r) + in + (loop ctxt ol, ()) (** Like constrain_wf_above, but only begin emitting wf constraints when the first ownership variable is encountered *) @@ -361,6 +342,13 @@ let mtmap p f tl = allocated are done so in magic context [loc] *) (* This needs to record *) let make_fresh_type loc root t = + let rec make_fresh_ownership_list loc root = function + | [] -> return [] + | _ :: r -> + let%bind o = alloc_ovar loc root in + let%bind r' = make_fresh_ownership_list loc root r in + return (o :: r') + in let rec loop root = function | Int -> return Int | Array (t,_) -> @@ -375,10 +363,9 @@ let make_fresh_type loc root t = | Tuple tl -> let%bind tl' = mtmap root loop tl in return @@ Tuple tl' - | Mu (id,t) -> - let%bind t' = loop root t in - return @@ Mu (id,t') - | IntList -> assert false + | IntList ol -> + let%bind ol' = make_fresh_ownership_list loc root ol in + return @@ IntList ol' in let%bind t' = loop root t in constrain_well_formed t' >> return t' From dc07082364886fb3d4cf3aff4a5c9a6a531069a5 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 12 Jun 2023 15:45:51 +0900 Subject: [PATCH 042/108] update ownership inference --- src/ownershipInference.ml | 57 +++++++++++++-------------------------- 1 file changed, 18 insertions(+), 39 deletions(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index d38e6a5e..be55862a 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -178,28 +178,6 @@ let%lm shuffle_types ~src:(t1,t1') ~dst:(t2,t2') ctxt = in loop t1 t2 t1' t2' ctxt -(** Like shuffle above, but no unfolding occurs, and the destination type [out] must - have an ownership equal to the "pointwise" sum of ownerships in [t1] and [t2]. *) -let%lm sum_ownership t1 t2 out ctxt = - let rec loop t1 t2 out ctxt = - match t1,t2,out with - | Int, Int, Int -> ctxt - | Ref (r1,o1), Ref (r2,o2), Ref (ro,oo) -> - loop r1 r2 ro - { ctxt with ocons = (Split (oo,(o1,o2)))::ctxt.ocons} - | Tuple tl1, Tuple tl2, Tuple tl_out -> - fold_left3i (fun ctxt _ e1 e2 e_out -> - loop e1 e2 e_out ctxt) ctxt tl1 tl2 tl_out - | Mu (_,t1'), Mu (_,t2'), Mu (_,out') -> - loop t1' t2' out' ctxt - | TVar _,TVar _, TVar _ -> ctxt - | Array (et1,o1), Array (et2,o2), Array (et3,o3) -> - loop et1 et2 et3 - { ctxt with ocons = Split (o3,(o1,o2))::ctxt.ocons } - | _ -> failwith "Mismatched types (simple checker broken C?)" - in - loop t1 t2 out ctxt - let rec unfold_simple arg mu = function | `Int -> `Int @@ -234,6 +212,10 @@ let rec constrain_wf_loop o t ctxt = ctxt with ocons = Wf (h1, h2)::ctxt.ocons } (h2::r) in + let ctxt = match ol with + [] -> ctxt + | h :: _ -> {ctxt with ocons = Wf (o,h)::ctxt.ocons} + in (loop ctxt ol, ()) (** Like constrain_wf_above, but only begin emitting wf constraints @@ -242,10 +224,11 @@ let rec constrain_well_formed = function | TVar _ | Int -> return () | Tuple tl -> miter constrain_well_formed tl - | Mu (_,t) -> constrain_well_formed t | Ref (t,o) | Array (t,o) -> constrain_wf_loop o t - | IntList -> assert false + | IntList ol -> match ol with + [] -> return () + | h :: r -> constrain_wf_loop h (IntList r) (** Record the allocation of an ownership variable in the context of a magic operation. Updates the gen map *) @@ -512,26 +495,30 @@ let lkp_split loc v = let%bind (t1,t2) = split_type loc (P.var v) t in update_type v t1 >> return t2 -(* let%lq is_unfold eid ctxt = - let open SimpleChecker.SideAnalysis in - IntSet.mem eid ctxt.iso.unfold_locs *) - let%lq theta f ctxt = SM.find f ctxt.theta (** Functionally quite similar to split type, but rather than splitting a type in place and giving the two result types, constrains t1 and t2 to be the result of splitting out *) let%lm sum_types t1 t2 out ctxt = + let rec sum_ownership_list ol1 ol2 outl ctxt = + match ol1, ol2, outl with + [],[],[] -> ctxt + | h1 :: r1, h2 :: r2, outh :: outr -> + sum_ownership_list r1 r2 outr { ctxt with ocons = Split (outh, (h1, h2))::ctxt.ocons } + | _ -> failwith "Ownership arity is different between IntList types" + in let rec loop t1 t2 out ctxt = match t1,t2,out with | TVar _,TVar _,TVar _ | Int,Int,Int -> ctxt - | Mu (_,t1), Mu (_,t2), Mu (_,t3) -> loop t1 t2 t3 ctxt | Tuple tl1,Tuple tl2, Tuple tl3 -> fold_left3i (fun ctxt _ t1 t2 t3 -> loop t1 t2 t3 ctxt) ctxt tl1 tl2 tl3 | Ref (t1,o1), Ref (t2,o2), Ref (out,oout) | Array (t1,o1), Array (t2,o2), Array (out,oout) -> loop t1 t2 out { ctxt with ocons = Split (oout,(o1,o2))::ctxt.ocons } + | IntList ol1, IntList ol2, IntList outl -> + sum_ownership_list ol1 ol2 outl ctxt | _,_,_ -> failwith "type mismatch (simple checker broken A?)" in loop t1 t2 out ctxt @@ -544,12 +531,11 @@ let%lm max_ovar ov ctxt = let rec max_type = function | Array (_,o) -> max_ovar o | Int | TVar _ -> return () - | Mu (_,t) -> max_type t | Tuple tl -> miter max_type tl | Ref (t,o) -> max_ovar o >> max_type t - | IntList -> assert false + | IntList ol -> miter max_ovar ol let process_call e_id c = let%bind arg_types = mmap (lkp_split @@ SCall e_id) c.arg_names @@ -678,14 +664,7 @@ let rec process_expr ~output ((e_id,_),expr) = end | Deref v -> let%bind (t,o) = lkp_ref v in - let%bind (t1,t2_pre) = split_type (SBind e_id) (P.deref (P.var v)) t in - (* let%bind uf = is_unfold e_id in *) - let t2 = - (* if uf then - unfold t2_pre - else *) - t2_pre - in + let%bind (t1,t2) = split_type (SBind e_id) (P.deref (P.var v)) t in begin%m update_type v @@ Ref (t1,o); (* only require the ownership to be non-zero in relaxed mode (the relaxed argument) *) From d7d9e6eb6851d90a9122e22ddb99f65007d8e711 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 12 Jun 2023 16:07:13 +0900 Subject: [PATCH 043/108] add o_arity argument to some functions --- src/ownershipInference.ml | 57 +++++++++++++++++++-------------------- 1 file changed, 28 insertions(+), 29 deletions(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index be55862a..1de04ff5 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -428,10 +428,9 @@ let fresh_ap e_id (p: P.concr_ap) = ) steps (* this must record *) -let get_type_scheme (*e_id v ctxt*) = - assert false - (* let st = IntMap.find e_id ctxt.iso.SimpleChecker.SideAnalysis.let_types in - lift_to_ownership (MGen e_id) (P.var v) st ctxt *) +let get_type_scheme e_id v ctxt ~o_arity = + let st = IntMap.find e_id ctxt.iso.SimpleChecker.SideAnalysis.let_types in + lift_to_ownership (MGen e_id) (P.var v) st ctxt ~o_arity let tarray o t = Array (t,o) let tref o t = Ref (t,o) @@ -556,7 +555,7 @@ let process_call e_id c = let%lm save_type e_id ctxt = { ctxt with save_env = IntMap.add e_id ctxt.gamma ctxt.save_env } -let rec process_expr ~output ((e_id,_),expr) = +let rec process_expr ~output ((e_id,_),expr) ~o_arity = save_type e_id >> match expr with | Fail -> @@ -573,21 +572,21 @@ let rec process_expr ~output ((e_id,_),expr) = >> return `Return | Unit -> return `Cont | Seq (e1,e2) -> - let%bind stat = process_expr ~output e1 in + let%bind stat = process_expr ~output e1 ~o_arity in assert (stat <> `Return); - process_expr ~output e2 + process_expr ~output e2 ~o_arity | NCond (v,e1,e2) -> process_conditional ~e_id ~tr_branch:( let%bind t = lkp v in let%bind t' = make_fresh_type (MGen e_id) (P.var v) t in update_type v t' - ) ~output e1 e2 + ) ~output e1 e2 ~o_arity | Cond (_,e1,e2) -> - process_conditional ~e_id ~tr_branch:(return ()) ~output e1 e2 + process_conditional ~e_id ~tr_branch:(return ()) ~output e1 e2 ~o_arity | Assign (v,IInt _,nxt) -> let%bind (t,o) = lkp_ref v in assert (t = Int); - constrain_write o >> process_expr ~output nxt + constrain_write o >> process_expr ~output nxt ~o_arity | Assign (v, IVar i,nxt) -> let%bind t2 = lkp_split (SBind e_id) i and (vt,o) = lkp_ref v in @@ -602,7 +601,7 @@ let rec process_expr ~output ((e_id,_),expr) = update_type v @@ Ref (vt',o'); constrain_write o; constrain_write o'; - process_expr ~output nxt + process_expr ~output nxt ~o_arity end | Update (base,_,contents,nxt) -> let%bind (cts,o) = lkp_array base @@ -612,7 +611,7 @@ let rec process_expr ~output ((e_id,_),expr) = constrain_write o; constrain_eq ~src:cts ~dst:new_cts; update_type base @@ Array (new_cts,o); - process_expr ~output nxt + process_expr ~output nxt ~o_arity end | Alias(src,dst,nxt) -> let%bind (src_up,st,st') = fresh_ap e_id src @@ -621,29 +620,29 @@ let rec process_expr ~output ((e_id,_),expr) = shuffle_types ~src:(st,st') ~dst:(dt,dt'); src_up; dst_up; - process_expr ~output nxt + process_expr ~output nxt ~o_arity end - | Assert (_,nxt) -> process_expr ~output nxt + | Assert (_,nxt) -> process_expr ~output nxt ~o_arity | Let (PVar v,Mkref (RVar src),body) -> let%bind t2 = lkp_split (SBind e_id) src in begin - match%bind get_type_scheme with + match%bind get_type_scheme e_id v ~o_arity with | (Ref (ref_cont,o)) as t' -> begin%m constrain_eq ~src:t2 ~dst:ref_cont; add_constraint @@ Write o; - with_types [(v,t')] @@ process_expr ~output body + with_types [(v,t')] @@ process_expr ~output body ~o_arity end | _ -> assert false end | Let (PVar v,(Null | MkArray _),body) -> - let%bind t = get_type_scheme (*e_id v*) in - with_types [(v,t)] @@ process_expr ~output body + let%bind t = get_type_scheme e_id v ~o_arity in + with_types [(v,t)] @@ process_expr ~output body ~o_arity | Let (PVar v,Mkref (RNone | RInt _), body) -> let%bind new_var = alloc_ovar (MGen e_id) (P.var v) in begin%m add_constraint @@ Write new_var; - with_types [(v,Ref (Int, new_var))] @@ process_expr ~output body + with_types [(v,Ref (Int, new_var))] @@ process_expr ~output body ~o_arity end | Let (patt,rhs,body) -> let%bind to_bind = @@ -700,12 +699,12 @@ let rec process_expr ~output ((e_id,_),expr) = | PTuple _,_ -> assert false in let bindings = assign_patt_loop [] patt to_bind in - with_types bindings @@ process_expr ~output body + with_types bindings @@ process_expr ~output body ~o_arity | Match (_, _, _, _, _) -> assert false -and process_conditional ~e_id ~tr_branch ~output e1 e2 ctxt = +and process_conditional ~e_id ~tr_branch ~output e1 e2 ctxt ~o_arity = let (ctxt_tpre,()) = tr_branch ctxt in - let (ctxt_t,tfl) = process_expr ~output e1 ctxt_tpre in - let (ctxt_f,ffl) = process_expr ~output e2 { ctxt_t with gamma = ctxt.gamma } in + let (ctxt_t,tfl) = process_expr ~output e1 ctxt_tpre ~o_arity in + let (ctxt_f,ffl) = process_expr ~output e2 { ctxt_t with gamma = ctxt.gamma } ~o_arity in match tfl,ffl with | `Return,f -> ctxt_f,f | `Cont,`Return -> { ctxt_f with gamma = ctxt_t.gamma },`Cont @@ -716,8 +715,8 @@ and process_conditional ~e_id ~tr_branch ~output e1 e2 ctxt = let constrain_ge = constrain_rel ~rel:(fun o1 o2 -> Ge (o1, o2)) in begin%m (* notice that we allow ownership to be discarded at join points, the reason for MJoin *) - constrain_ge (*~e_id*) ~src:tt ~dst:t'; - constrain_ge (*~e_id*) ~src:ft ~dst:t'; + constrain_ge ~src:tt ~dst:t'; + constrain_ge ~src:ft ~dst:t'; update_type k t' end ) (StringMap.bindings ctxt_f.gamma) { ctxt_f with gamma = StringMap.empty } in @@ -734,13 +733,13 @@ module Result = struct } end -let analyze_fn ctxt fn = +let analyze_fn ctxt fn ~o_arity = let arg_names = fn.args in let fn_type = SM.find fn.name ctxt.theta in let start_gamma = SM.of_bindings @@ List.combine arg_names fn_type.arg_types in let out_type = List.combine arg_names fn_type.output_types in let ctxt = List.fold_left (fun ctxt ty -> fst @@ max_type ty ctxt) ctxt fn_type.output_types in - let (ctxt,_) = process_expr ~output:(Some (out_type,fn_type.result_type)) fn.body { ctxt with gamma = start_gamma } in + let (ctxt,_) = process_expr ~output:(Some (out_type,fn_type.result_type)) fn.body { ctxt with gamma = start_gamma } ~o_arity in { ctxt with gamma = SM.empty } let infer ~opts (simple_types,iso) (fn,prog) = @@ -810,8 +809,8 @@ let infer ~opts (simple_types,iso) (fn,prog) = { acc with theta = SM.add nm ft acc.theta } ) (ArgOptions.get_intr opts).op_interp in - let ctxt = List.fold_left analyze_fn ctxt fn in - let (ctxt,_) = process_expr ~output:None prog ctxt in + let ctxt = List.fold_left (analyze_fn ~o_arity:opts.ArgOptions.ownership_arity) ctxt fn in + let (ctxt,_) = process_expr ~output:None prog ctxt ~o_arity:opts.ArgOptions.ownership_arity in { Result.ocons = ctxt.ocons; Result.ovars = ctxt.ovars; From 284152b9caad355962a2ff50ca42993c5154c410 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 15 Jun 2023 16:24:06 +0900 Subject: [PATCH 044/108] fix split_type (WIP) --- src/ownershipInference.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 1de04ff5..aecbd8e5 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -447,8 +447,8 @@ let rec split_type loc p = in function | (Int as t) - | (TVar _ as t) - | (IntList _ as t) -> return (t,t) + | (TVar _ as t) -> return (t,t) + | (IntList ol) -> assert false | Tuple tl -> let%bind split_list = mtmap p (split_type loc) tl in let (tl1,tl2) = List.split split_list in From a9cce677ee8692cf816ff15c1b53cfb9451ff1da Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Fri, 16 Jun 2023 09:11:07 +0900 Subject: [PATCH 045/108] update split_type --- src/ownershipInference.ml | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index aecbd8e5..ee706ccb 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -441,14 +441,24 @@ let rec split_type loc p = and (o1,o2) = alloc_split loc p o in begin%m constrain_wf_loop o1 t1; - constrain_wf_loop o2 t2; - return @@ (k o1 t1,k o2 t2) + constrain_wf_loop o2 t2; + return @@ (k o1 t1,k o2 t2) end in + let rec split_ownership_list ol = + match ol with + | [] -> return ([],[]) + | o :: r -> + let%bind (o1,o2) = alloc_split loc p o in + let%bind (r1,r2) = split_ownership_list r in + return @@ (o1 :: r1,o2 :: r2) + in function | (Int as t) | (TVar _ as t) -> return (t,t) - | (IntList ol) -> assert false + | (IntList ol) -> + let%bind (ol1, ol2) = split_ownership_list ol in + return @@ (IntList ol1,IntList ol2) | Tuple tl -> let%bind split_list = mtmap p (split_type loc) tl in let (tl1,tl2) = List.split split_list in From 42a1cef0dbe65e4a3f0528e2065498d93bb6f458 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Fri, 16 Jun 2023 09:11:25 +0900 Subject: [PATCH 046/108] some fix --- src/ownershipInference.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index ee706ccb..d60d8feb 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -456,15 +456,15 @@ let rec split_type loc p = function | (Int as t) | (TVar _ as t) -> return (t,t) - | (IntList ol) -> - let%bind (ol1, ol2) = split_ownership_list ol in - return @@ (IntList ol1,IntList ol2) | Tuple tl -> let%bind split_list = mtmap p (split_type loc) tl in let (tl1,tl2) = List.split split_list in return @@ (Tuple tl1,Tuple tl2) | Ref (t,o) -> split_mem o t P.deref tref | Array (t,o) -> split_mem o t P.elem tarray + | (IntList ol) -> + let%bind (ol1, ol2) = split_ownership_list ol in + return @@ (IntList ol1,IntList ol2) (** Constrain to types to be pointwse constrained by the generator rel, which From 0e298946924513e2e3a1d6c95bbd39352111fff7 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Fri, 16 Jun 2023 14:24:08 +0900 Subject: [PATCH 047/108] add tests and functions --- src/ownershipInference.ml | 26 +++++++++++++++++++++++--- src/test/list/not-variable-pattern.imp | 8 ++++++++ 2 files changed, 31 insertions(+), 3 deletions(-) create mode 100644 src/test/list/not-variable-pattern.imp diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index d60d8feb..6f4c43e2 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -654,6 +654,16 @@ let rec process_expr ~output ((e_id,_),expr) ~o_arity = add_constraint @@ Write new_var; with_types [(v,Ref (Int, new_var))] @@ process_expr ~output body ~o_arity end + | Let (PVar v, Nil, body) -> + let rec loop ol ~o_arity = + if o_arity <= 0 then return ol + else + let%bind o = alloc_ovar (MGen e_id) (P.var v) in + loop (o :: ol) ~o_arity:(o_arity - 1) + in + let%bind o_list = loop [] ~o_arity in + let t = IntList o_list in + with_types [(v,t)] @@ process_expr ~output body ~o_arity | Let (patt,rhs,body) -> let%bind to_bind = match rhs with @@ -697,8 +707,8 @@ let rec process_expr ~output ((e_id,_),expr) ~o_arity = ) t_init in return @@ Tuple tl | Call c -> process_call e_id c - | Cons _ - | Nil -> return IntList + | Cons _ -> assert false + | Nil -> assert false in let rec assign_patt_loop acc patt ty = match patt,ty with @@ -710,7 +720,17 @@ let rec process_expr ~output ((e_id,_),expr) ~o_arity = in let bindings = assign_patt_loop [] patt to_bind in with_types bindings @@ process_expr ~output body ~o_arity - | Match (_, _, _, _, _) -> assert false + | Match (e1, e2, h, r, e3) -> + let v = match e1 with + Var v -> v + | _ -> failwith "Not implemented" + in + let%bind t = lkp v in + let t = match t with + IntList _ -> t + | _ -> failwith "The value pattern matched must be IntList" + in + and process_conditional ~e_id ~tr_branch ~output e1 e2 ctxt ~o_arity = let (ctxt_tpre,()) = tr_branch ctxt in let (ctxt_t,tfl) = process_expr ~output e1 ctxt_tpre ~o_arity in diff --git a/src/test/list/not-variable-pattern.imp b/src/test/list/not-variable-pattern.imp new file mode 100644 index 00000000..21bf4bc1 --- /dev/null +++ b/src/test/list/not-variable-pattern.imp @@ -0,0 +1,8 @@ +{ + let x = mkref Nil in + let y = mkref (Cons 1 x) in + let z = mkref (Cons 2 y) in + match Cons 3 z with + Nil -> () + | Cons h r -> () +} \ No newline at end of file From 0679c3032cee8709e1199a41291993fec5ae6a2d Mon Sep 17 00:00:00 2001 From: artoy Date: Sun, 18 Jun 2023 20:25:00 +0900 Subject: [PATCH 048/108] implement pattern matching (WIP) --- src/ownershipInference.ml | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 6f4c43e2..5d6a8213 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -726,11 +726,12 @@ let rec process_expr ~output ((e_id,_),expr) ~o_arity = | _ -> failwith "Not implemented" in let%bind t = lkp v in - let t = match t with - IntList _ -> t - | _ -> failwith "The value pattern matched must be IntList" + let type_of_r = match t with + IntList ol -> Ref(IntList (List.tl ol @ [List.hd @@ List.rev ol]), List.hd ol) + | _ -> failwith "The value pattern matched msust be IntList" in - + (* TODO: implement process pattern matching with reference to process_conditional *) + with_types [(h, Int); (r, type_of_r)] @@ process_expr ~output e3 ~o_arity and process_conditional ~e_id ~tr_branch ~output e1 e2 ctxt ~o_arity = let (ctxt_tpre,()) = tr_branch ctxt in let (ctxt_t,tfl) = process_expr ~output e1 ctxt_tpre ~o_arity in From 7ea6d9e45efb24821d9e477ee4f4528f30cb63d3 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 19 Jun 2023 14:48:31 +0900 Subject: [PATCH 049/108] add process pattern matching --- src/ownershipInference.ml | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 6f4c43e2..03eff5fb 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -707,6 +707,7 @@ let rec process_expr ~output ((e_id,_),expr) ~o_arity = ) t_init in return @@ Tuple tl | Call c -> process_call e_id c + (* these should not be possible *) | Cons _ -> assert false | Nil -> assert false in @@ -751,6 +752,25 @@ and process_conditional ~e_id ~tr_branch ~output e1 e2 ctxt ~o_arity = end ) (StringMap.bindings ctxt_f.gamma) { ctxt_f with gamma = StringMap.empty } in ctxt,`Cont +and process_pattern_matching ~e_id ~output e1 h r e2 ctxt ~o_arity = + let (ctxt_n, nfl) = process_expr ~output e1 ctxt ~o_arity in + let (ctxt_c, cfl) = process_expr ~output e2 { ctxt_n with gamma = StringMap.add h ctxt.gamma } ~o_arity in + match nfl,cfl with + | `Return, f -> ctxt_c, f + | `Cont, `Return -> { ctxt_c with gamma = ctxt_n.gamma }, `Cont + | `Cont, `Cont -> + let ctxt, () = miter (fun (k,ft) -> + let%bind t' = make_fresh_type (MJoin e_id) (P.var k) ft in + let tt = StringMap.find k ctxt_n.gamma in + let constrain_ge = constrain_rel ~rel:(fun o1 o2 -> Ge (o1, o2)) in + begin%m + (* notice that we allow ownership to be discarded at join points, the reason for MJoin *) + constrain_ge ~src:tt ~dst:t'; + constrain_ge ~src:ft ~dst:t'; + update_type k t' + end + ) (StringMap.bindings ctxt_c.gamma) { ctxt_c with gamma = StringMap.empty } in + ctxt, `Cont module Result = struct type t = { From 76f4bff58dde67ab883a2027aee123991cc35301 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 19 Jun 2023 15:11:05 +0900 Subject: [PATCH 050/108] complete implement match statement --- src/ownershipInference.ml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 125fd014..0745cd1c 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -731,8 +731,7 @@ let rec process_expr ~output ((e_id,_),expr) ~o_arity = IntList ol -> Ref(IntList (List.tl ol @ [List.hd @@ List.rev ol]), List.hd ol) | _ -> failwith "The value pattern matched msust be IntList" in - (* TODO: implement process pattern matching with reference to process_conditional *) - with_types [(h, Int); (r, type_of_r)] @@ process_expr ~output e3 ~o_arity + process_pattern_matching ~e_id ~output e2 h r type_of_r e3 ~o_arity and process_conditional ~e_id ~tr_branch ~output e1 e2 ctxt ~o_arity = let (ctxt_tpre,()) = tr_branch ctxt in let (ctxt_t,tfl) = process_expr ~output e1 ctxt_tpre ~o_arity in @@ -753,10 +752,10 @@ and process_conditional ~e_id ~tr_branch ~output e1 e2 ctxt ~o_arity = end ) (StringMap.bindings ctxt_f.gamma) { ctxt_f with gamma = StringMap.empty } in ctxt,`Cont -and process_pattern_matching ~e_id ~output e1 h r e2 ctxt ~o_arity = +and process_pattern_matching ~e_id ~output e1 h r type_of_r e2 ctxt ~o_arity = let (ctxt_n, nfl) = process_expr ~output e1 ctxt ~o_arity in - let (ctxt_c, cfl) = process_expr ~output e2 { ctxt_n with gamma = StringMap.add h ctxt.gamma } ~o_arity in - match nfl,cfl with + let (ctxt_c, cfl) = (with_types [(h, Int); (r, type_of_r)] @@ process_expr ~output e2 ~o_arity) { ctxt_n with gamma = ctxt.gamma } in + match nfl, cfl with | `Return, f -> ctxt_c, f | `Cont, `Return -> { ctxt_c with gamma = ctxt_n.gamma }, `Cont | `Cont, `Cont -> From fe3e44643bf30467288bbe01109a202a238da25f Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Tue, 20 Jun 2023 19:53:06 +0900 Subject: [PATCH 051/108] add WeakSplit (WIP) --- src/ownershipInference.ml | 29 +++++++++++++---------------- 1 file changed, 13 insertions(+), 16 deletions(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 0745cd1c..0b36eba0 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -24,6 +24,7 @@ type ocon = | Write of ownership (** Constraint ownership variable n to be 1 *) | Shuff of (ownership * ownership) * (ownership * ownership) (** ((r1, r2),(r1',r2')) is the shuffling of permissions s.t. r1 + r2 = r1' + r2' *) | Split of ownership * (ownership * ownership) (** Split (o,(s,t)) is the constraint that o = s + t *) + | WeakSplit of ownership * (ownership * ownership) (** WeakSplit (o,(s,t)) is the constraint that o >= s + t *) | Eq of ownership * ownership (** o1 = o2 *) | Wf of ownership * ownership (** For well-formedness: if o1 = 0, then o2 = 0 *) | Ge of ownership * ownership (** o1 >= o2 *) @@ -282,17 +283,17 @@ let alloc_split,alloc_ovar = in alloc_split,alloc_ovar +let rec alloc_ovar_list loc p ~o_arity = + if o_arity <= 0 then return [] + else ( + let%bind o = alloc_ovar loc p in + let%bind o_list = alloc_ovar_list loc p ~o_arity:(o_arity - 1) in + return (o :: o_list) + ) + (** Lift a simple type into an ownership type (of type otype) *) (* this must record *) let lift_to_ownership loc root t_simp ~o_arity = - let rec lift_list_to_ownership loc root ~o_arity = - if o_arity <= 0 then return [] - else ( - let%bind o = alloc_ovar loc root in - let%bind o_list = lift_list_to_ownership loc root ~o_arity:(o_arity - 1) in - return (o :: o_list) - ) - in let rec simple_lift ~unfld root = function | `Array `Int -> @@ -310,7 +311,7 @@ let lift_to_ownership loc root t_simp ~o_arity = ) tl in return @@ Tuple tl' | `IntList -> - let%bind o_list = lift_list_to_ownership loc root ~o_arity in + let%bind o_list = alloc_ovar_list loc root ~o_arity in return @@ IntList o_list in let%bind t = simple_lift ~unfld:IntSet.empty root t_simp in @@ -655,15 +656,11 @@ let rec process_expr ~output ((e_id,_),expr) ~o_arity = with_types [(v,Ref (Int, new_var))] @@ process_expr ~output body ~o_arity end | Let (PVar v, Nil, body) -> - let rec loop ol ~o_arity = - if o_arity <= 0 then return ol - else - let%bind o = alloc_ovar (MGen e_id) (P.var v) in - loop (o :: ol) ~o_arity:(o_arity - 1) - in - let%bind o_list = loop [] ~o_arity in + let%bind o_list = alloc_ovar_list (MGen e_id) (P.var v) ~o_arity in let t = IntList o_list in with_types [(v,t)] @@ process_expr ~output body ~o_arity + | Let (PVar v, Cons (h, r), body) -> + let ol_x = alloc_ovar_list (MGen) ~o_arity in | Let (patt,rhs,body) -> let%bind to_bind = match rhs with From d639b6316eef71ac1e33a491a3cb4185599987c5 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 22 Jun 2023 18:45:24 +0900 Subject: [PATCH 052/108] implement cons (WIP) --- src/ownershipInference.ml | 30 +++++++++++++++++++++++++++--- 1 file changed, 27 insertions(+), 3 deletions(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 0b36eba0..445e06f0 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -256,7 +256,7 @@ let%lm record_split loc p o1 o2 ctxt = instrumented to record using the functions above. [alloc_ovar] is to generate a fresh ownership variable (always??? in the context of a generation op) and alloc_split generates two ownership variables in the context of a split operation. *) -let alloc_split,alloc_ovar = +let alloc_split,alloc_ovar,alloc_weak_split,alloc_weak_split_with_another = let alloc_ovar_inner ctxt = let new_ovar = ctxt.v_counter in let max_vars = @@ -281,7 +281,20 @@ let alloc_split,alloc_ovar = let%bind o = alloc_ovar_inner in record_alloc loc p o >> return o in - alloc_split,alloc_ovar + let alloc_weak_split loc p o = + let%bind o1 = alloc_ovar_inner + and o2 = alloc_ovar_inner in + add_constraint (WeakSplit (o,(o1,o2))) >> + record_split loc p o1 o2 >> + return (o1,o2) + in + let alloc_weak_split_with_another loc p o1 o2 = + let%bind o3 = alloc_ovar_inner in + add_constraint (WeakSplit (o1,(o2,o3))) >> + record_split loc p o2 o3 >> + return o3 + in + alloc_split,alloc_ovar,alloc_weak_split,alloc_weak_split_with_another let rec alloc_ovar_list loc p ~o_arity = if o_arity <= 0 then return [] @@ -660,7 +673,18 @@ let rec process_expr ~output ((e_id,_),expr) ~o_arity = let t = IntList o_list in with_types [(v,t)] @@ process_expr ~output body ~o_arity | Let (PVar v, Cons (h, r), body) -> - let ol_x = alloc_ovar_list (MGen) ~o_arity in + let split_type_cons = function + | IntList ol -> ( + let rec loop ol ~o_arity ol1 ol2 = + match ol with + | [o] -> + | [h :: r] -> + in + let ol1, ol2 = loop ol ~o_arity [] [] in + + ) + | _ -> failwith "The type of second argument of Cons must be IntList." + in | Let (patt,rhs,body) -> let%bind to_bind = match rhs with From e49f75b1a588c69b4ecfd288237d014566afe0af Mon Sep 17 00:00:00 2001 From: artoy Date: Sat, 24 Jun 2023 13:34:35 +0900 Subject: [PATCH 053/108] WIP --- src/ownershipInference.ml | 30 ++++++++++++++++++++++-------- 1 file changed, 22 insertions(+), 8 deletions(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 445e06f0..0d1a5b5c 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -674,17 +674,31 @@ let rec process_expr ~output ((e_id,_),expr) ~o_arity = with_types [(v,t)] @@ process_expr ~output body ~o_arity | Let (PVar v, Cons (h, r), body) -> let split_type_cons = function - | IntList ol -> ( - let rec loop ol ~o_arity ol1 ol2 = + | Ref(IntList ol, o) -> ( + let rec split_loop ol ol1 ol2 = match ol with - | [o] -> - | [h :: r] -> + | [o] -> return (List.rev ol1, List.rev ol2, o) + | h :: r -> + let%bind (o1, o2) = alloc_weak_split (SBind e_id) (P.var v) h in + return @@ split_loop r (o1 :: ol1) (o2 :: ol2) + | [] -> assert false in - let ol1, ol2 = loop ol ~o_arity [] [] in - - ) - | _ -> failwith "The type of second argument of Cons must be IntList." + let%bind (ol1, ol2, o_not_splited) = split_loop ol [] [] in + let%bind (ol1_head, ol2_outer_ref) = alloc_weak_split (SBind e_id) (P.var v) o in + let%bind ol2_tail = alloc_weak_split_with_another (SBind e_id) (P.var v) o_not_splited (List.hd @@ List.rev ol1) in + return (IntList(ol1_head :: ol1), Ref(IntList(ol2 @ [ol2_tail]), ol2_outer_ref)) + ) + | _ -> failwith "The type of second argument of Cons must be Ref IntList." in + match r with + | Var v' -> ( + let (t1, t2) = split_type_cons @@ lkp v' in + begin%m + update_type v t1; + with_types [(v, t2)] @@ process_expr ~output body ~o_arity + end + ) + | _ -> failwith("Not implemented.") | Let (patt,rhs,body) -> let%bind to_bind = match rhs with From f02da0c67f926d46486122780e9ede1c15adf30a Mon Sep 17 00:00:00 2001 From: artoy Date: Sun, 25 Jun 2023 12:01:45 +0900 Subject: [PATCH 054/108] implemented (but error occurs) --- src/consort.ml | 32 +++++++++++++++----------------- src/ownershipInference.ml | 11 ++++++----- src/ownershipSolver.ml | 10 ++++++++++ 3 files changed, 31 insertions(+), 22 deletions(-) diff --git a/src/consort.ml b/src/consort.ml index fe1bfbba..c7bd40c3 100644 --- a/src/consort.ml +++ b/src/consort.ml @@ -53,7 +53,7 @@ let pcomment ~body = let open PrettyPrint in pblock ~nl:true ~op:(ps "/*") ~body ~close:(ps "*/") -(* let print_program ~o_map ~o_printer r ast = +let print_program ~o_map ~o_printer r ast = let open PrettyPrint in let open OwnershipInference.Result in let rec print_type = @@ -75,15 +75,14 @@ let pcomment ~body = pf "[%a]@ %a" (ul print_type) t (ul o_printer) (o_map o) - | Mu (id,t) -> - pf "%s '%d.@ %a" - Greek.mu - id - (ul print_type) t | TVar id -> pf "'%d" id - | IntList -> - ps "int list" + | IntList ol -> + pl [ + ps "int list @["; + psep_gen (pf ", ") @@ List.map (fun o -> pf "%a" (ul o_printer) (o_map o)) ol; + ps "]" + ] in let print_type_binding (k, t) = pb [pf "%s: " k; print_type t] in let print_type_sep t = List.map print_type t |> psep_gen (pf ",@ ") in @@ -113,7 +112,7 @@ let pcomment ~body = newline ] in - AstPrinter.pretty_print_program ~annot:pp_ty_env ~annot_fn:pp_f_type stdout ast *) + AstPrinter.pretty_print_program ~annot:pp_ty_env ~annot_fn:pp_f_type stdout ast (* let print_fold_locations simple_res = let open SimpleChecker.SideAnalysis in @@ -122,16 +121,16 @@ let pcomment ~body = Std.IntSet.iter (Printf.printf "* %d\n") side.fold_locs; print_endline "<<<" *) -(* let print_inference infer_res ast = +let print_inference infer_res ast = let open PrettyPrint in let open OwnershipInference in let o_map o = o in let o_printer = function | OConst o -> pf "%f" o | OVar v -> pf "$%d" v in - print_program ~o_map ~o_printer infer_res ast *) + print_program ~o_map ~o_printer infer_res ast -(* let print_ownership ownership_res infer_res ast = +let print_ownership ownership_res infer_res ast = let open PrettyPrint in let open OwnershipInference in match ownership_res with @@ -141,7 +140,7 @@ let pcomment ~body = | OConst o -> o | OVar o -> List.assoc o o_res in let o_printer = pf "%f" in - print_program ~o_map ~o_printer infer_res ast *) + print_program ~o_map ~o_printer infer_res ast let print_typecheck (f_types, side) ast = let open Ast in @@ -213,16 +212,15 @@ let ownership ~opts file = let ast = AstUtil.parse_file file in let intr_op = (ArgOptions.get_intr opts).op_interp in let simple_op = RefinementTypes.to_simple_funenv intr_op in - let _ = SimpleChecker.typecheck_prog simple_op ast in - assert false - (* print_fold_locations simple_res; + let simple_res = SimpleChecker.typecheck_prog simple_op ast in + (* print_fold_locations simple_res; *) let infer_res = OwnershipInference.infer ~opts simple_res ast in print_inference infer_res ast; let ownership_res = OwnershipSolver.solve_ownership ~opts infer_res in print_ownership ownership_res infer_res ast; match ownership_res with | None -> Unverified Aliasing - | Some _ -> Verified *) + | Some _ -> Verified let typecheck ~opts file = let ast = AstUtil.parse_file file in diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 0d1a5b5c..abf1ac54 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -672,7 +672,7 @@ let rec process_expr ~output ((e_id,_),expr) ~o_arity = let%bind o_list = alloc_ovar_list (MGen e_id) (P.var v) ~o_arity in let t = IntList o_list in with_types [(v,t)] @@ process_expr ~output body ~o_arity - | Let (PVar v, Cons (h, r), body) -> + | Let (PVar v, Cons (_, r), body) -> ( let split_type_cons = function | Ref(IntList ol, o) -> ( let rec split_loop ol ol1 ol2 = @@ -680,7 +680,7 @@ let rec process_expr ~output ((e_id,_),expr) ~o_arity = | [o] -> return (List.rev ol1, List.rev ol2, o) | h :: r -> let%bind (o1, o2) = alloc_weak_split (SBind e_id) (P.var v) h in - return @@ split_loop r (o1 :: ol1) (o2 :: ol2) + split_loop r (o1 :: ol1) (o2 :: ol2) | [] -> assert false in let%bind (ol1, ol2, o_not_splited) = split_loop ol [] [] in @@ -692,13 +692,14 @@ let rec process_expr ~output ((e_id,_),expr) ~o_arity = in match r with | Var v' -> ( - let (t1, t2) = split_type_cons @@ lkp v' in + let%bind v'_name = lkp v' in + let%bind (t1, t2) = split_type_cons v'_name in begin%m update_type v t1; - with_types [(v, t2)] @@ process_expr ~output body ~o_arity + with_types [(v', t2)] @@ process_expr ~output body ~o_arity end ) - | _ -> failwith("Not implemented.") + | _ -> failwith("Not implemented.")) | Let (patt,rhs,body) -> let%bind to_bind = match rhs with diff --git a/src/ownershipSolver.ml b/src/ownershipSolver.ml index 5c6ee21f..225bbfdf 100644 --- a/src/ownershipSolver.ml +++ b/src/ownershipSolver.ml @@ -76,6 +76,16 @@ let pp_oconstraint ff ocon = ] ] ] + | WeakSplit (o,(o1,o2)) -> + pg "assert" [ + pg ">=" [ + po o; + pg "+" [ + po o1; + po o2 + ] + ] + ] | Eq (o1,o2) -> pg "assert" [ pg "=" [ From 7047d0a742881f0de4595368a17eaa853b0e4aa6 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 29 Jun 2023 15:45:20 +0900 Subject: [PATCH 055/108] fix simple type checker where assign int --- src/simpleChecker.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/simpleChecker.ml b/src/simpleChecker.ml index 623241ba..95ff7d71 100644 --- a/src/simpleChecker.ml +++ b/src/simpleChecker.ml @@ -329,7 +329,7 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = process_expr ret_type ctxt e1 res_acc >> process_expr ret_type ctxt e2 | Assign (v1,IInt _,e) -> - unify_ref v1 `Int; + unify_ref v1 @@ `Ref `Int; process_expr ret_type ctxt e res_acc | Assign (v1,IVar v2,e) -> unify_var v1 @@ `Ref (lkp v2); From 06b1f3b381bd6a884bd7f2c50370f5ed71ab7dc1 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 29 Jun 2023 16:09:53 +0900 Subject: [PATCH 056/108] refix ownership inference --- src/simpleChecker.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/simpleChecker.ml b/src/simpleChecker.ml index 95ff7d71..084dc060 100644 --- a/src/simpleChecker.ml +++ b/src/simpleChecker.ml @@ -278,7 +278,7 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = in let unify_var n typ = unify ~loc ctxt.sub (lkp n) typ in let unify_ref v t = - unify ~loc ctxt.sub (lkp v) @@ t + unify ~loc ctxt.sub (lkp v) @@ `Ref t in let fresh_var () = let t = UnionFind.new_node ctxt.sub.uf in @@ -329,7 +329,7 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = process_expr ret_type ctxt e1 res_acc >> process_expr ret_type ctxt e2 | Assign (v1,IInt _,e) -> - unify_ref v1 @@ `Ref `Int; + unify_ref v1 @@ `Int; process_expr ret_type ctxt e res_acc | Assign (v1,IVar v2,e) -> unify_var v1 @@ `Ref (lkp v2); From cef561faddce9bfeffd10b669796c3d5cdab32e5 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 29 Jun 2023 17:10:02 +0900 Subject: [PATCH 057/108] add test --- src/test/test.imp | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 src/test/test.imp diff --git a/src/test/test.imp b/src/test/test.imp new file mode 100644 index 00000000..a3a49564 --- /dev/null +++ b/src/test/test.imp @@ -0,0 +1,7 @@ +{ + let x = mkref 1 in + let y = mkref x in + let a = Nil in + let b = mkref a in + () +} \ No newline at end of file From 0c1574fa6a1dd1e04187dc27e68d6ef17e4ee1f8 Mon Sep 17 00:00:00 2001 From: artoy Date: Sat, 1 Jul 2023 16:06:23 +0900 Subject: [PATCH 058/108] fix a bug about mkref intlist --- src/ownershipInference.ml | 24 ++++++++++++++++-------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index abf1ac54..2f77ebc3 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -156,7 +156,7 @@ let%lm shuffle_types ~src:(t1,t1') ~dst:(t2,t2') ctxt = shuffle_intlist r1 r2 r1' r2' @@ { ctxt with ocons = Shuff ((h1,h2),(h1',h2')) :: ctxt.ocons } - | _ -> failwith "Ownership arity is different between IntList types" + | _ -> failwith "Ownership arities are different between IntList types" in let rec loop t1 t2 t1' t2' ctxt = match t1,t2,t1',t2' with @@ -307,27 +307,27 @@ let rec alloc_ovar_list loc p ~o_arity = (** Lift a simple type into an ownership type (of type otype) *) (* this must record *) let lift_to_ownership loc root t_simp ~o_arity = - let rec simple_lift ~unfld root = + let rec simple_lift root = function | `Array `Int -> let%bind o = alloc_ovar loc root in return @@ Array (Int, o) | `Ref t -> let%bind o = alloc_ovar loc root in - let%bind t' = simple_lift ~unfld (P.deref root) t in + let%bind t' = simple_lift (P.deref root) t in return @@ Ref (t',o) | `Int -> return Int | `TVar id -> return @@ TVar id | `Tuple tl -> let%bind tl' = mmapi (fun i t -> - simple_lift ~unfld (P.t_ind root i) t + simple_lift (P.t_ind root i) t ) tl in return @@ Tuple tl' | `IntList -> let%bind o_list = alloc_ovar_list loc root ~o_arity in return @@ IntList o_list in - let%bind t = simple_lift ~unfld:IntSet.empty root t_simp in + let%bind t = simple_lift root t_simp in constrain_well_formed t >> return t let mtmap p f tl = @@ -487,13 +487,21 @@ let%lm constrain_rel ~rel ~src:t1 ~dst:t2 ctxt = let rec loop t1 t2 ctxt = match t1, t2 with | TVar _,TVar _ - | Int, Int - | IntList _, IntList _ -> ctxt + | Int, Int -> ctxt | Ref (t1',o1), Ref (t2',o2) | Array (t1',o1), Array (t2',o2) -> loop t1' t2' { ctxt with ocons = (rel o1 o2)::ctxt.ocons } | Tuple tl1,Tuple tl2 -> List.fold_left2 (fun acc t1 t2 -> loop t1 t2 acc) ctxt tl1 tl2 + | IntList ol1, IntList ol2 -> + let rec loop_ol ol1 ol2 ctxt = + match ol1,ol2 with + | [],[] -> ctxt + | o1::r1,o2::r2 -> + loop_ol r1 r2 { ctxt with ocons = (rel o1 o2)::ctxt.ocons } + | _ -> failwith "Ownership arities are different between IntList types" + in + loop_ol ol1 ol2 ctxt | _,_ -> failwith "Type mismatch (simple checker broken B?)" in loop t1 t2 ctxt @@ -529,7 +537,7 @@ let%lm sum_types t1 t2 out ctxt = [],[],[] -> ctxt | h1 :: r1, h2 :: r2, outh :: outr -> sum_ownership_list r1 r2 outr { ctxt with ocons = Split (outh, (h1, h2))::ctxt.ocons } - | _ -> failwith "Ownership arity is different between IntList types" + | _ -> failwith "Ownership arities are different between IntList types" in let rec loop t1 t2 out ctxt = match t1,t2,out with From a2b82e2dc39ebdd973ace2db3d9be6e75c07a0ff Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 3 Jul 2023 15:38:27 +0900 Subject: [PATCH 059/108] fix match statement (is this really correct?) --- src/ownershipInference.ml | 21 +++++++++++++++------ src/simpleChecker.ml | 2 -- src/test/list/not-variable-pattern.imp | 4 ++-- src/test/test.imp | 7 ------- 4 files changed, 17 insertions(+), 17 deletions(-) delete mode 100644 src/test/test.imp diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 2f77ebc3..5c73368f 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -771,11 +771,20 @@ let rec process_expr ~output ((e_id,_),expr) ~o_arity = | _ -> failwith "Not implemented" in let%bind t = lkp v in - let type_of_r = match t with - IntList ol -> Ref(IntList (List.tl ol @ [List.hd @@ List.rev ol]), List.hd ol) - | _ -> failwith "The value pattern matched msust be IntList" + let%bind type_of_v, type_of_r = match t with + IntList ol -> + let rec split_loop ol ol1 ol2 = + match ol with + | [] -> return (List.rev ol1, List.rev ol2) + | h :: r -> + let%bind (o1, o2) = alloc_weak_split (SBind e_id) (P.var v) h in + split_loop r (o1 :: ol1) (o2 :: ol2) + in + let%bind (ol1, ol2) = split_loop ol [] [] in + return (IntList ol1, Ref(IntList((List.tl ol2) @ [(List.hd @@ List.rev ol2)]), List.hd ol2)) + | _ -> failwith "The value pattern matched must be IntList" in - process_pattern_matching ~e_id ~output e2 h r type_of_r e3 ~o_arity + process_pattern_matching ~e_id ~output v type_of_v e2 h r type_of_r e3 ~o_arity and process_conditional ~e_id ~tr_branch ~output e1 e2 ctxt ~o_arity = let (ctxt_tpre,()) = tr_branch ctxt in let (ctxt_t,tfl) = process_expr ~output e1 ctxt_tpre ~o_arity in @@ -796,9 +805,9 @@ and process_conditional ~e_id ~tr_branch ~output e1 e2 ctxt ~o_arity = end ) (StringMap.bindings ctxt_f.gamma) { ctxt_f with gamma = StringMap.empty } in ctxt,`Cont -and process_pattern_matching ~e_id ~output e1 h r type_of_r e2 ctxt ~o_arity = +and process_pattern_matching ~e_id ~output v type_of_v e1 h r type_of_r e2 ctxt ~o_arity = let (ctxt_n, nfl) = process_expr ~output e1 ctxt ~o_arity in - let (ctxt_c, cfl) = (with_types [(h, Int); (r, type_of_r)] @@ process_expr ~output e2 ~o_arity) { ctxt_n with gamma = ctxt.gamma } in + let (ctxt_c, cfl) = (with_types [(h, Int); (r, type_of_r)] @@ process_expr ~output e2 ~o_arity) { ctxt_n with gamma = update_map v type_of_v ctxt.gamma } in match nfl, cfl with | `Return, f -> ctxt_c, f | `Cont, `Return -> { ctxt_c with gamma = ctxt_n.gamma }, `Cont diff --git a/src/simpleChecker.ml b/src/simpleChecker.ml index 084dc060..4d3fcc23 100644 --- a/src/simpleChecker.ml +++ b/src/simpleChecker.ml @@ -159,8 +159,6 @@ let rec occurs_check sub v (t2: typ) = | `IntList | `Var _ | `Int -> () - (* Notice that we do not check reference contents for recursion. Recursion under a reference constructor is fine *) - (* TODO: Probably, TyCons is going to be deleted *) let assign sub var t = occurs_check sub var (t :> typ); diff --git a/src/test/list/not-variable-pattern.imp b/src/test/list/not-variable-pattern.imp index 21bf4bc1..0aaaf3ea 100644 --- a/src/test/list/not-variable-pattern.imp +++ b/src/test/list/not-variable-pattern.imp @@ -1,8 +1,8 @@ { let x = mkref Nil in let y = mkref (Cons 1 x) in - let z = mkref (Cons 2 y) in - match Cons 3 z with + let z = Cons 2 y in + match z with Nil -> () | Cons h r -> () } \ No newline at end of file diff --git a/src/test/test.imp b/src/test/test.imp deleted file mode 100644 index a3a49564..00000000 --- a/src/test/test.imp +++ /dev/null @@ -1,7 +0,0 @@ -{ - let x = mkref 1 in - let y = mkref x in - let a = Nil in - let b = mkref a in - () -} \ No newline at end of file From 2ec1692f993118c76abbbd92ea42dd84358a2cc4 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 3 Jul 2023 15:57:26 +0900 Subject: [PATCH 060/108] update test --- src/test/list/{not-variable-pattern.imp => match-easy.imp} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename src/test/list/{not-variable-pattern.imp => match-easy.imp} (100%) diff --git a/src/test/list/not-variable-pattern.imp b/src/test/list/match-easy.imp similarity index 100% rename from src/test/list/not-variable-pattern.imp rename to src/test/list/match-easy.imp From 7e7ce3c9bb7314b24fbc327946fd07978ad3e19e Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 6 Jul 2023 15:29:40 +0900 Subject: [PATCH 061/108] implement simple type checking of .Cons.2 alias --- src/astPrinter.ml | 2 ++ src/ownershipInference.ml | 2 ++ src/parser.mly | 1 + src/paths.ml | 7 ++++++- src/paths.mli | 5 ++++- src/simpleChecker.ml | 6 ++++++ src/test/list/match.imp | 6 ++++-- 7 files changed, 25 insertions(+), 4 deletions(-) diff --git a/src/astPrinter.ml b/src/astPrinter.ml index 8492bf38..fbc8887a 100644 --- a/src/astPrinter.ml +++ b/src/astPrinter.ml @@ -47,6 +47,8 @@ let pp_ap r = | `Proj i::l -> pf "%a.%d" (ul loop) l i | `Deref::l -> pf "*%a" (ul loop) l + | `Cons(con, i) :: l -> + pf "%a.%s.%d" (ul loop) l con i in loop steps | _ -> failwith "Unsupported operation ap" diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 5c73368f..3e844624 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -430,6 +430,8 @@ let fresh_ap e_id (p: P.concr_ap) = return @@ (Tuple tl',lt, lt') | _ -> assert false ) l + | `Cons _ :: _ -> + assert false in loop (fun ?o t -> let%bind t' = make_fresh_type loc p t in diff --git a/src/parser.mly b/src/parser.mly index 5253416f..41db0a75 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -118,6 +118,7 @@ let ap := let ap_prim := | v = ID; { Paths.var v } | a1 = ap_prim; DOT; ind = INT; { Paths.t_ind a1 ind } + | a1 = ap_prim; DOT; CONS; DOT; ind = INT; { Paths.t_cons a1 "Cons" ind } | LPAREN; ~ = ap; RPAREN; <> let patt := diff --git a/src/paths.ml b/src/paths.ml index b8be6f0f..75f2cd1c 100644 --- a/src/paths.ml +++ b/src/paths.ml @@ -12,6 +12,7 @@ type root = type steps = [ | `Deref | `Proj of int + | `Cons of string * int ] [@@deriving sexp] type path = root * steps list * suff [@@deriving sexp] @@ -36,6 +37,7 @@ let to_z3_ident (root,steps,suff) = match s with | `Deref -> "->*" ^ acc | `Proj i -> Printf.sprintf "->%d%s" i acc + | `Cons(s, i) -> Printf.sprintf "->%s%d%s" s i acc ) (string_of_suff suff) steps in (root_to_string root) ^ st @@ -72,6 +74,9 @@ let t_ind p i = let deref = check_extend `Deref +let t_cons p s i = + check_extend (`Cons (s,i)) p + let var v = (Var v,[],`None) let ret = (Ret, [],`None) @@ -162,7 +167,7 @@ let root_at ~child:(r,steps,suff) ~parent:(root,steps2,suff2) = let is_root (_,l,f) = l = [] && f = `None -type tail_ret = [`Null | `Deref | `Proj of int | `Len | `Elem | `Ind ] +type tail_ret = [`Null | `Deref | `Proj of int | `Len | `Elem | `Ind | `Cons of string * int] type inh_tags = [`Len | `Null | `Ind | `Elem ] let tail (_,l,f) = diff --git a/src/paths.mli b/src/paths.mli index 94bb5c77..9277b4ca 100644 --- a/src/paths.mli +++ b/src/paths.mli @@ -22,6 +22,7 @@ type root = private type steps = [ | `Deref (** Follow a (non-null) memory address *) | `Proj of int (** The ith element of a tuple *) + | `Cons of string * int (** The constructor and index of it of data types. For example, in case of LinkedList = Nil | Cons of int * ref LinkedList, the reference part of Cons is represented as Cons("Cons", 2) *) ] [@@deriving sexp] (** A path is a tuple consisting of a root, a series of steps through the heap, followed by an (optional) final path. This type is @@ -63,6 +64,8 @@ val to_null : path -> path (** Extend the path with an element of [steps] *) val extend : path -> steps -> path +(** Extend the path with constructor and index of data types *) +val t_cons : path -> string -> int -> path (** {2 Constructors} @@ -141,7 +144,7 @@ val compare : path -> path -> int Otherwise, on a path with a non-[`None] suffix [s], returns [Some s]. Otherwise, on a path with a [`None] suffix, returns the head element of steps (i.e., the last deref/projection in the path) *) -val tail : path -> [`Null | `Deref | `Proj of int | `Len | `Elem | `Ind ] option +val tail : path -> [`Null | `Deref | `Proj of int | `Len | `Elem | `Ind | `Cons of string * int] option (** A (printable) set of paths *) module PathSet : Std.PRINTSET with type elt = path diff --git a/src/simpleChecker.ml b/src/simpleChecker.ml index 4d3fcc23..0badaced 100644 --- a/src/simpleChecker.ml +++ b/src/simpleChecker.ml @@ -360,6 +360,12 @@ let rec process_expr ret_type ctxt ((id,loc),e) res_acc = unify (`Var content_v) tau; record_tcons tuple_v i content_v >> find_loop (`Var tuple_v) rest + | `Cons(s, i) :: rest -> + if s = "Cons" && i = 2 then ( + unify tau @@ `Ref `IntList; + find_loop `IntList rest + ) + else failwith "Unsupported aliasing (currently, only .Cons.2 is supported)" in let aliased_type = fresh_var () in let%bind () = find_loop aliased_type steps in diff --git a/src/test/list/match.imp b/src/test/list/match.imp index b625192f..3bbdb506 100644 --- a/src/test/list/match.imp +++ b/src/test/list/match.imp @@ -3,8 +3,10 @@ sum(l, s) { Nil -> s | Cons h r -> { let s2 = s + h in - let r2 = *r in - sum(r2, s2) + let r2 = *r in { + alias(l.Cons.2 = r); + sum(r2, s2) + } } } From eb0989ebf5b4f229e538ad32c21350d9fa281eea Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 6 Jul 2023 15:32:47 +0900 Subject: [PATCH 062/108] delete an unused function --- src/ownershipInference.ml | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 3e844624..21c89666 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -179,17 +179,6 @@ let%lm shuffle_types ~src:(t1,t1') ~dst:(t2,t2') ctxt = in loop t1 t2 t1' t2' ctxt -let rec unfold_simple arg mu = - function - | `Int -> `Int - | `Ref t' -> `Ref (unfold_simple arg mu t') - | `TVar id when id = arg -> mu - | `TVar id -> `TVar id - | `Array `Int -> `Array `Int - | `Tuple tl_list -> `Tuple (List.map (unfold_simple arg mu) tl_list) - | `Mu (id,t) -> `Mu (id, unfold_simple arg mu t) - | `IntList -> assert false - (** Walk a type, constraining the first occurrence of an ownership variable to be well-formed w.r.t [o]. Recall well-formedness requires that if o = 0 => o' = 0 From 2dabacf6f8e402fe660be5587a6ea94db6de8837 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 10 Jul 2023 15:57:38 +0900 Subject: [PATCH 063/108] implement ownership inference of .cons.2 --- src/ownershipInference.ml | 23 +++++++++++++++++++++-- src/test/list/alias-cons2.imp | 18 ++++++++++++++++++ 2 files changed, 39 insertions(+), 2 deletions(-) create mode 100644 src/test/list/alias-cons2.imp diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 21c89666..f923c8d3 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -419,8 +419,27 @@ let fresh_ap e_id (p: P.concr_ap) = return @@ (Tuple tl',lt, lt') | _ -> assert false ) l - | `Cons _ :: _ -> - assert false + | `Cons _ :: l -> + loop (fun ?o in_t -> + match in_t with + | IntList ol -> + let pull = Ref(IntList (List.tl ol @ [List.hd @@ List.rev ol]), List.hd ol) in + let%bind (new_sub, lt, lt') = k ?o pull in + let%bind push = match + new_sub with + | Ref (IntList ol', o) -> + let ol'_a = List.hd @@ List.rev ol' in + let ol'_a_minus_1 = List.hd @@ List.tl @@ List.rev ol' in + let ol'_rest = List.tl @@ List.tl ol' in + let%bind o_approximated = alloc_ovar loc p in + add_constraint(Ge(ol'_a, o_approximated)) >> + add_constraint(Ge(ol'_a_minus_1, o_approximated)) >> + return @@ IntList (o :: ol'_rest @ [o_approximated]) + | _ -> assert false + in + return @@ (push, lt, lt') + | _ -> assert false + ) l in loop (fun ?o t -> let%bind t' = make_fresh_type loc p t in diff --git a/src/test/list/alias-cons2.imp b/src/test/list/alias-cons2.imp new file mode 100644 index 00000000..e349aaf7 --- /dev/null +++ b/src/test/list/alias-cons2.imp @@ -0,0 +1,18 @@ +insert_second(l, x) { + match l with + Nil -> () + | Cons h r -> { + let r2 = r in { + r := Cons x r2; + alias(l.Cons.2 = r) + } + } +} + +{ + let n = mkref Nil in + let l = Cons 0 n in { + insert_second(l, 1); + insert_second(l, 2); + } +} \ No newline at end of file From f54fa86827b94974e65135a3cd6c3d2e18103a78 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 13 Jul 2023 10:18:58 +0900 Subject: [PATCH 064/108] fix a test --- src/test/list/alias-cons2.imp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/test/list/alias-cons2.imp b/src/test/list/alias-cons2.imp index e349aaf7..a2eb3e6a 100644 --- a/src/test/list/alias-cons2.imp +++ b/src/test/list/alias-cons2.imp @@ -2,7 +2,7 @@ insert_second(l, x) { match l with Nil -> () | Cons h r -> { - let r2 = r in { + let r2 = mkref *r in { r := Cons x r2; alias(l.Cons.2 = r) } From b847fda3a330ec5b33c0ad9a6659277e2ab4f2c0 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 13 Jul 2023 14:22:56 +0900 Subject: [PATCH 065/108] update consort.ml --- src/consort.ml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/consort.ml b/src/consort.ml index c7bd40c3..85a776b9 100644 --- a/src/consort.ml +++ b/src/consort.ml @@ -196,14 +196,13 @@ let consort ~opts file = let ast = AstUtil.parse_file file in let intr_op = (ArgOptions.get_intr opts).op_interp in let simple_typing = RefinementTypes.to_simple_funenv intr_op in - let _ = SimpleChecker.typecheck_prog simple_typing ast in - assert false - (* let infer_res = OwnershipInference.infer ~opts simple_res ast in + let simple_res = SimpleChecker.typecheck_prog simple_typing ast in + let infer_res = OwnershipInference.infer ~opts simple_res ast in let ownership_res = OwnershipSolver.solve_ownership ~opts infer_res in match ownership_res with | None -> Unverified Aliasing - | Some o_res -> - let o_hint = to_hint o_res infer_res.op_record in + | Some _ -> Verified + (* let o_hint = to_hint o_res infer_res.op_record in let solve = get_solve ~opts in let ans = solve ~opts simple_res o_hint ast in solver_result_to_check_result ans *) From d4929b472a815d1a7deef5b687a341b827217f1b Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 13 Jul 2023 15:20:21 +0900 Subject: [PATCH 066/108] output constraints of ownership variables --- src/ownershipSolver.ml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/ownershipSolver.ml b/src/ownershipSolver.ml index 225bbfdf..f340edf1 100644 --- a/src/ownershipSolver.ml +++ b/src/ownershipSolver.ml @@ -164,6 +164,12 @@ let solve_ownership ~opts result = ] o_buf.printer end; finish o_buf; + (* Print constraints of ownership variables *) + print_newline (); + print_string (Buffer.contents o_buf.buf); + print_newline (); + print_newline (); + let res = let opts : ArgOptions.t = { opts with From 2c53f396d4062a6ef86aa1bad7370c45ace6932c Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 13 Jul 2023 15:34:15 +0900 Subject: [PATCH 067/108] fix .cons.2 in alias statements --- src/ownershipInference.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index f923c8d3..1836808f 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -430,7 +430,7 @@ let fresh_ap e_id (p: P.concr_ap) = | Ref (IntList ol', o) -> let ol'_a = List.hd @@ List.rev ol' in let ol'_a_minus_1 = List.hd @@ List.tl @@ List.rev ol' in - let ol'_rest = List.tl @@ List.tl ol' in + let ol'_rest = List.rev @@ List.tl @@ List.tl @@ List.rev ol' in let%bind o_approximated = alloc_ovar loc p in add_constraint(Ge(ol'_a, o_approximated)) >> add_constraint(Ge(ol'_a_minus_1, o_approximated)) >> From 05f3eee76bc86ed5e4ae45ef524d4921d2d65dd7 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Fri, 14 Jul 2023 17:13:26 +0900 Subject: [PATCH 068/108] add convmochi --- src/argOptions.ml | 4 +- src/consort.ml | 16 ++ src/consort.mli | 1 + src/convMoCHi.ml | 450 ++++++++++++++++++++++++++++++++++++++ src/dune | 3 +- src/ownershipInference.ml | 3 + src/ownershipSolver.ml | 5 +- src/test.ml | 1 + 8 files changed, 479 insertions(+), 4 deletions(-) create mode 100644 src/convMoCHi.ml diff --git a/src/argOptions.ml b/src/argOptions.ml index 48c2fd8a..b5083ac8 100644 --- a/src/argOptions.ml +++ b/src/argOptions.ml @@ -12,11 +12,13 @@ module ExecMode = struct | Consort | Ownership | Typecheck + | ConvMoCHi let pairs = [ ("consort", Consort); ("ownership", Ownership); - ("typecheck", Typecheck) + ("typecheck", Typecheck); + ("convmochi", ConvMoCHi) ] let default = "consort" let candidates = List.map (fun (s, _) -> s) pairs diff --git a/src/consort.ml b/src/consort.ml index 85a776b9..0bd5995b 100644 --- a/src/consort.ml +++ b/src/consort.ml @@ -228,3 +228,19 @@ let typecheck ~opts file = let simple_res = SimpleChecker.typecheck_prog simple_op ast in print_typecheck simple_res ast; Verified + + let convmochi ~opts file = + let ast = AstUtil.parse_file file in + (* print_endline @@ Sexplib.Sexp.to_string @@ Ast.sexp_of_prog ast; *) + let intr_op = (ArgOptions.get_intr opts).op_interp in + let simple_op = RefinementTypes.to_simple_funenv intr_op in + let simple_res = SimpleChecker.typecheck_prog simple_op ast in + let infer_res = OwnershipInference.infer ~opts simple_res ast in + let ownership_res = OwnershipSolver.solve_ownership ~opts infer_res in + let prog = + ConvMoCHi.prog_to_mochi infer_res + ((function Some x -> x | None -> assert false) ownership_res) + ast + in + ConvMoCHi.Mochi.print_prog prog; + match ownership_res with None -> Unverified Aliasing | Some _ -> Verified diff --git a/src/consort.mli b/src/consort.mli index 4b407e63..cc683b19 100644 --- a/src/consort.mli +++ b/src/consort.mli @@ -16,3 +16,4 @@ val result_to_string : check_result -> string val consort : opts:ArgOptions.t -> string -> check_result val ownership : opts:ArgOptions.t -> string -> check_result val typecheck : opts:ArgOptions.t -> string -> check_result +val convmochi : opts:ArgOptions.t -> string -> check_result diff --git a/src/convMoCHi.ml b/src/convMoCHi.ml new file mode 100644 index 00000000..63046869 --- /dev/null +++ b/src/convMoCHi.ml @@ -0,0 +1,450 @@ +open PrettyPrint +open Sexplib.Std +open Format +open Ast + +let todo () = assert false + +let fn_to_mochi = function + | "=" -> "eq'" + | "!=" -> "ne'" + | "+" -> "( + )" + | "*" -> "( * )" + | "-" -> "( - )" + | "<" -> "lt'" + | ">" -> "gt'" + | "<=" -> "le'" + | ">=" -> "ge'" + | "%" -> "(mod)" + | "&&" -> "land'" + | "||" -> "lor'" + | fn -> + if AstPrinter.is_operator_id fn then failwith @@ "Unknown operator " ^ fn + else fn + +let is_builtin_fn = function + | "=" | "!=" | "+" | "*" | "-" | "<" | ">" | "<=" | ">=" | "%" | "&&" | "||"-> true + | fn -> + if AstPrinter.is_operator_id fn then failwith @@ "Unknown operator " ^ fn + else false + +module Mochi = struct + type adist = Left | Right | Nil [@@deriving sexp] + type atype = ABase of adist | ATuple of atype list [@@deriving sexp] + + type exp = + | Unit + | Fail + | Cond of string * exp * exp + | Let of patt * exp * exp + | Tuple of exp list + | Var of string + | Const of int + | Call of string * string list + | Nondet of OwnershipInference.otype * RefinementTypes.refinement option + | MkArray of string + | LengthOf of string + | Read of string * string + | Assert of relation * exp + | Update of string * string * string * exp + | Alias of + (* Paths.steps list は Paths と逆順 *) + string + * string + * patt + * patt + * patt + * exp + [@@deriving sexp] + + type fn = { name : string; args : string list; body : exp } [@@deriving sexp] + type prog = fn list * exp [@@deriving sexp] + + let arrfuns = + "let eq' x y = if x = y then 0 else 1\n\ + let ne' x y = if x <> y then 0 else 1\n\ + let lt' x y = if x < y then 0 else 1\n\ + let gt' x y = if x > y then 0 else 1\n\ + let le' x y = if x <= y then 0 else 1\n\ + let ge' x y = if x >= y then 0 else 1\n\ + let land' x y = if x = 0 && y = 0 then 0 else 1\n\ + let lor' x y = if x = 0 || y = 0 then 0 else 1\n\ + let mkarray' n = (n, fun i -> assert (0 <= i && i < n); 0)\n\ + let update' arr i x = let a = snd arr in (a i; (fst arr, fun j -> a j; if j = i \ + then x else a j))\n" + + let ap_to_string (root, steps, _) = + let open Paths in + let pp_root = match root with Var x -> x | _ -> assert false in + List.fold_left + (fun acc s -> + match s with + | `Deref -> acc + | `Proj 0 -> acc ^ "fst @@" + | `Proj 1 -> acc ^ "snd @@" + | `Cons _ -> assert false + | _ -> assert false) + "" steps + ^ pp_root + + let pp_ap ap = ap_to_string ap |> ps + + let rec pp_refinement r = + let open RefinementTypes in + let open Paths in + match r with + | Top -> ps "true" + | ConstEq n -> pf "_' = %d" n + | Relation { rel_op1; rel_cond; rel_op2 } -> + let print_rimm ff = function + | RConst i -> pi i ff + | RAp c -> pp_ap (c :> root * steps list * suff) ff + in + let r1_printer ff r1 = + match r1 with Nu -> ps "_'" ff | RImm i -> print_rimm ff i + in + pf "%a@ %s@ %a" r1_printer rel_op1 rel_cond print_rimm rel_op2 + | And (r1, r2) -> + pf "%a@ &&@ %a" (ul pp_refinement) r1 (ul pp_refinement) r2 + | _ -> failwith @@ "Cannot annotate with relation " ^ string_of_refinement r + + let rec pp_nondet_ot = + let open OwnershipInference in + function + | Int -> ps "Random.int 0" + | Tuple ots -> pl [ ps "("; psep ", " @@ List.map pp_nondet_ot ots; ps ")" ] + | Ref (ot, _) -> pp_nondet_ot ot + | _ -> assert false + + let rec pp_exp = function + | Unit -> ps "()" + | Fail -> ps "Fail" + | Tuple es -> pl [ ps "("; psep ", " @@ List.map pp_exp es; ps ")" ] + | Var x -> + assert (String.get x 0 > 'Z'); + pv x + | Const i -> pi i + | Nondet (Int, None) -> ps "Random.int 0" + | Nondet (Int, Some p) -> + pf + "let rec nd' () = @[let _' = Random.int 0 in@;\ + @[if %a then _'@;\ + else nd' ()@;\ + @]@] in nd' ()@;" + (ul pp_refinement) p + | Nondet (ot, None) -> pp_nondet_ot ot + | Nondet (_, _) -> assert false + | MkArray x -> pf "mkarray' %s" x + | LengthOf x -> pf "fst %s" x + | Read (x, i) -> pf "snd %s %s" x i + | Assert ({ rop1; cond; rop2 }, e) -> + pl + [ + pf "assert (%a %s %a)" AstPrinter.upp_imm rop1 cond + AstPrinter.upp_imm rop2; + semi; + pp_exp e; + ] + | Update (a, i, x, e) -> + pl [ pf "let %s = update' %s %s %s in" a a i x; nl; pp_exp e ] + | Call (callee, arg_names) -> + let pp_callee = fn_to_mochi callee in + pf "(%s %s)" pp_callee @@ String.concat " " arg_names + | Alias (xd, xs, p1, p2, p3, e) -> + pl + [ + pf "let %s = %a in" xd (ul pl) + [ + pf "let %a = %s in" (ul AstPrinter.pp_patt) p1 xd; + nl; + pf "let %a = %s in" (ul AstPrinter.pp_patt) p2 xs; + nl; + AstPrinter.pp_patt p3; + ]; + nl; + pp_exp e; + ] + | Cond (x, e1, e2) -> + pblock ~nl:false ~op:(pf "if %s = 0 then (" x) ~body:(pp_exp e1) + ~close: + (pblock ~nl:true ~op:(ps ") else (") ~body:(pp_exp e2) + ~close:(ps ")")) + | Let (patt, e1, e2) -> + pl + [ + pf "let %a = %a in" (ul AstPrinter.pp_patt) patt (ul pp_exp) e1; + nl; + pp_exp e2; + ] + + let pp_fn ff { name; args; body } ~first = + pl + [ + pblock ~nl:true + ~op: + (pf "%s %s %s =" (if first then "let rec" else "and") name + @@ String.concat " " args) + ~body:(pp_exp body) ~close:null; + ] + ff + + let pp_prog (fn, body) ff = + pp_open_vbox ff 0; + List.iteri (fun i -> pp_fn ff ~first:(i = 0)) fn; + pp_close_box ff (); + pp_open_vbox ff 1; + fprintf ff "let main () =@;"; + pp_exp body ff; + pp_close_box ff (); + pp_force_newline ff () + + let print_prog prog = + print_endline arrfuns; + pp_prog prog std_formatter +end + +let lhs_to_mochi (ri : OwnershipInference.Result.t) (ro : (int * float) list) i + = + let open OwnershipInference in + function + | Var x -> Mochi.Var x + | Const i -> Mochi.Const i + | Mkref RNone -> Mochi.Nondet (Int, None) + | Mkref (RInt i) -> Mochi.Const i + | Mkref (RVar x) -> Mochi.Var x + | MkArray x -> Mochi.MkArray x + | Call { callee; arg_names; _ } -> Mochi.Call (callee, arg_names) + | Deref x -> ( + (* REVIEW: deref のたびに常に havoc する必要はない *) + let ty_env = Std.IntMap.find i ri.ty_envs in + let ty = StringMap.find x ty_env in + match ty with + | Ref (t, o) -> + let r = match o with OConst r -> r | OVar i -> List.assoc i ro in + if r > 0. then Mochi.Var x else Mochi.Nondet (t, None) + | _ -> raise @@ Failure "illegal deref") + | Tuple ls -> + Mochi.( + Tuple + (List.map + (function + | RNone -> Nondet (Int, None) + | RInt i -> Const i + | RVar x -> Var x) + ls)) + | Nondet p -> Mochi.Nondet (Int, p) + | LengthOf x -> Mochi.LengthOf x + | Read (x, y) -> Mochi.Read (x, y) + | Null -> raise @@ Failure "null is not supported" + | Nil + | Cons _ -> assert false + +let map_o ro o = + let open OwnershipInference in + match o with OConst r -> r | OVar i -> List.assoc i ro + +let alias_to_adist (ro : (int * float) list) + ((tl, sl) : OwnershipInference.otype * Paths.steps list) + ((tr, sr) : OwnershipInference.otype * Paths.steps list) = + let open OwnershipInference in + let rsl = List.rev sl in + let rsr = List.rev sr in + let rec walk ty = function + | [] -> ty + | `Deref :: ss -> ( + match ty with + | Ref (ty', o) -> + (* WF より, オーナーシップ0の先をエイリアス宣言しても意味ない *) + assert (map_o ro o > 0.); + walk ty' ss + | _ -> assert false) + | `Proj i :: ss -> ( + match ty with + | Tuple tys -> walk (List.nth tys i) ss + | _ -> assert false) + | `Cons _ :: _ -> assert false + in + let tl = walk tl rsl in + let tr = walk tr rsr in + let open Mochi in + let rec loop tl tr = + match (tl, tr) with + | Array (tl', o1), Array (tr', o2) | Ref (tl', o1), Ref (tr', o2) -> + let zl, zr = (map_o ro o1 = 0., map_o ro o2 = 0.) in + if zl then if zr then Nil else Left + else if zr then Right + else loop tl' tr' + | Tuple tsl, Tuple tsr -> + let adists = List.map2 loop tsl tsr in + let nl, nr, nn = + List.fold_left + (fun (nl, nr, nn) -> function + | Left -> (nl + 1, nr, nn) + | Right -> (nl, nr + 1, nn) + | Nil -> (nl, nr, nn + 1)) + (0, 0, 0) adists + in + let n = List.length adists in + if nn = n then Nil + else if nl + nn = n then Left + else if nr + nn = n then Right + else assert false + | Int, Int -> Nil + | t1, _ -> + failwith + (Printf.sprintf "ill type: %s" (sexp_of_otype t1 |> string_of_sexp)) + in + (rsl, rsr, loop tl tr) + +let alias_to_patt (ro : (int * float) list) + ((xl, tl, sl) : string * OwnershipInference.otype * Paths.steps list) + ((xr, tr, sr) : string * OwnershipInference.otype * Paths.steps list) = + let open OwnershipInference in + let rsl, rsr, adist = alias_to_adist ro (tl, sl) (tr, sr) in + let xd, td, sd, xs, ts, ss = + match adist with + | Left -> (xl, tl, rsl, xr, tr, rsr) + | _ -> (xr, tr, rsr, xl, tl, rsl) + in + let rec xname x = function + | [] -> x + | `Deref :: s -> xname x s + | `Proj i :: s -> xname (Printf.sprintf "%s'%i" x i) s + | `Cons _ :: _ -> assert false + in + let xxd = xname xd sd in + let xxs = xname xs ss in + let rec e_patt rx x t = function + | [] -> PVar rx + | `Deref :: s -> ( + match t with + | Ref (t', o) -> + assert (map_o ro o > 0.); + e_patt rx x t' s + | _ -> assert false) + | `Proj i :: s -> ( + match t with + | Tuple tys -> + let x' = Printf.sprintf "%s'%i" x i in + PTuple + (List.mapi + (fun j ty -> if i = j then e_patt rx x' ty s else PVar x') + tys) + | _ -> assert false) + | `Cons _ :: _ -> assert false + in + let ptd = e_patt xxd xd td sd in + let pts = e_patt xxs xs ts ss in + let pt_ = e_patt xxs xd td sd in + (xd, xs, ptd, pts, pt_) +(* +let alias_to_aty (ro : (int * float) list) + ((tl, sl) : OwnershipInference.otype * Paths.steps list) + ((tr, sr) : OwnershipInference.otype * Paths.steps list) = + let open OwnershipInference in + let rsl = List.rev sl in + let rsr = List.rev sr in + let rec walk ty = function + | [] -> ty + | `Deref :: ss -> ( + match ty with + | Ref (ty', o) -> + assert (map_o ro o > 0.); + walk ty' ss + | _ -> assert false) + | `Proj i :: ss -> ( + match ty with + | Tuple tys -> walk (List.nth tys i) ss + | _ -> assert false) + in + let tl = walk tl rsl in + let tr = walk tr rsr in + let open Mochi in + let rec loop tl tr = + match (tl, tr) with + | Array (tl', o1), Array (tr', o2) | Ref (tl', o1), Ref (tr', o2) -> + let zl, zr = (map_o ro o1 = 0., map_o ro o2 = 0.) in + if zl then if zr then ABase Nil else ABase Left + else if zr then ABase Right + else loop tl' tr' + | Tuple tsl, Tuple tsr -> + let atys = List.map2 loop tsl tsr in + let nl, nr, nn = + List.fold_left + (fun ((nl, nr, nn) as acc) -> function + | ABase Left -> (nl + 1, nr, nn) + | ABase Right -> (nl, nr + 1, nn) + | ABase Nil -> (nl, nr, nn + 1) + | _ -> acc) + (0, 0, 0) atys + in + let n = List.length atys in + if nl = n then ABase Left + else if nr = n then ABase Right + else if nn = n then ABase Nil + else ATuple atys + | Int, Int -> ABase Nil + | _ -> assert false + in + loop tl tr *) + +let rec exp_to_mochi (ri : OwnershipInference.Result.t) + (ro : (int * float) list) (vs : string list) (((i, _), e) : exp) = + let map_ty x = + let ty_env = Std.IntMap.find i ri.ty_envs in + StringMap.find x ty_env + in + match e with + | Unit -> Mochi.(Tuple (Unit :: List.map (fun v -> Var v) vs)) + | Cond (x, e1, e2) -> + Mochi.Cond (x, exp_to_mochi ri ro vs e1, exp_to_mochi ri ro vs e2) + | Seq ((((i', _), _) as e1), e2) -> + let vs' = + StringMap.fold + (fun v _ vs -> v :: vs) + (Std.IntMap.find i' ri.ty_envs) + [] + in + Mochi.( + Let + ( PTuple (PNone :: List.map (fun v -> PVar v) vs'), + exp_to_mochi ri ro vs' e1, + exp_to_mochi ri ro vs e2 )) + | Assign (x, iv, e) -> + let e' = + match iv with IVar y -> Mochi.Var y | IInt i -> Mochi.Const i + in + Mochi.(Let (PVar x, e', exp_to_mochi ri ro vs e)) + | Return x -> Mochi.(Tuple (Var x :: List.map (fun v -> Var v) vs)) + | Let (patt, (Call { callee; arg_names; _ } as lhs), e) + when not @@ is_builtin_fn callee -> + Mochi.Let + ( PTuple (patt :: List.map (fun x -> PVar x) arg_names), + lhs_to_mochi ri ro i lhs, + exp_to_mochi ri ro vs e ) + | Let (patt, lhs, e) -> + Mochi.Let (patt, lhs_to_mochi ri ro i lhs, exp_to_mochi ri ro vs e) + | NCond (_, _, _) -> raise @@ Failure "null is not supported" + | Fail -> Mochi.Fail + | Assert (p, e) -> Mochi.Assert (p, exp_to_mochi ri ro vs e) + | Update (a, i, x, e) -> Mochi.Update (a, i, x, exp_to_mochi ri ro vs e) + | Alias (p1, p2, e) -> ( + let open Paths in + let r1, st1, _ = (p1 :> root * steps list * suff) in + let r2, st2, _ = (p2 :> root * steps list * suff) in + match (r1, r2) with + | Var x1, Var x2 -> + let xd, xs, p1, p2, p3 = + alias_to_patt ro (x1, map_ty x1, st1) (x2, map_ty x2, st2) + in + Mochi.Alias (xd, xs, p1, p2, p3, exp_to_mochi ri ro vs e) + | _ -> assert false) + | Match _ -> assert false + +let fn_to_mochi (ri : OwnershipInference.Result.t) (ro : (int * float) list) + { name; args; body } = + Mochi.{ name; args; body = exp_to_mochi ri ro args body } + +let prog_to_mochi (ri : OwnershipInference.Result.t) (ro : (int * float) list) + (fns, exp) = + (List.map (fn_to_mochi ri ro) fns, exp_to_mochi ri ro [] exp) diff --git a/src/dune b/src/dune index 40360bb9..bb8c9fa4 100644 --- a/src/dune +++ b/src/dune @@ -43,7 +43,8 @@ (modules HornBackend SmtBackend Z3BasedBackend Consort HoiceBackend NullSolver - ExternalFileBackend EldaricaBackend ParallelBackend)) + ExternalFileBackend EldaricaBackend ParallelBackend + ConvMoCHi)) (executable (name test) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 1836808f..41e5c72d 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -18,6 +18,7 @@ module P = Paths type ownership = OVar of int (** A variable with id int *) | OConst of float (** a constant ownership with the given rational number *) + [@@deriving sexp] type ocon = | Live of ownership (** The ownership must be greater than 0 (only emitted in relaxed mode) *) @@ -36,8 +37,10 @@ type 'a otype_ = | Tuple of 'a otype_ list | TVar of int | IntList of 'a list + [@@deriving sexp] type otype = ownership otype_ +[@@deriving sexp] (** For the most part, the ownership and refinement inference passes may be run independently. The only intersection is handling 0 ownership references; when a reference drops to 0 ownership, all refinements must go to top (although we use diff --git a/src/ownershipSolver.ml b/src/ownershipSolver.ml index f340edf1..bc35fd01 100644 --- a/src/ownershipSolver.ml +++ b/src/ownershipSolver.ml @@ -165,10 +165,11 @@ let solve_ownership ~opts result = end; finish o_buf; (* Print constraints of ownership variables *) - print_newline (); + (* TODO: Dump constraints of ownership variables only when -exec ownership *) + (* print_newline (); print_string (Buffer.contents o_buf.buf); print_newline (); - print_newline (); + print_newline (); *) let res = let opts : ArgOptions.t = { diff --git a/src/test.ml b/src/test.ml index c6725b3c..82e82be1 100644 --- a/src/test.ml +++ b/src/test.ml @@ -5,6 +5,7 @@ let choose_exec = | Consort -> consort | Ownership -> ownership | Typecheck -> typecheck + | ConvMoCHi -> convmochi let result_to_yaml = let (<<) f g x = f (g x) in From 35b99c215050eb2762acc04cbc9efe8455faf048 Mon Sep 17 00:00:00 2001 From: artoy Date: Fri, 28 Jul 2023 17:25:56 +0900 Subject: [PATCH 069/108] WIP --- src/convMoCHi.ml | 27 ++++++++++++++++++--------- 1 file changed, 18 insertions(+), 9 deletions(-) diff --git a/src/convMoCHi.ml b/src/convMoCHi.ml index 63046869..4e8c6a06 100644 --- a/src/convMoCHi.ml +++ b/src/convMoCHi.ml @@ -29,7 +29,7 @@ let is_builtin_fn = function else false module Mochi = struct - type adist = Left | Right | Nil [@@deriving sexp] + type adist = Left | Right | Niladist [@@deriving sexp] type atype = ABase of adist | ATuple of atype list [@@deriving sexp] type exp = @@ -55,6 +55,9 @@ module Mochi = struct * patt * patt * exp + | Nil + | Cons of exp * exp + | Match of string * exp * string * string * exp [@@deriving sexp] type fn = { name : string; args : string list; body : exp } [@@deriving sexp] @@ -176,6 +179,9 @@ module Mochi = struct nl; pp_exp e2; ] + | Nil + | Cons _ + | Match _ -> assert false let pp_fn ff { name; args; body } ~first = pl @@ -203,7 +209,7 @@ module Mochi = struct pp_prog prog std_formatter end -let lhs_to_mochi (ri : OwnershipInference.Result.t) (ro : (int * float) list) i +let rec lhs_to_mochi (ri : OwnershipInference.Result.t) (ro : (int * float) list) i = let open OwnershipInference in function @@ -236,8 +242,8 @@ let lhs_to_mochi (ri : OwnershipInference.Result.t) (ro : (int * float) list) i | LengthOf x -> Mochi.LengthOf x | Read (x, y) -> Mochi.Read (x, y) | Null -> raise @@ Failure "null is not supported" - | Nil - | Cons _ -> assert false + | Nil -> Mochi.Nil + | Cons (h, t) -> Mochi.Cons (lhs_to_mochi ri ro i h, lhs_to_mochi ri ro i t) let map_o ro o = let open OwnershipInference in @@ -271,7 +277,7 @@ let alias_to_adist (ro : (int * float) list) match (tl, tr) with | Array (tl', o1), Array (tr', o2) | Ref (tl', o1), Ref (tr', o2) -> let zl, zr = (map_o ro o1 = 0., map_o ro o2 = 0.) in - if zl then if zr then Nil else Left + if zl then if zr then Niladist else Left else if zr then Right else loop tl' tr' | Tuple tsl, Tuple tsr -> @@ -281,15 +287,15 @@ let alias_to_adist (ro : (int * float) list) (fun (nl, nr, nn) -> function | Left -> (nl + 1, nr, nn) | Right -> (nl, nr + 1, nn) - | Nil -> (nl, nr, nn + 1)) + | Niladist -> (nl, nr, nn + 1)) (0, 0, 0) adists in let n = List.length adists in - if nn = n then Nil + if nn = n then Niladist else if nl + nn = n then Left else if nr + nn = n then Right else assert false - | Int, Int -> Nil + | Int, Int -> Niladist | t1, _ -> failwith (Printf.sprintf "ill type: %s" (sexp_of_otype t1 |> string_of_sexp)) @@ -439,7 +445,10 @@ let rec exp_to_mochi (ri : OwnershipInference.Result.t) in Mochi.Alias (xd, xs, p1, p2, p3, exp_to_mochi ri ro vs e) | _ -> assert false) - | Match _ -> assert false + | Match (e1, e2, h, t, e3) -> + match e1 with + Var x -> Mochi.Match (x, exp_to_mochi ri ro vs e2, h, t, exp_to_mochi ri ro vs e3) + | _ -> failwith "Not implemented" let fn_to_mochi (ri : OwnershipInference.Result.t) (ro : (int * float) list) { name; args; body } = From b52b3eee9de2b0096ed81b67ccaeed1e8f5f09d0 Mon Sep 17 00:00:00 2001 From: artoy Date: Sun, 30 Jul 2023 11:03:46 +0900 Subject: [PATCH 070/108] add patterns of IntList --- src/convMoCHi.ml | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/src/convMoCHi.ml b/src/convMoCHi.ml index 4e8c6a06..2c225400 100644 --- a/src/convMoCHi.ml +++ b/src/convMoCHi.ml @@ -111,6 +111,7 @@ module Mochi = struct pf "%a@ &&@ %a" (ul pp_refinement) r1 (ul pp_refinement) r2 | _ -> failwith @@ "Cannot annotate with relation " ^ string_of_refinement r +(* TODO: Is the case of IntList needed? *) let rec pp_nondet_ot = let open OwnershipInference in function @@ -179,9 +180,23 @@ module Mochi = struct nl; pp_exp e2; ] - | Nil - | Cons _ - | Match _ -> assert false + | Nil -> ps "[]" + | Cons (h, t) -> + pl [ + pp_exp h; + pf " :: "; + pp_exp t; + ] + | Match (x, e1, h, r, e2) -> + pl [ + pf "match %s with " x; + pf "[] -> { "; + pp_exp e1; + ps " } "; + pf "| Cons %s (%s) -> { " h r; + pp_exp e2; + ps "}"; + ] let pp_fn ff { name; args; body } ~first = pl From 560c52e6f722d7ffefca0feed1caba88ab22619f Mon Sep 17 00:00:00 2001 From: artoy Date: Sun, 30 Jul 2023 23:13:30 +0900 Subject: [PATCH 071/108] WIP --- src/convMoCHi.ml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/convMoCHi.ml b/src/convMoCHi.ml index 2c225400..93b09fed 100644 --- a/src/convMoCHi.ml +++ b/src/convMoCHi.ml @@ -283,7 +283,14 @@ let alias_to_adist (ro : (int * float) list) match ty with | Tuple tys -> walk (List.nth tys i) ss | _ -> assert false) - | `Cons _ :: _ -> assert false + | `Cons (s, i) :: ss -> + if s = "Cons" && i = 2 then ( + match ty with + | IntList ol -> + let ty' = Ref (IntList (List.tl ol @ [(List.hd @@ List.rev ol)]), List.hd ol) in + walk ty' ss + | _ -> assert false) + else failwith "Only .Cons.2 is supported in paths related to recursive types in alias statement" in let tl = walk tl rsl in let tr = walk tr rsr in From 800d909ed06903dadbbec7ecdb639dfe8261188c Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 31 Jul 2023 13:36:29 +0900 Subject: [PATCH 072/108] add a test --- src/test/tuple/tuple-alias-easy.imp | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 src/test/tuple/tuple-alias-easy.imp diff --git a/src/test/tuple/tuple-alias-easy.imp b/src/test/tuple/tuple-alias-easy.imp new file mode 100644 index 00000000..ccb1c5e6 --- /dev/null +++ b/src/test/tuple/tuple-alias-easy.imp @@ -0,0 +1,8 @@ +{ + let p = mkref (0, mkref 0) in { + let (_, p2) = *p in { + p2 := *p2 + 1; + alias(p2 = (*p).1) + }; + } +} \ No newline at end of file From 681da2ed661bff2163e58930e89519928085273c Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 3 Aug 2023 13:46:33 +0900 Subject: [PATCH 073/108] add test --- src/test/cond.imp | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 src/test/cond.imp diff --git a/src/test/cond.imp b/src/test/cond.imp new file mode 100644 index 00000000..87023118 --- /dev/null +++ b/src/test/cond.imp @@ -0,0 +1,12 @@ +{ + let b = 1 in + let x = mkref 0 in + { + if b = 1 then { + x := 1 + } else { + x := 2 + }; + assert (*x = 1) + } +} \ No newline at end of file From 06eb5da4c69970ad4fb121c07b5d541fb7d00ebd Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 3 Aug 2023 17:53:26 +0900 Subject: [PATCH 074/108] implement alias_to_mochi --- src/convMoCHi.ml | 201 ++++++++++++++++++++++------------------------- 1 file changed, 94 insertions(+), 107 deletions(-) diff --git a/src/convMoCHi.ml b/src/convMoCHi.ml index 93b09fed..18dcaa47 100644 --- a/src/convMoCHi.ml +++ b/src/convMoCHi.ml @@ -29,8 +29,22 @@ let is_builtin_fn = function else false module Mochi = struct - type adist = Left | Right | Niladist [@@deriving sexp] - type atype = ABase of adist | ATuple of atype list [@@deriving sexp] + (** Direction of assignment generated by alias statements *) + type adist = Left | Right | None [@@deriving sexp] + + (** The value actually assigned by alias statements *) + type arhs = + | AVar of string + | AList of string list + [@@deriving sexp] + + (** The expression to assign value by alias statements *) + type aexp = + | AVarExp of string list + | ATupleLhsExp of string list * string * string * aexp * string list + | ATupleRhsExp of string list * string * aexp + | AListExp of string * string * string * aexp + [@@deriving sexp] type exp = | Unit @@ -47,14 +61,7 @@ module Mochi = struct | Read of string * string | Assert of relation * exp | Update of string * string * string * exp - | Alias of - (* Paths.steps list は Paths と逆順 *) - string - * string - * patt - * patt - * patt - * exp + | Alias of string * aexp | Nil | Cons of exp * exp | Match of string * exp * string * string * exp @@ -187,6 +194,7 @@ module Mochi = struct pf " :: "; pp_exp t; ] + (* It is not right. We have to use monad to use variables that is defined or updated in branch *) | Match (x, e1, h, r, e2) -> pl [ pf "match %s with " x; @@ -224,6 +232,17 @@ module Mochi = struct pp_prog prog std_formatter end +let pull_type ty con i = + let open OwnershipInference in + match ty with + | Ref (t, _) -> t + | Tuple ts -> List.nth ts i + | IntList ol -> + if con = "Cons" && i = 2 + then Ref (IntList (List.tl ol @ [(List.hd @@ List.rev ol)]), List.hd ol) + else failwith "Only .Cons.2 is supported in paths related to recursive types in alias statement" + | _ -> assert false + let rec lhs_to_mochi (ri : OwnershipInference.Result.t) (ro : (int * float) list) i = let open OwnershipInference in @@ -284,13 +303,11 @@ let alias_to_adist (ro : (int * float) list) | Tuple tys -> walk (List.nth tys i) ss | _ -> assert false) | `Cons (s, i) :: ss -> - if s = "Cons" && i = 2 then ( - match ty with - | IntList ol -> - let ty' = Ref (IntList (List.tl ol @ [(List.hd @@ List.rev ol)]), List.hd ol) in - walk ty' ss - | _ -> assert false) - else failwith "Only .Cons.2 is supported in paths related to recursive types in alias statement" + match ty with + | IntList _ -> + let ty' = pull_type ty s i in + walk ty' ss + | _ -> assert false in let tl = walk tl rsl in let tr = walk tr rsr in @@ -299,7 +316,7 @@ let alias_to_adist (ro : (int * float) list) match (tl, tr) with | Array (tl', o1), Array (tr', o2) | Ref (tl', o1), Ref (tr', o2) -> let zl, zr = (map_o ro o1 = 0., map_o ro o2 = 0.) in - if zl then if zr then Niladist else Left + if zl then if zr then None else Left else if zr then Right else loop tl' tr' | Tuple tsl, Tuple tsr -> @@ -309,112 +326,85 @@ let alias_to_adist (ro : (int * float) list) (fun (nl, nr, nn) -> function | Left -> (nl + 1, nr, nn) | Right -> (nl, nr + 1, nn) - | Niladist -> (nl, nr, nn + 1)) + | None -> (nl, nr, nn + 1)) (0, 0, 0) adists in let n = List.length adists in - if nn = n then Niladist + if nn = n then None else if nl + nn = n then Left else if nr + nn = n then Right else assert false - | Int, Int -> Niladist + | Int, Int -> None | t1, _ -> failwith (Printf.sprintf "ill type: %s" (sexp_of_otype t1 |> string_of_sexp)) in (rsl, rsr, loop tl tr) -let alias_to_patt (ro : (int * float) list) +let alias_to_mochi (ro : (int * float) list) ((xl, tl, sl) : string * OwnershipInference.otype * Paths.steps list) - ((xr, tr, sr) : string * OwnershipInference.otype * Paths.steps list) = + ((xr, tr, sr) : string * OwnershipInference.otype * Paths.steps list) + (e : Mochi.exp) : Mochi.exp = let open OwnershipInference in - let rsl, rsr, adist = alias_to_adist ro (tl, sl) (tr, sr) in - let xd, td, sd, xs, ts, ss = - match adist with - | Left -> (xl, tl, rsl, xr, tr, rsr) - | _ -> (xr, tr, rsr, xl, tl, rsl) - in - let rec xname x = function - | [] -> x - | `Deref :: s -> xname x s - | `Proj i :: s -> xname (Printf.sprintf "%s'%i" x i) s - | `Cons _ :: _ -> assert false + let rec conv_alias_rhs xs ts rss e acc = + match rss with + | [] -> Mochi.AVarExp (List.rev (xs :: acc)) + | `Deref :: ss -> ( + match ts with + | Ref (_, o) -> + assert (map_o ro o > 0.); + let ty' = pull_type ts "" 0 in + conv_alias_rhs xs ty' ss e acc + | _ -> assert false) + | `Proj i :: ss -> ( + match ts with + | Tuple tys -> + let xspats = List.mapi (fun j _ -> if i = j then Printf.sprintf "%s'%i" xs j else "_") tys in + let xsi = Printf.sprintf "%s'%i" xs i in + let ty' = pull_type ts "" i in + Mochi.ATupleRhsExp (xspats, xs, conv_alias_rhs xsi ty' ss e acc) + | _ -> assert false) + | `Cons (s, i) :: ss -> ( + match ts with + | IntList _ -> + let ty' = pull_type ts s i in + let h = Printf.sprintf "%s'1" xs in + let t = Printf.sprintf "%s'2" xs in + Mochi.AListExp (xs, h, t, conv_alias_rhs t ty' ss e acc) + | _ -> assert false) in - let xxd = xname xd sd in - let xxs = xname xs ss in - let rec e_patt rx x t = function - | [] -> PVar rx - | `Deref :: s -> ( - match t with + let rec conv_alias xd td rsd xs ts rss e acc = + match rsd with + | [] -> conv_alias_rhs xs ts rss e acc + | `Deref :: ss -> ( + match td with | Ref (t', o) -> - assert (map_o ro o > 0.); - e_patt rx x t' s + assert (map_o ro o > 0.); + conv_alias xd t' ss xs ts rss e acc | _ -> assert false) - | `Proj i :: s -> ( - match t with + | `Proj i :: ss -> ( + match td with | Tuple tys -> - let x' = Printf.sprintf "%s'%i" x i in - PTuple - (List.mapi - (fun j ty -> if i = j then e_patt rx x' ty s else PVar x') - tys) - | _ -> assert false) - | `Cons _ :: _ -> assert false - in - let ptd = e_patt xxd xd td sd in - let pts = e_patt xxs xs ts ss in - let pt_ = e_patt xxs xd td sd in - (xd, xs, ptd, pts, pt_) -(* -let alias_to_aty (ro : (int * float) list) - ((tl, sl) : OwnershipInference.otype * Paths.steps list) - ((tr, sr) : OwnershipInference.otype * Paths.steps list) = - let open OwnershipInference in - let rsl = List.rev sl in - let rsr = List.rev sr in - let rec walk ty = function - | [] -> ty - | `Deref :: ss -> ( - match ty with - | Ref (ty', o) -> - assert (map_o ro o > 0.); - walk ty' ss + let xdpats = List.mapi (fun j _ -> Printf.sprintf "%s'%i" xd j) tys in + let xdpats' = List.mapi (fun j _ -> Printf.sprintf (if i = j then "%s''%i" else "%s'%i") xd j) tys in + let xdi' = Printf.sprintf "%s''%i" xd i in + let ty' = pull_type td "" i in + Mochi.ATupleLhsExp (xdpats, xd, xdi', conv_alias xdi' ty' ss xs ts rss e acc, xdpats') | _ -> assert false) - | `Proj i :: ss -> ( - match ty with - | Tuple tys -> walk (List.nth tys i) ss + | `Cons (s, i) :: ss -> ( + match td with + | IntList _ -> + let ty' = pull_type td s i in + let h = Printf.sprintf "%s'1" xd in + let t = Printf.sprintf "%s'2" xd in + Mochi.AListExp(xd, h, t, conv_alias t ty' ss xs ts rss e (h :: acc)) | _ -> assert false) in - let tl = walk tl rsl in - let tr = walk tr rsr in - let open Mochi in - let rec loop tl tr = - match (tl, tr) with - | Array (tl', o1), Array (tr', o2) | Ref (tl', o1), Ref (tr', o2) -> - let zl, zr = (map_o ro o1 = 0., map_o ro o2 = 0.) in - if zl then if zr then ABase Nil else ABase Left - else if zr then ABase Right - else loop tl' tr' - | Tuple tsl, Tuple tsr -> - let atys = List.map2 loop tsl tsr in - let nl, nr, nn = - List.fold_left - (fun ((nl, nr, nn) as acc) -> function - | ABase Left -> (nl + 1, nr, nn) - | ABase Right -> (nl, nr + 1, nn) - | ABase Nil -> (nl, nr, nn + 1) - | _ -> acc) - (0, 0, 0) atys - in - let n = List.length atys in - if nl = n then ABase Left - else if nr = n then ABase Right - else if nn = n then ABase Nil - else ATuple atys - | Int, Int -> ABase Nil - | _ -> assert false - in - loop tl tr *) + let rsl, rsr, adist = alias_to_adist ro (tl, sl) (tr, sr) in + match adist with + | Left -> Mochi.Alias(xl, conv_alias xl tl rsl xr tr rsr e []) + | Right -> Mochi.Alias(xr, conv_alias xr tr rsr xl tl rsl e []) + | None -> e let rec exp_to_mochi (ri : OwnershipInference.Result.t) (ro : (int * float) list) (vs : string list) (((i, _), e) : exp) = @@ -462,10 +452,7 @@ let rec exp_to_mochi (ri : OwnershipInference.Result.t) let r2, st2, _ = (p2 :> root * steps list * suff) in match (r1, r2) with | Var x1, Var x2 -> - let xd, xs, p1, p2, p3 = - alias_to_patt ro (x1, map_ty x1, st1) (x2, map_ty x2, st2) - in - Mochi.Alias (xd, xs, p1, p2, p3, exp_to_mochi ri ro vs e) + alias_to_mochi ro (x1, map_ty x1, st1) (x2, map_ty x2, st2) (exp_to_mochi ri ro vs e) | _ -> assert false) | Match (e1, e2, h, t, e3) -> match e1 with From 101021228485e41c8986e8af67fa77af1ff0ff51 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Fri, 4 Aug 2023 13:17:47 +0900 Subject: [PATCH 075/108] support for pretty printing of alias --- src/convMoCHi.ml | 49 ++++++++++++++++++++++++++++++++++++------------ 1 file changed, 37 insertions(+), 12 deletions(-) diff --git a/src/convMoCHi.ml b/src/convMoCHi.ml index 18dcaa47..995a66c5 100644 --- a/src/convMoCHi.ml +++ b/src/convMoCHi.ml @@ -32,6 +32,7 @@ module Mochi = struct (** Direction of assignment generated by alias statements *) type adist = Left | Right | None [@@deriving sexp] + (* TODO: Is it needed? *) (** The value actually assigned by alias statements *) type arhs = | AVar of string @@ -127,6 +128,38 @@ module Mochi = struct | Ref (ot, _) -> pp_nondet_ot ot | _ -> assert false + let rec pp_aexp = function + | AVarExp xs -> ps @@ String.concat " :: " xs + | ATupleLhsExp (xs, x, xi', ae, xs') -> + pl [ + ps "let ("; + ps @@ String.concat ", " xs; + pf ") = %s in" x; + nl; + pf "let %s = " xi'; + pp_aexp ae; + ps " in"; + ps "("; + ps @@ String.concat ", " xs'; + ps ")"; + ] + | ATupleRhsExp (xs, x, ae) -> + pl [ + ps "let ("; + ps @@ String.concat ", " xs; + pf ") = %s in" x; + pp_aexp ae; + ] + | AListExp (x, h, t, ae) -> + pl [ + pf "match %s with" x; + nl; + pf "%s :: %s ->" h t; + nl; + pp_aexp ae; + ps " | _ -> assert false"; + ] + let rec pp_exp = function | Unit -> ps "()" | Fail -> ps "Fail" @@ -161,19 +194,11 @@ module Mochi = struct | Call (callee, arg_names) -> let pp_callee = fn_to_mochi callee in pf "(%s %s)" pp_callee @@ String.concat " " arg_names - | Alias (xd, xs, p1, p2, p3, e) -> + | Alias (x, ae) -> pl [ - pf "let %s = %a in" xd (ul pl) - [ - pf "let %a = %s in" (ul AstPrinter.pp_patt) p1 xd; - nl; - pf "let %a = %s in" (ul AstPrinter.pp_patt) p2 xs; - nl; - AstPrinter.pp_patt p3; - ]; - nl; - pp_exp e; + pf "let %s = " x; + pp_aexp ae; ] | Cond (x, e1, e2) -> pblock ~nl:false ~op:(pf "if %s = 0 then (" x) ~body:(pp_exp e1) @@ -194,7 +219,7 @@ module Mochi = struct pf " :: "; pp_exp t; ] - (* It is not right. We have to use monad to use variables that is defined or updated in branch *) + (* TODO: It is not right. We have to use monad to use variables that is defined or updated in branch *) | Match (x, e1, h, r, e2) -> pl [ pf "match %s with " x; From 9188d590661214e1ad803d66acf29fcb5e4717f9 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Wed, 9 Aug 2023 16:03:59 +0900 Subject: [PATCH 076/108] move a test --- src/test/{ => monad}/cond.imp | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename src/test/{ => monad}/cond.imp (100%) diff --git a/src/test/cond.imp b/src/test/monad/cond.imp similarity index 100% rename from src/test/cond.imp rename to src/test/monad/cond.imp From 55c588245ab1b7253b407d847951a6d247d0322c Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 10 Aug 2023 18:17:43 +0900 Subject: [PATCH 077/108] some fix --- src/convMoCHi.ml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/convMoCHi.ml b/src/convMoCHi.ml index 995a66c5..ed0fccab 100644 --- a/src/convMoCHi.ml +++ b/src/convMoCHi.ml @@ -119,13 +119,13 @@ module Mochi = struct pf "%a@ &&@ %a" (ul pp_refinement) r1 (ul pp_refinement) r2 | _ -> failwith @@ "Cannot annotate with relation " ^ string_of_refinement r -(* TODO: Is the case of IntList needed? *) let rec pp_nondet_ot = let open OwnershipInference in function | Int -> ps "Random.int 0" | Tuple ots -> pl [ ps "("; psep ", " @@ List.map pp_nondet_ot ots; ps ")" ] | Ref (ot, _) -> pp_nondet_ot ot + | IntList _ -> ps "_" | _ -> assert false let rec pp_aexp = function @@ -152,12 +152,12 @@ module Mochi = struct ] | AListExp (x, h, t, ae) -> pl [ - pf "match %s with" x; + pf "( match %s with" x; nl; pf "%s :: %s ->" h t; nl; pp_aexp ae; - ps " | _ -> assert false"; + ps " | _ -> assert false )"; ] let rec pp_exp = function @@ -222,13 +222,13 @@ module Mochi = struct (* TODO: It is not right. We have to use monad to use variables that is defined or updated in branch *) | Match (x, e1, h, r, e2) -> pl [ - pf "match %s with " x; - pf "[] -> { "; + pf "( match %s with " x; + pf "[] -> ( "; pp_exp e1; - ps " } "; - pf "| Cons %s (%s) -> { " h r; + ps " ) "; + pf "| %s :: %s -> ( " h r; pp_exp e2; - ps "}"; + ps " ) ) "; ] let pp_fn ff { name; args; body } ~first = From 001d25e62ef720fbec65720dd62995d5bfd0f9cf Mon Sep 17 00:00:00 2001 From: artoy Date: Thu, 10 Aug 2023 18:30:28 +0900 Subject: [PATCH 078/108] add a comment and some fix --- src/convMoCHi.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/convMoCHi.ml b/src/convMoCHi.ml index ed0fccab..f8409223 100644 --- a/src/convMoCHi.ml +++ b/src/convMoCHi.ml @@ -125,6 +125,7 @@ module Mochi = struct | Int -> ps "Random.int 0" | Tuple ots -> pl [ ps "("; psep ", " @@ List.map pp_nondet_ot ots; ps ")" ] | Ref (ot, _) -> pp_nondet_ot ot + (* TODO: What should it be? *) | IntList _ -> ps "_" | _ -> assert false @@ -154,10 +155,10 @@ module Mochi = struct pl [ pf "( match %s with" x; nl; - pf "%s :: %s ->" h t; - nl; + pf "%s :: %s -> " h t; pp_aexp ae; - ps " | _ -> assert false )"; + nl; + ps "| _ -> assert false )"; ] let rec pp_exp = function @@ -226,6 +227,7 @@ module Mochi = struct pf "[] -> ( "; pp_exp e1; ps " ) "; + nl; pf "| %s :: %s -> ( " h r; pp_exp e2; ps " ) ) "; From dd704c0d7685a387e5930434154ccbccedc1f89d Mon Sep 17 00:00:00 2001 From: artoy Date: Fri, 11 Aug 2023 22:56:27 +0900 Subject: [PATCH 079/108] fix alias statment --- src/convMoCHi.ml | 29 ++++++++++++++++------------- 1 file changed, 16 insertions(+), 13 deletions(-) diff --git a/src/convMoCHi.ml b/src/convMoCHi.ml index f8409223..df827fa3 100644 --- a/src/convMoCHi.ml +++ b/src/convMoCHi.ml @@ -62,7 +62,7 @@ module Mochi = struct | Read of string * string | Assert of relation * exp | Update of string * string * string * exp - | Alias of string * aexp + | Alias of string * aexp * exp | Nil | Cons of exp * exp | Match of string * exp * string * string * exp @@ -195,11 +195,14 @@ module Mochi = struct | Call (callee, arg_names) -> let pp_callee = fn_to_mochi callee in pf "(%s %s)" pp_callee @@ String.concat " " arg_names - | Alias (x, ae) -> + | Alias (x, ae, e) -> pl [ pf "let %s = " x; pp_aexp ae; + ps " in"; + nl; + pp_exp e; ] | Cond (x, e1, e2) -> pblock ~nl:false ~op:(pf "if %s = 0 then (" x) ~body:(pp_exp e1) @@ -373,7 +376,7 @@ let alias_to_mochi (ro : (int * float) list) ((xr, tr, sr) : string * OwnershipInference.otype * Paths.steps list) (e : Mochi.exp) : Mochi.exp = let open OwnershipInference in - let rec conv_alias_rhs xs ts rss e acc = + let rec conv_alias_rhs xs ts rss acc = match rss with | [] -> Mochi.AVarExp (List.rev (xs :: acc)) | `Deref :: ss -> ( @@ -381,7 +384,7 @@ let alias_to_mochi (ro : (int * float) list) | Ref (_, o) -> assert (map_o ro o > 0.); let ty' = pull_type ts "" 0 in - conv_alias_rhs xs ty' ss e acc + conv_alias_rhs xs ty' ss acc | _ -> assert false) | `Proj i :: ss -> ( match ts with @@ -389,7 +392,7 @@ let alias_to_mochi (ro : (int * float) list) let xspats = List.mapi (fun j _ -> if i = j then Printf.sprintf "%s'%i" xs j else "_") tys in let xsi = Printf.sprintf "%s'%i" xs i in let ty' = pull_type ts "" i in - Mochi.ATupleRhsExp (xspats, xs, conv_alias_rhs xsi ty' ss e acc) + Mochi.ATupleRhsExp (xspats, xs, conv_alias_rhs xsi ty' ss acc) | _ -> assert false) | `Cons (s, i) :: ss -> ( match ts with @@ -397,17 +400,17 @@ let alias_to_mochi (ro : (int * float) list) let ty' = pull_type ts s i in let h = Printf.sprintf "%s'1" xs in let t = Printf.sprintf "%s'2" xs in - Mochi.AListExp (xs, h, t, conv_alias_rhs t ty' ss e acc) + Mochi.AListExp (xs, h, t, conv_alias_rhs t ty' ss acc) | _ -> assert false) in - let rec conv_alias xd td rsd xs ts rss e acc = + let rec conv_alias xd td rsd xs ts rss acc = match rsd with - | [] -> conv_alias_rhs xs ts rss e acc + | [] -> conv_alias_rhs xs ts rss acc | `Deref :: ss -> ( match td with | Ref (t', o) -> assert (map_o ro o > 0.); - conv_alias xd t' ss xs ts rss e acc + conv_alias xd t' ss xs ts rss acc | _ -> assert false) | `Proj i :: ss -> ( match td with @@ -416,7 +419,7 @@ let alias_to_mochi (ro : (int * float) list) let xdpats' = List.mapi (fun j _ -> Printf.sprintf (if i = j then "%s''%i" else "%s'%i") xd j) tys in let xdi' = Printf.sprintf "%s''%i" xd i in let ty' = pull_type td "" i in - Mochi.ATupleLhsExp (xdpats, xd, xdi', conv_alias xdi' ty' ss xs ts rss e acc, xdpats') + Mochi.ATupleLhsExp (xdpats, xd, xdi', conv_alias xdi' ty' ss xs ts rss acc, xdpats') | _ -> assert false) | `Cons (s, i) :: ss -> ( match td with @@ -424,13 +427,13 @@ let alias_to_mochi (ro : (int * float) list) let ty' = pull_type td s i in let h = Printf.sprintf "%s'1" xd in let t = Printf.sprintf "%s'2" xd in - Mochi.AListExp(xd, h, t, conv_alias t ty' ss xs ts rss e (h :: acc)) + Mochi.AListExp(xd, h, t, conv_alias t ty' ss xs ts rss (h :: acc)) | _ -> assert false) in let rsl, rsr, adist = alias_to_adist ro (tl, sl) (tr, sr) in match adist with - | Left -> Mochi.Alias(xl, conv_alias xl tl rsl xr tr rsr e []) - | Right -> Mochi.Alias(xr, conv_alias xr tr rsr xl tl rsl e []) + | Left -> Mochi.Alias(xl, conv_alias xl tl rsl xr tr rsr [], e) + | Right -> Mochi.Alias(xr, conv_alias xr tr rsr xl tl rsl [], e) | None -> e let rec exp_to_mochi (ri : OwnershipInference.Result.t) From 2d383b8dea673d4bc730dec28a1da950d5c6ea40 Mon Sep 17 00:00:00 2001 From: artoy Date: Sat, 12 Aug 2023 11:54:51 +0900 Subject: [PATCH 080/108] add a test --- src/test/list/{ => easy}/alias-cons2.imp | 0 src/test/list/{ => easy}/cons.imp | 0 src/test/list/{ => easy}/match-easy.imp | 0 src/test/list/{ => easy}/match.imp | 0 src/test/list/{ => easy}/nil.imp | 0 src/test/list/length.imp | 20 ++++++++++++++++++++ 6 files changed, 20 insertions(+) rename src/test/list/{ => easy}/alias-cons2.imp (100%) rename src/test/list/{ => easy}/cons.imp (100%) rename src/test/list/{ => easy}/match-easy.imp (100%) rename src/test/list/{ => easy}/match.imp (100%) rename src/test/list/{ => easy}/nil.imp (100%) create mode 100644 src/test/list/length.imp diff --git a/src/test/list/alias-cons2.imp b/src/test/list/easy/alias-cons2.imp similarity index 100% rename from src/test/list/alias-cons2.imp rename to src/test/list/easy/alias-cons2.imp diff --git a/src/test/list/cons.imp b/src/test/list/easy/cons.imp similarity index 100% rename from src/test/list/cons.imp rename to src/test/list/easy/cons.imp diff --git a/src/test/list/match-easy.imp b/src/test/list/easy/match-easy.imp similarity index 100% rename from src/test/list/match-easy.imp rename to src/test/list/easy/match-easy.imp diff --git a/src/test/list/match.imp b/src/test/list/easy/match.imp similarity index 100% rename from src/test/list/match.imp rename to src/test/list/easy/match.imp diff --git a/src/test/list/nil.imp b/src/test/list/easy/nil.imp similarity index 100% rename from src/test/list/nil.imp rename to src/test/list/easy/nil.imp diff --git a/src/test/list/length.imp b/src/test/list/length.imp new file mode 100644 index 00000000..ef0596f5 --- /dev/null +++ b/src/test/list/length.imp @@ -0,0 +1,20 @@ +mklist(n) { + if n = 0 then Nil else { + let h = _ in + let m = n + -1 in + let t = mkref mklist(m) in + Cons h t + } +} + +len(l) { + match l with + Nil -> 0 + | Cons h t -> 1 + len(*t) +} + +{ + let n = ( _ : ~ >= 0) in + let l = mklist(n) in + assert(len(l) = n) +} \ No newline at end of file From 280f2b34c720715eb5de491050792775e7caad30 Mon Sep 17 00:00:00 2001 From: artoy Date: Sun, 13 Aug 2023 17:12:24 +0900 Subject: [PATCH 081/108] support for undet IntList --- src/convMoCHi.ml | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/src/convMoCHi.ml b/src/convMoCHi.ml index df827fa3..8af1ba9f 100644 --- a/src/convMoCHi.ml +++ b/src/convMoCHi.ml @@ -71,7 +71,7 @@ module Mochi = struct type fn = { name : string; args : string list; body : exp } [@@deriving sexp] type prog = fn list * exp [@@deriving sexp] - let arrfuns = + let builtin = "let eq' x y = if x = y then 0 else 1\n\ let ne' x y = if x <> y then 0 else 1\n\ let lt' x y = if x < y then 0 else 1\n\ @@ -82,7 +82,14 @@ module Mochi = struct let lor' x y = if x = 0 || y = 0 then 0 else 1\n\ let mkarray' n = (n, fun i -> assert (0 <= i && i < n); 0)\n\ let update' arr i x = let a = snd arr in (a i; (fst arr, fun j -> a j; if j = i \ - then x else a j))\n" + then x else a j))\n\ + let rec undetlist' =\n\ + let rand' = Random.int 0 in\n\ + if rand' >= 0 then (\n\ + let rec mk' n =\n\ + if n = 0 then [] else (Random.int 0) :: mk'(n - 1)\n\ + in mk' rand'\n\ + ) else undetlist'\n" let ap_to_string (root, steps, _) = let open Paths in @@ -125,8 +132,7 @@ module Mochi = struct | Int -> ps "Random.int 0" | Tuple ots -> pl [ ps "("; psep ", " @@ List.map pp_nondet_ot ots; ps ")" ] | Ref (ot, _) -> pp_nondet_ot ot - (* TODO: What should it be? *) - | IntList _ -> ps "_" + | IntList _ -> ps "undetlist'" | _ -> assert false let rec pp_aexp = function @@ -258,7 +264,7 @@ module Mochi = struct pp_force_newline ff () let print_prog prog = - print_endline arrfuns; + print_endline builtin; pp_prog prog std_formatter end From ea58b0d61cb8b47c0282e650cc518f52ff935497 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 24 Aug 2023 23:24:59 +0900 Subject: [PATCH 082/108] some fix and add tests --- src/convMoCHi.ml | 2 +- src/test/list/hd.imp | 22 ++++++++++++++++++++++ src/test/list/length.imp | 7 +++++-- src/test/list/nth.imp | 7 +++++++ src/test/list/tl.imp | 39 +++++++++++++++++++++++++++++++++++++++ 5 files changed, 74 insertions(+), 3 deletions(-) create mode 100644 src/test/list/hd.imp create mode 100644 src/test/list/nth.imp create mode 100644 src/test/list/tl.imp diff --git a/src/convMoCHi.ml b/src/convMoCHi.ml index 8af1ba9f..84058c89 100644 --- a/src/convMoCHi.ml +++ b/src/convMoCHi.ml @@ -169,7 +169,7 @@ module Mochi = struct let rec pp_exp = function | Unit -> ps "()" - | Fail -> ps "Fail" + | Fail -> ps "assert false" | Tuple es -> pl [ ps "("; psep ", " @@ List.map pp_exp es; ps ")" ] | Var x -> assert (String.get x 0 > 'Z'); diff --git a/src/test/list/hd.imp b/src/test/list/hd.imp new file mode 100644 index 00000000..08f77b09 --- /dev/null +++ b/src/test/list/hd.imp @@ -0,0 +1,22 @@ +mklist(n) { + if n = 0 then Nil else { + let h = _ in + let m = n + -1 in + let t = mkref mklist(m) in + Cons h t + } +} + +hd(l) { + match l with + Nil -> fail + | Cons h t -> return h +} + +{ + let n = ( _ : ~ > 0) in + let l = mklist(n) in + match l with + Nil -> fail + | Cons h t -> assert(hd(l) = h) +} \ No newline at end of file diff --git a/src/test/list/length.imp b/src/test/list/length.imp index ef0596f5..bfb53e87 100644 --- a/src/test/list/length.imp +++ b/src/test/list/length.imp @@ -9,8 +9,11 @@ mklist(n) { len(l) { match l with - Nil -> 0 - | Cons h t -> 1 + len(*t) + Nil -> return 0 + | Cons h t -> { + let n = 1 + len(*t) in + return n + } } { diff --git a/src/test/list/nth.imp b/src/test/list/nth.imp new file mode 100644 index 00000000..59dbff12 --- /dev/null +++ b/src/test/list/nth.imp @@ -0,0 +1,7 @@ +nth(l, n) { + +} + +{ + +} \ No newline at end of file diff --git a/src/test/list/tl.imp b/src/test/list/tl.imp new file mode 100644 index 00000000..dc13a5e4 --- /dev/null +++ b/src/test/list/tl.imp @@ -0,0 +1,39 @@ +mklist(n) { + if n = 0 then Nil else { + let h = _ in + let m = n + -1 in + let t = mkref mklist(m) in + Cons h t + } +} + +assert_eq(l1, l2) { + match l1 with + Nil -> { + match l2 with + Nil -> () + | Cons h2 t2 -> fail + } + | Cons h1 t1 -> { + match l2 with + Nil -> fail + | Cons h2 t2 -> { + assert(h1 = h2); + assert_eq(*t1, *t2) + } + } +} + +tl(l) { + match l with + Nil -> fail + | Cons h t -> return *t +} + +{ + let n = ( _ : ~ > 0) in + let l = mklist(n) in + match l with + Nil -> fail + | Cons h t -> assert_eq(tl(l), *t) +} \ No newline at end of file From 881902f2c7b4a690dd512b750cbc82f2d954f1e9 Mon Sep 17 00:00:00 2001 From: artoy Date: Thu, 24 Aug 2023 23:58:42 +0900 Subject: [PATCH 083/108] update tests --- src/test/list/nth.imp | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/src/test/list/nth.imp b/src/test/list/nth.imp index 59dbff12..6ba96e1e 100644 --- a/src/test/list/nth.imp +++ b/src/test/list/nth.imp @@ -1,7 +1,24 @@ -nth(l, n) { +mklist(n) { + if n = 0 then Nil else { + let h = _ in + let m = n + -1 in + let t = mkref mklist(m) in + Cons h t + } +} +nth(l, n) { + match l with + Nil -> fail + | Cons h t -> { + let m = n + -1 in + if n = 1 then h else nth(*t, m) + } } { - + let n = ( _ : ~ >= 1) in + let k = ( _ : ~ >= 1 /\ ~ <= n) in + let l = mklist(n) in + nth(l, k) } \ No newline at end of file From 3361880ac9c8a16c0195e37fe5d5f2a50783d9c6 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 28 Aug 2023 15:52:17 +0900 Subject: [PATCH 084/108] update built-in functions --- src/convMoCHi.ml | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/src/convMoCHi.ml b/src/convMoCHi.ml index 84058c89..dd7110b3 100644 --- a/src/convMoCHi.ml +++ b/src/convMoCHi.ml @@ -83,13 +83,9 @@ module Mochi = struct let mkarray' n = (n, fun i -> assert (0 <= i && i < n); 0)\n\ let update' arr i x = let a = snd arr in (a i; (fst arr, fun j -> a j; if j = i \ then x else a j))\n\ - let rec undetlist' =\n\ + let rec undetlist' () =\n\ let rand' = Random.int 0 in\n\ - if rand' >= 0 then (\n\ - let rec mk' n =\n\ - if n = 0 then [] else (Random.int 0) :: mk'(n - 1)\n\ - in mk' rand'\n\ - ) else undetlist'\n" + if rand' > 0 then (Random.int 0) :: (undetlist' ()) else []\n" let ap_to_string (root, steps, _) = let open Paths in @@ -132,7 +128,7 @@ module Mochi = struct | Int -> ps "Random.int 0" | Tuple ots -> pl [ ps "("; psep ", " @@ List.map pp_nondet_ot ots; ps ")" ] | Ref (ot, _) -> pp_nondet_ot ot - | IntList _ -> ps "undetlist'" + | IntList _ -> ps "(undetlist' ())" | _ -> assert false let rec pp_aexp = function From 1797552d471896ae65b139238939f658507e2bf8 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 4 Sep 2023 14:21:55 +0900 Subject: [PATCH 085/108] fix a test --- src/test/list/length.imp | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/test/list/length.imp b/src/test/list/length.imp index bfb53e87..4fe4cb91 100644 --- a/src/test/list/length.imp +++ b/src/test/list/length.imp @@ -11,8 +11,12 @@ len(l) { match l with Nil -> return 0 | Cons h t -> { - let n = 1 + len(*t) in - return n + let t_der = *t in + let n = 1 + len(t_der) in { + alias(t_der = *t); + alias(l.Cons.2 = t); + return n + } } } From 49b4033dcdbfdd5c1bfabdc6ba52ec880c08f3f5 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 4 Sep 2023 14:46:40 +0900 Subject: [PATCH 086/108] fix decision of the way of assign when alias --- src/convMoCHi.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/convMoCHi.ml b/src/convMoCHi.ml index dd7110b3..c0e62b7b 100644 --- a/src/convMoCHi.ml +++ b/src/convMoCHi.ml @@ -367,6 +367,7 @@ let alias_to_adist (ro : (int * float) list) else if nr + nn = n then Right else assert false | Int, Int -> None + | IntList _, IntList _ -> loop (pull_type tl "Cons" 2) (pull_type tr "Cons" 2) | t1, _ -> failwith (Printf.sprintf "ill type: %s" (sexp_of_otype t1 |> string_of_sexp)) From 2a2be1b5c23ba578c8ed555a2f562e616643ffca Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 4 Sep 2023 14:54:17 +0900 Subject: [PATCH 087/108] fix tests --- src/test/list/length.imp | 4 ++-- src/test/list/tl.imp | 9 ++++++++- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/src/test/list/length.imp b/src/test/list/length.imp index 4fe4cb91..0b48d988 100644 --- a/src/test/list/length.imp +++ b/src/test/list/length.imp @@ -12,8 +12,8 @@ len(l) { Nil -> return 0 | Cons h t -> { let t_der = *t in - let n = 1 + len(t_der) in { - alias(t_der = *t); + let n = 1 + len(t_deref) in { + alias(t_deref = *t); alias(l.Cons.2 = t); return n } diff --git a/src/test/list/tl.imp b/src/test/list/tl.imp index dc13a5e4..31c5060c 100644 --- a/src/test/list/tl.imp +++ b/src/test/list/tl.imp @@ -19,7 +19,14 @@ assert_eq(l1, l2) { Nil -> fail | Cons h2 t2 -> { assert(h1 = h2); - assert_eq(*t1, *t2) + let t1_deref = *t1 in + let t2_deref = *t2 in { + assert_eq(t1_deref, t2_deref); + alias(t1_deref = *t1); + alias(l1.Cons.2 = t1); + alias(t2_deref = *t2); + alias(l2.Cons.2 = t2) + } } } } From 0dd53ff507a2592b8ecf7e4c51d9f4a1f3361885 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 4 Sep 2023 14:56:34 +0900 Subject: [PATCH 088/108] add comment --- src/convMoCHi.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/convMoCHi.ml b/src/convMoCHi.ml index c0e62b7b..6541cb90 100644 --- a/src/convMoCHi.ml +++ b/src/convMoCHi.ml @@ -369,6 +369,7 @@ let alias_to_adist (ro : (int * float) list) | Int, Int -> None | IntList _, IntList _ -> loop (pull_type tl "Cons" 2) (pull_type tr "Cons" 2) | t1, _ -> + (* TODO: Maybe, error statement below does not support IntList. *) failwith (Printf.sprintf "ill type: %s" (sexp_of_otype t1 |> string_of_sexp)) in From 4c163cdc17ab1ac303f9c26b36da494d3dd9f0fe Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 4 Sep 2023 15:01:37 +0900 Subject: [PATCH 089/108] delete comment --- src/convMoCHi.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/convMoCHi.ml b/src/convMoCHi.ml index 6541cb90..ac169316 100644 --- a/src/convMoCHi.ml +++ b/src/convMoCHi.ml @@ -225,7 +225,6 @@ module Mochi = struct pf " :: "; pp_exp t; ] - (* TODO: It is not right. We have to use monad to use variables that is defined or updated in branch *) | Match (x, e1, h, r, e2) -> pl [ pf "( match %s with " x; From 73dd5b0c11a5d0ab02dd0a64a37a2c08b6fd46fd Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 4 Sep 2023 15:49:22 +0900 Subject: [PATCH 090/108] insert "int list" to argument automatically --- src/convMoCHi.ml | 15 ++++++++++++--- src/test/list/length.imp | 2 +- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/src/convMoCHi.ml b/src/convMoCHi.ml index ac169316..e970d8f0 100644 --- a/src/convMoCHi.ml +++ b/src/convMoCHi.ml @@ -68,7 +68,7 @@ module Mochi = struct | Match of string * exp * string * string * exp [@@deriving sexp] - type fn = { name : string; args : string list; body : exp } [@@deriving sexp] + type fn = { name : string; args : (string * OwnershipInference.otype) list; body : exp } [@@deriving sexp] type prog = fn list * exp [@@deriving sexp] let builtin = @@ -237,13 +237,17 @@ module Mochi = struct ps " ) ) "; ] + let pp_arg = function + | (arg, OwnershipInference.IntList _) -> Printf.sprintf "(%s: int list)" arg + | (arg, _) -> arg + let pp_fn ff { name; args; body } ~first = pl [ pblock ~nl:true ~op: (pf "%s %s %s =" (if first then "let rec" else "and") name - @@ String.concat " " args) + @@ String.concat " " @@ List.map pp_arg args) ~body:(pp_exp body) ~close:null; ] ff @@ -494,7 +498,12 @@ let rec exp_to_mochi (ri : OwnershipInference.Result.t) let fn_to_mochi (ri : OwnershipInference.Result.t) (ro : (int * float) list) { name; args; body } = - Mochi.{ name; args; body = exp_to_mochi ri ro args body } + let rec zip_list l1 l2 acc = + match l1, l2 with + h1 :: t1, h2 :: t2 -> zip_list t1 t2 ((h1, h2) :: acc) + | _ -> acc + in + Mochi.{ name; args = zip_list args (StringMap.find name ri.theta).arg_types []; body = exp_to_mochi ri ro args body } let prog_to_mochi (ri : OwnershipInference.Result.t) (ro : (int * float) list) (fns, exp) = diff --git a/src/test/list/length.imp b/src/test/list/length.imp index 0b48d988..85b19d2c 100644 --- a/src/test/list/length.imp +++ b/src/test/list/length.imp @@ -11,7 +11,7 @@ len(l) { match l with Nil -> return 0 | Cons h t -> { - let t_der = *t in + let t_deref = *t in let n = 1 + len(t_deref) in { alias(t_deref = *t); alias(l.Cons.2 = t); From 1c3f86bce768be0516758e31ff140328d89c4c83 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 4 Sep 2023 17:18:52 +0900 Subject: [PATCH 091/108] change default ownership arity --- src/argOptions.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/argOptions.ml b/src/argOptions.ml index b5083ac8..fa2914f5 100644 --- a/src/argOptions.ml +++ b/src/argOptions.ml @@ -98,7 +98,7 @@ let default = { file_list = []; output_channel = ref None; intrinsics = ref None; - ownership_arity = 1; + ownership_arity = 2; } let close_output ~opts = Option.iter close_out !(opts.output_channel); @@ -197,7 +197,7 @@ let parse anon_fun usage_msg = ("-files", Rest (fun s -> file_list := s::!file_list), " ...\t Interpret all remaining arguments as files to test"); ("-ownership-arity", Set_int ownership_arity, - "\t The number of different ownership variables used in recursive data structure (default: 1)"); + "\t The number of different ownership variables used in recursive data structure (default: 2)"); ] in Arg.parse spec anon_fun usage_msg; { From bb17ed3cd5ca04fd17179ff6e11b9bbd11ef9d56 Mon Sep 17 00:00:00 2001 From: Atsushi Igarashi Date: Wed, 13 Sep 2023 11:23:08 +0900 Subject: [PATCH 092/108] Change the syntax of Cons. before: Cons x y after: Cons(x,y) --- src/parser.mly | 4 ++-- src/test/list/easy/alias-cons2.imp | 6 +++--- src/test/list/easy/cons.imp | 4 ++-- src/test/list/easy/match-easy.imp | 6 +++--- src/test/list/easy/match.imp | 8 ++++---- src/test/list/hd.imp | 6 +++--- src/test/list/length.imp | 4 ++-- src/test/list/nth.imp | 4 ++-- src/test/list/tl.imp | 12 ++++++------ 9 files changed, 27 insertions(+), 27 deletions(-) diff --git a/src/parser.mly b/src/parser.mly index 41db0a75..7f31abe9 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -107,7 +107,7 @@ let expr := | RETURN; lbl = expr_label; e = lhs; { Return ((lbl,$startpos),e) } - | MATCH; lbl = expr_label; e1 = lhs; WITH; NIL; ARROW; e2 = expr; BAR; CONS; h = ID; r = ID; ARROW; e3 = expr; { + | MATCH; lbl = expr_label; e1 = lhs; WITH; NIL; ARROW; e2 = expr; BAR; CONS; LPAREN; h = ID; COMMA; r = ID; RPAREN; ARROW; e3 = expr; { Match ((lbl,$startpos),e1,e2,h,r,e3) } @@ -143,7 +143,7 @@ let op := | LPAREN; l = tuple_contents; RPAREN; <`Tuple> | ~ = array_expr; <`Read> | ~ = op; DOT; LENGTH; <`LengthOf> - | CONS; h = lhs; r = op; <`Cons> + | CONS; LPAREN; h = lhs; COMMA; r = op; RPAREN; <`Cons> | NIL; { `Nil } let tuple_rest := diff --git a/src/test/list/easy/alias-cons2.imp b/src/test/list/easy/alias-cons2.imp index a2eb3e6a..6356f753 100644 --- a/src/test/list/easy/alias-cons2.imp +++ b/src/test/list/easy/alias-cons2.imp @@ -1,9 +1,9 @@ insert_second(l, x) { match l with Nil -> () - | Cons h r -> { + | Cons (h, r) -> { let r2 = mkref *r in { - r := Cons x r2; + r := Cons (x, r2); alias(l.Cons.2 = r) } } @@ -11,7 +11,7 @@ insert_second(l, x) { { let n = mkref Nil in - let l = Cons 0 n in { + let l = Cons (0, n) in { insert_second(l, 1); insert_second(l, 2); } diff --git a/src/test/list/easy/cons.imp b/src/test/list/easy/cons.imp index 0b96548b..010ed7db 100644 --- a/src/test/list/easy/cons.imp +++ b/src/test/list/easy/cons.imp @@ -1,6 +1,6 @@ { let x = mkref Nil in - let y = mkref (Cons 1 x) in - let z = mkref (Cons 2 y) in + let y = mkref (Cons (1, x)) in + let z = mkref (Cons (2, y)) in () } \ No newline at end of file diff --git a/src/test/list/easy/match-easy.imp b/src/test/list/easy/match-easy.imp index 0aaaf3ea..a9996ed7 100644 --- a/src/test/list/easy/match-easy.imp +++ b/src/test/list/easy/match-easy.imp @@ -1,8 +1,8 @@ { let x = mkref Nil in - let y = mkref (Cons 1 x) in - let z = Cons 2 y in + let y = mkref (Cons (1, x)) in + let z = Cons (2, y) in match z with Nil -> () - | Cons h r -> () + | Cons (h, r) -> () } \ No newline at end of file diff --git a/src/test/list/easy/match.imp b/src/test/list/easy/match.imp index 3bbdb506..ee0f6590 100644 --- a/src/test/list/easy/match.imp +++ b/src/test/list/easy/match.imp @@ -1,7 +1,7 @@ sum(l, s) { match l with Nil -> s - | Cons h r -> { + | Cons (h, r) -> { let s2 = s + h in let r2 = *r in { alias(l.Cons.2 = r); @@ -12,9 +12,9 @@ sum(l, s) { { let x = mkref Nil in - let y = mkref (Cons 1 x) in - let z = mkref (Cons 2 y) in - let l = Cons 3 z in + let y = mkref (Cons (1, x)) in + let z = mkref (Cons (2, y)) in + let l = Cons (3, z) in let s = sum(l, 0) in assert(s = 6) } \ No newline at end of file diff --git a/src/test/list/hd.imp b/src/test/list/hd.imp index 08f77b09..1d7bcbcb 100644 --- a/src/test/list/hd.imp +++ b/src/test/list/hd.imp @@ -3,14 +3,14 @@ mklist(n) { let h = _ in let m = n + -1 in let t = mkref mklist(m) in - Cons h t + Cons (h, t) } } hd(l) { match l with Nil -> fail - | Cons h t -> return h + | Cons (h, t) -> return h } { @@ -18,5 +18,5 @@ hd(l) { let l = mklist(n) in match l with Nil -> fail - | Cons h t -> assert(hd(l) = h) + | Cons (h, t) -> assert(hd(l) = h) } \ No newline at end of file diff --git a/src/test/list/length.imp b/src/test/list/length.imp index 85b19d2c..99b6d25e 100644 --- a/src/test/list/length.imp +++ b/src/test/list/length.imp @@ -3,14 +3,14 @@ mklist(n) { let h = _ in let m = n + -1 in let t = mkref mklist(m) in - Cons h t + Cons (h, t) } } len(l) { match l with Nil -> return 0 - | Cons h t -> { + | Cons (h, t) -> { let t_deref = *t in let n = 1 + len(t_deref) in { alias(t_deref = *t); diff --git a/src/test/list/nth.imp b/src/test/list/nth.imp index 6ba96e1e..7ec91257 100644 --- a/src/test/list/nth.imp +++ b/src/test/list/nth.imp @@ -3,14 +3,14 @@ mklist(n) { let h = _ in let m = n + -1 in let t = mkref mklist(m) in - Cons h t + Cons (h, t) } } nth(l, n) { match l with Nil -> fail - | Cons h t -> { + | Cons (h, t) -> { let m = n + -1 in if n = 1 then h else nth(*t, m) } diff --git a/src/test/list/tl.imp b/src/test/list/tl.imp index 31c5060c..95ec8998 100644 --- a/src/test/list/tl.imp +++ b/src/test/list/tl.imp @@ -3,7 +3,7 @@ mklist(n) { let h = _ in let m = n + -1 in let t = mkref mklist(m) in - Cons h t + Cons (h, t) } } @@ -12,12 +12,12 @@ assert_eq(l1, l2) { Nil -> { match l2 with Nil -> () - | Cons h2 t2 -> fail + | Cons (h2, t2) -> fail } - | Cons h1 t1 -> { + | Cons (h1, t1) -> { match l2 with Nil -> fail - | Cons h2 t2 -> { + | Cons (h2, t2) -> { assert(h1 = h2); let t1_deref = *t1 in let t2_deref = *t2 in { @@ -34,7 +34,7 @@ assert_eq(l1, l2) { tl(l) { match l with Nil -> fail - | Cons h t -> return *t + | Cons (h, t) -> return *t } { @@ -42,5 +42,5 @@ tl(l) { let l = mklist(n) in match l with Nil -> fail - | Cons h t -> assert_eq(tl(l), *t) + | Cons (h, t) -> assert_eq(tl(l), *t) } \ No newline at end of file From c10c4afffb09601ed37b6f4cf1f6819aa83c26b4 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 25 Sep 2023 14:22:26 +0900 Subject: [PATCH 093/108] add a test --- src/test/list/reverse.imp | 68 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 68 insertions(+) create mode 100644 src/test/list/reverse.imp diff --git a/src/test/list/reverse.imp b/src/test/list/reverse.imp new file mode 100644 index 00000000..205ccb31 --- /dev/null +++ b/src/test/list/reverse.imp @@ -0,0 +1,68 @@ +mklist(n) { + if n = 0 then Nil else { + let h = _ in + let m = n + -1 in + let t = mkref mklist(m) in + Cons (h, t) + } +} + +assert_eq(l1, l2) { + match l1 with + Nil -> { + match l2 with + Nil -> () + | Cons (h2, t2) -> fail + } + | Cons (h1, t1) -> { + match l2 with + Nil -> fail + | Cons (h2, t2) -> { + assert(h1 = h2); + let t1_deref = *t1 in + let t2_deref = *t2 in { + assert_eq(t1_deref, t2_deref); + alias(t1_deref = *t1); + alias(l1.Cons.2 = t1); + alias(t2_deref = *t2); + alias(l2.Cons.2 = t2) + } + } + } +} + +_reverse(l, l_next) { + match l_next with + Nil -> () + | Cons(h, t) -> { + let t_deref = *t in { + t := l; + _reverse(l_next, t_deref); + alias(t_deref = *t); + alias(l_next.Cons.2 = t) + } + } +} + +reverse(l) { + match l with + Nil -> l + | Cons(h, t) -> { + let t_deref = *t in { + t := Nil; + _reverse(l, t_deref); + alias(t_deref = *t); + alias(l.Cons.2 = t); + return l + } + } +} + +{ + let n = ( _ : ~ >= 0) in + let l = mklist(n) in + let rev_rev_l = reverse(reverse(l)) in { + alias(l = rev_rev_l); + assert_eq(l, rev_rev_l) + } +} \ No newline at end of file From 5115e0de9d9734d5ab0dd719296ed7cfecf7f63c Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 25 Sep 2023 16:22:39 +0900 Subject: [PATCH 094/108] fix a test --- src/test/list/reverse.imp | 23 +++++++++-------------- 1 file changed, 9 insertions(+), 14 deletions(-) diff --git a/src/test/list/reverse.imp b/src/test/list/reverse.imp index 205ccb31..7821212e 100644 --- a/src/test/list/reverse.imp +++ b/src/test/list/reverse.imp @@ -33,29 +33,24 @@ assert_eq(l1, l2) { _reverse(l, l_next) { match l_next with - Nil -> () + Nil -> { + alias(*(l.Cons.2) = l_next); + return l + } | Cons(h, t) -> { let t_deref = *t in { t := l; - _reverse(l_next, t_deref); alias(t_deref = *t); - alias(l_next.Cons.2 = t) + alias(l_next.Cons.2 = t); + let reversed = _reverse(l_next, t_deref) in + reversed } } } reverse(l) { - match l with - Nil -> l - | Cons(h, t) -> { - let t_deref = *t in { - t := Nil; - _reverse(l, t_deref); - alias(t_deref = *t); - alias(l.Cons.2 = t); - return l - } - } + let reversed = _reverse(Nil, l) in + reversed } { From 6d1ddafa788f84fccb897b120c68528854695d85 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 25 Sep 2023 16:41:27 +0900 Subject: [PATCH 095/108] fix a test --- src/test/list/reverse.imp | 1 - 1 file changed, 1 deletion(-) diff --git a/src/test/list/reverse.imp b/src/test/list/reverse.imp index 7821212e..48b828fd 100644 --- a/src/test/list/reverse.imp +++ b/src/test/list/reverse.imp @@ -40,7 +40,6 @@ _reverse(l, l_next) { | Cons(h, t) -> { let t_deref = *t in { t := l; - alias(t_deref = *t); alias(l_next.Cons.2 = t); let reversed = _reverse(l_next, t_deref) in reversed From d690b0bc862afebedc133d61bcdf998d84ec5e09 Mon Sep 17 00:00:00 2001 From: artoy Date: Sat, 30 Sep 2023 11:58:13 +0900 Subject: [PATCH 096/108] add and fix tests --- src/test/list/append.imp | 62 ++++++++++++++++++++++++++++++++++++++ src/test/list/reverse.imp | 8 +++-- src/test/list/reverse2.imp | 55 +++++++++++++++++++++++++++++++++ 3 files changed, 123 insertions(+), 2 deletions(-) create mode 100644 src/test/list/append.imp create mode 100644 src/test/list/reverse2.imp diff --git a/src/test/list/append.imp b/src/test/list/append.imp new file mode 100644 index 00000000..d300317c --- /dev/null +++ b/src/test/list/append.imp @@ -0,0 +1,62 @@ +mklist(n) { + if n = 0 then Nil else { + let h = _ in + let m = n + -1 in + let t = mkref mklist(m) in + Cons (h, t) + } +} + +len(l) { + match l with + Nil -> return 0 + | Cons (h, t) -> { + let t_deref = *t in + let n = 1 + len(t_deref) in { + alias(t_deref = *t); + alias(l.Cons.2 = t); + return n + } + } +} + +_append(l, r) { + match l with + Nil -> () + | Cons(h1, t1) -> { + let t1_deref = *t1 in + match t1_deref with + Nil -> { + t1 := r; + alias(t1_deref = *t1); + alias(l.Cons.2 = t1) + } + | Cons(h2, t2) -> { + _append(t1_deref, r); + alias(t1_deref = *t1); + alias(l.Cons.2 = t1) + } + + } +} + +append(l, r){ + match l with + Nil -> return r + | Cons(h, t) -> { + _append(l, r); + return l + } +} + +{ + let m = ( _ : ~ >= 0) in + let n = ( _ : ~ >= 0) in + let l1 = mklist(m) in + let l2 = mklist(n) in + let l = append(l1, l2) in + let sum_length = len(l1) + len(l2) in { + alias(l = l1); + assert(len(l) = sum_length) + } +} \ No newline at end of file diff --git a/src/test/list/reverse.imp b/src/test/list/reverse.imp index 48b828fd..017b1938 100644 --- a/src/test/list/reverse.imp +++ b/src/test/list/reverse.imp @@ -48,8 +48,12 @@ _reverse(l, l_next) { } reverse(l) { - let reversed = _reverse(Nil, l) in - reversed + match l with + Nil -> l + | Cons(h, t) -> { + let reversed = _reverse(Nil, l) in + reversed + } } { diff --git a/src/test/list/reverse2.imp b/src/test/list/reverse2.imp new file mode 100644 index 00000000..e48c4bb3 --- /dev/null +++ b/src/test/list/reverse2.imp @@ -0,0 +1,55 @@ +mklist(n) { + if n = 0 then Nil else { + let h = _ in + let m = n + -1 in + let t = mkref mklist(m) in + Cons (h, t) + } +} + +_reverse(l, l_next) { + match l_next with + Nil -> { + alias(*(l.Cons.2) = l_next); + return l + } + | Cons(h, t) -> { + let t_deref = *t in { + t := l; + alias(l_next.Cons.2 = t); + let reversed = _reverse(l_next, t_deref) in + reversed + } + } +} + +reverse(l) { + match l with + Nil -> l + | Cons(h, r) -> { + let reversed = _reverse(Nil, l) in + reversed + } +} + +len(l) { + match l with + Nil -> return 0 + | Cons (h, t) -> { + let t_deref = *t in + let n = 1 + len(t_deref) in { + alias(t_deref = *t); + alias(l.Cons.2 = t); + return n + } + } +} + +{ + let n = ( _ : ~ >= 0) in + let l = mklist(n) in + let rev_l = reverse(l) in { + alias(l = rev_l); + assert(len(l) = len(rev_l)) + } +} \ No newline at end of file From 89d7a7ee757faccd8d4c9c3c7c7baa0a8ef9d2bb Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Tue, 10 Oct 2023 14:49:27 +0900 Subject: [PATCH 097/108] add tests --- src/test/list/append.imp | 8 ++++---- src/test/list/mochi/append.ml | 36 +++++++++++++++++++++++++++++++++ src/test/list/mochi/reverse2.ml | 34 +++++++++++++++++++++++++++++++ src/test/list/reverse2.imp | 7 +++---- 4 files changed, 77 insertions(+), 8 deletions(-) create mode 100644 src/test/list/mochi/append.ml create mode 100644 src/test/list/mochi/reverse2.ml diff --git a/src/test/list/append.imp b/src/test/list/append.imp index d300317c..e56145ac 100644 --- a/src/test/list/append.imp +++ b/src/test/list/append.imp @@ -54,9 +54,9 @@ append(l, r){ let n = ( _ : ~ >= 0) in let l1 = mklist(m) in let l2 = mklist(n) in - let l = append(l1, l2) in - let sum_length = len(l1) + len(l2) in { - alias(l = l1); - assert(len(l) = sum_length) + let sum_length = len(l1) + len(l2) in + let l = append(l1, l2) in { + alias(l = l1); + assert(len(l) = sum_length) } } \ No newline at end of file diff --git a/src/test/list/mochi/append.ml b/src/test/list/mochi/append.ml new file mode 100644 index 00000000..15c9e79d --- /dev/null +++ b/src/test/list/mochi/append.ml @@ -0,0 +1,36 @@ +let rec mklist n = + if n > 0 then + let h = Random.int 0 in + let t = mklist (n - 1) in + h :: t + else [] + +and len (l: int list) = + match l with + [] -> 0 + | _ :: t -> 1 + len t + +and append (l1: int list) (l2: int list) = + match l1 with + [] -> l2 + | h :: t -> h :: (append t l2) + +let main () = + let m = + let rec nd' () = + let _' = Random.int 0 in + if _' >= 0 then _' else nd' () + in nd' () + in + let n = + let rec nd' () = + let _' = Random.int 0 in + if _' >= 0 then _' else nd' () + in nd' () + in + let l1 = mklist m in + let l2 = mklist n in + let sum_length = len l1 + len l2 in + let l = append l1 l2 in + assert (len(l) = sum_length); + (()) diff --git a/src/test/list/mochi/reverse2.ml b/src/test/list/mochi/reverse2.ml new file mode 100644 index 00000000..d900d991 --- /dev/null +++ b/src/test/list/mochi/reverse2.ml @@ -0,0 +1,34 @@ +let rec mklist n = + if n > 0 then + let h = Random.int 0 in + let t = mklist (n - 1) in + h :: t + else [] + +and _reverse (l: int list) (acc: int list) = + match l with + [] -> acc + | h :: t -> _reverse t (h :: acc) + +and reverse (l: int list) = + _reverse l [] + +and len (l: int list) = + match l with + [] -> 0 + | _ :: t -> 1 + len t + +let main () = + let n = + let rec nd' () = + let _' = Random.int 0 in + if _' >= 0 then _' else nd' () + in nd' () + in + let l = mklist n in + let __t0 = len l in + let rev_l = reverse l in + let __t1 = len rev_l in + assert (__t0 = __t1); + let __t2 = 0 in + (()) diff --git a/src/test/list/reverse2.imp b/src/test/list/reverse2.imp index e48c4bb3..09d99c3b 100644 --- a/src/test/list/reverse2.imp +++ b/src/test/list/reverse2.imp @@ -48,8 +48,7 @@ len(l) { { let n = ( _ : ~ >= 0) in let l = mklist(n) in - let rev_l = reverse(l) in { - alias(l = rev_l); - assert(len(l) = len(rev_l)) - } + let len_l = len(l) in + let rev_l = reverse(l) in + assert(len_l = len(rev_l)) } \ No newline at end of file From 26acaa987356b9cff1ff826649c2e3d02fd3035f Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Sun, 5 Nov 2023 00:43:50 +0900 Subject: [PATCH 098/108] add callMoCHi --- src/callMoCHi.ml | 0 src/consort.ml | 30 +++++++++++++++--------------- 2 files changed, 15 insertions(+), 15 deletions(-) create mode 100644 src/callMoCHi.ml diff --git a/src/callMoCHi.ml b/src/callMoCHi.ml new file mode 100644 index 00000000..e69de29b diff --git a/src/consort.ml b/src/consort.ml index 0bd5995b..28c8b5ca 100644 --- a/src/consort.ml +++ b/src/consort.ml @@ -229,18 +229,18 @@ let typecheck ~opts file = print_typecheck simple_res ast; Verified - let convmochi ~opts file = - let ast = AstUtil.parse_file file in - (* print_endline @@ Sexplib.Sexp.to_string @@ Ast.sexp_of_prog ast; *) - let intr_op = (ArgOptions.get_intr opts).op_interp in - let simple_op = RefinementTypes.to_simple_funenv intr_op in - let simple_res = SimpleChecker.typecheck_prog simple_op ast in - let infer_res = OwnershipInference.infer ~opts simple_res ast in - let ownership_res = OwnershipSolver.solve_ownership ~opts infer_res in - let prog = - ConvMoCHi.prog_to_mochi infer_res - ((function Some x -> x | None -> assert false) ownership_res) - ast - in - ConvMoCHi.Mochi.print_prog prog; - match ownership_res with None -> Unverified Aliasing | Some _ -> Verified +let convmochi ~opts file = + let ast = AstUtil.parse_file file in + (* print_endline @@ Sexplib.Sexp.to_string @@ Ast.sexp_of_prog ast; *) + let intr_op = (ArgOptions.get_intr opts).op_interp in + let simple_op = RefinementTypes.to_simple_funenv intr_op in + let simple_res = SimpleChecker.typecheck_prog simple_op ast in + let infer_res = OwnershipInference.infer ~opts simple_res ast in + let ownership_res = OwnershipSolver.solve_ownership ~opts infer_res in + let prog = + ConvMoCHi.prog_to_mochi infer_res + ((function Some x -> x | None -> assert false) ownership_res) + ast + in + ConvMoCHi.Mochi.print_prog prog; + match ownership_res with None -> Unverified Aliasing | Some _ -> Verified From ee5a3c47efab3b1a64e273f49b4d691a5f4c2ebc Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 6 Nov 2023 14:00:46 +0900 Subject: [PATCH 099/108] add call mochi --- src/callMoCHi.ml | 4 ++++ src/dune | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/callMoCHi.ml b/src/callMoCHi.ml index e69de29b..e465e4fd 100644 --- a/src/callMoCHi.ml +++ b/src/callMoCHi.ml @@ -0,0 +1,4 @@ +let call_mochi = + let cmd = "~/git/MoCHi/src.mochi.exe ./test/to_mochi.ml" in + let proc = Process.spawn cmd in + \ No newline at end of file diff --git a/src/dune b/src/dune index bb8c9fa4..32fa851f 100644 --- a/src/dune +++ b/src/dune @@ -44,7 +44,7 @@ Z3BasedBackend Consort HoiceBackend NullSolver ExternalFileBackend EldaricaBackend ParallelBackend - ConvMoCHi)) + ConvMoCHi CallMoCHi)) (executable (name test) From b6a043c3ed2eec9fb36e22426b856d689d96a939 Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Mon, 6 Nov 2023 18:01:35 +0900 Subject: [PATCH 100/108] run mochi automatically (may error occurs) --- .gitignore | 1 + src/callMoCHi.ml | 8 +++++--- src/consort.ml | 8 +++++++- src/convMoCHi.ml | 4 ++++ 4 files changed, 17 insertions(+), 4 deletions(-) diff --git a/.gitignore b/.gitignore index 05c41159..4a1cca45 100644 --- a/.gitignore +++ b/.gitignore @@ -27,3 +27,4 @@ paper/related_work.tex paper/semantics.tex paper/typesystem.tex paper/wf_rules.tex +src/test/to_mochi.ml diff --git a/src/callMoCHi.ml b/src/callMoCHi.ml index e465e4fd..57a9a00e 100644 --- a/src/callMoCHi.ml +++ b/src/callMoCHi.ml @@ -1,4 +1,6 @@ let call_mochi = - let cmd = "~/git/MoCHi/src.mochi.exe ./test/to_mochi.ml" in - let proc = Process.spawn cmd in - \ No newline at end of file + let cmd = "~/git/MoCHi/src/mochi.exe ./test/to_mochi.ml" in + let p = Process.spawn cmd in + let res = (String.trim @@ input_line p.Process.proc_stdout, String.trim @@ input_line p.Process.proc_stderr) in + Process.dispose p; + res \ No newline at end of file diff --git a/src/consort.ml b/src/consort.ml index 28c8b5ca..f7152143 100644 --- a/src/consort.ml +++ b/src/consort.ml @@ -242,5 +242,11 @@ let convmochi ~opts file = ((function Some x -> x | None -> assert false) ownership_res) ast in - ConvMoCHi.Mochi.print_prog prog; + (* ConvMoCHi.Mochi.print_prog prog; *) + let file = open_out "./test/to_mochi.ml" in + ConvMoCHi.Mochi.write_to_channel_prog prog file; + Out_channel.close file; + let (res_out, res_err) = CallMoCHi.call_mochi in + print_endline res_out; + print_endline res_err; match ownership_res with None -> Unverified Aliasing | Some _ -> Verified diff --git a/src/convMoCHi.ml b/src/convMoCHi.ml index e970d8f0..cef56f90 100644 --- a/src/convMoCHi.ml +++ b/src/convMoCHi.ml @@ -265,6 +265,10 @@ module Mochi = struct let print_prog prog = print_endline builtin; pp_prog prog std_formatter + + let write_to_channel_prog prog file = + Printf.fprintf file "%s\n" builtin; + pp_prog prog (Format.formatter_of_out_channel file); end let pull_type ty con i = From 70d776e689c4b04daafa208202d799ec5afce4bc Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Tue, 7 Nov 2023 14:51:43 +0900 Subject: [PATCH 101/108] comment out --- src/consort.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/consort.ml b/src/consort.ml index f7152143..6b13ee30 100644 --- a/src/consort.ml +++ b/src/consort.ml @@ -246,7 +246,7 @@ let convmochi ~opts file = let file = open_out "./test/to_mochi.ml" in ConvMoCHi.Mochi.write_to_channel_prog prog file; Out_channel.close file; - let (res_out, res_err) = CallMoCHi.call_mochi in + (* let (res_out, res_err) = CallMoCHi.call_mochi in print_endline res_out; - print_endline res_err; + print_endline res_err; *) match ownership_res with None -> Unverified Aliasing | Some _ -> Verified From b0b5055354069d2fb3ec952c7382d55a12516aaa Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Thu, 30 Nov 2023 17:50:41 +0900 Subject: [PATCH 102/108] add test files --- src/test/list/reverse2-debug.imp | 32 ++++++++++++++++++++++++++++++++ src/test/list/reverse2.imp | 2 +- 2 files changed, 33 insertions(+), 1 deletion(-) create mode 100644 src/test/list/reverse2-debug.imp diff --git a/src/test/list/reverse2-debug.imp b/src/test/list/reverse2-debug.imp new file mode 100644 index 00000000..99ca23f0 --- /dev/null +++ b/src/test/list/reverse2-debug.imp @@ -0,0 +1,32 @@ +_reverse(l, l_next) { + match l_next with + Nil -> { + // alias(*(l.Cons.2) = l_next); + return l + } + | Cons(h, t) -> { + let t_deref = *t in { + t := l; + alias(l_next.Cons.2 = t); + let reversed = _reverse(l_next, t_deref) in + reversed + } + } +} + +reverse(l) { + match l with + Nil -> l + | Cons(h, r) -> { + let reversed = _reverse(Nil, l) in + reversed + } +} + +{ + let n = mkref Nil in + let m = mkref Cons(1, n) in + let l = Cons(2, m) in + let rev_l = reverse(l) in + () +} \ No newline at end of file diff --git a/src/test/list/reverse2.imp b/src/test/list/reverse2.imp index 09d99c3b..d15e56db 100644 --- a/src/test/list/reverse2.imp +++ b/src/test/list/reverse2.imp @@ -10,7 +10,7 @@ mklist(n) { _reverse(l, l_next) { match l_next with Nil -> { - alias(*(l.Cons.2) = l_next); + // alias(*(l.Cons.2) = l_next); return l } | Cons(h, t) -> { From 6eabb96abc40bfd162d35e1cd2e09e5593402c2f Mon Sep 17 00:00:00 2001 From: Ryota Kobayashi Date: Tue, 19 Mar 2024 11:18:03 +0900 Subject: [PATCH 103/108] update gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 05c41159..4a1cca45 100644 --- a/.gitignore +++ b/.gitignore @@ -27,3 +27,4 @@ paper/related_work.tex paper/semantics.tex paper/typesystem.tex paper/wf_rules.tex +src/test/to_mochi.ml From 3d5a9b816f75998b8f3cc1af8684567e13251223 Mon Sep 17 00:00:00 2001 From: artoy Date: Wed, 20 Mar 2024 12:00:52 +0900 Subject: [PATCH 104/108] wip --- src/ownershipInference.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 41e5c72d..b02a8fac 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -794,7 +794,9 @@ let rec process_expr ~output ((e_id,_),expr) ~o_arity = split_loop r (o1 :: ol1) (o2 :: ol2) in let%bind (ol1, ol2) = split_loop ol [] [] in - return (IntList ol1, Ref(IntList((List.tl ol2) @ [(List.hd @@ List.rev ol2)]), List.hd ol2)) + let%bind o_copied = alloc_ovar (SBind e_id) (P.var v) in + constrain_eq ~src:o_copied ~dst:List.hd @@ List.rev ol2 >> + return (IntList ol1, Ref(IntList((List.tl ol2) @ [o_copied]), List.hd ol2)) | _ -> failwith "The value pattern matched must be IntList" in process_pattern_matching ~e_id ~output v type_of_v e2 h r type_of_r e3 ~o_arity From bcdd83e045d47ab2f05770717ab2392aae5ce4e1 Mon Sep 17 00:00:00 2001 From: artoy Date: Thu, 21 Mar 2024 00:40:16 +0900 Subject: [PATCH 105/108] wip --- src/ownershipInference.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index b02a8fac..97297727 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -794,8 +794,8 @@ let rec process_expr ~output ((e_id,_),expr) ~o_arity = split_loop r (o1 :: ol1) (o2 :: ol2) in let%bind (ol1, ol2) = split_loop ol [] [] in - let%bind o_copied = alloc_ovar (SBind e_id) (P.var v) in - constrain_eq ~src:o_copied ~dst:List.hd @@ List.rev ol2 >> + let%bind o_copied = alloc_ovar (MGen e_id) (P.var v) in + add_constraint (Eq (o_copied, List.hd @@ List.rev ol1)) >> return (IntList ol1, Ref(IntList((List.tl ol2) @ [o_copied]), List.hd ol2)) | _ -> failwith "The value pattern matched must be IntList" in From c44a49aa7aabe74355a985421982aa1c8e75c82c Mon Sep 17 00:00:00 2001 From: artoy Date: Thu, 21 Mar 2024 14:56:59 +0900 Subject: [PATCH 106/108] fix calculation of ownership --- src/ownershipInference.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ownershipInference.ml b/src/ownershipInference.ml index 97297727..16f5efea 100644 --- a/src/ownershipInference.ml +++ b/src/ownershipInference.ml @@ -795,7 +795,7 @@ let rec process_expr ~output ((e_id,_),expr) ~o_arity = in let%bind (ol1, ol2) = split_loop ol [] [] in let%bind o_copied = alloc_ovar (MGen e_id) (P.var v) in - add_constraint (Eq (o_copied, List.hd @@ List.rev ol1)) >> + add_constraint (Eq (o_copied, List.hd @@ List.rev ol2)) >> return (IntList ol1, Ref(IntList((List.tl ol2) @ [o_copied]), List.hd ol2)) | _ -> failwith "The value pattern matched must be IntList" in From 130d1ec1eb80cf6ad45b92a05866a08fa07b5cb7 Mon Sep 17 00:00:00 2001 From: artoy Date: Thu, 21 Mar 2024 15:51:59 +0900 Subject: [PATCH 107/108] call mochi --- src/callMoCHi.ml | 6 ------ src/consort.ml | 3 --- src/dune | 2 +- 3 files changed, 1 insertion(+), 10 deletions(-) delete mode 100644 src/callMoCHi.ml diff --git a/src/callMoCHi.ml b/src/callMoCHi.ml deleted file mode 100644 index 57a9a00e..00000000 --- a/src/callMoCHi.ml +++ /dev/null @@ -1,6 +0,0 @@ -let call_mochi = - let cmd = "~/git/MoCHi/src/mochi.exe ./test/to_mochi.ml" in - let p = Process.spawn cmd in - let res = (String.trim @@ input_line p.Process.proc_stdout, String.trim @@ input_line p.Process.proc_stderr) in - Process.dispose p; - res \ No newline at end of file diff --git a/src/consort.ml b/src/consort.ml index 6b13ee30..7d06a88d 100644 --- a/src/consort.ml +++ b/src/consort.ml @@ -246,7 +246,4 @@ let convmochi ~opts file = let file = open_out "./test/to_mochi.ml" in ConvMoCHi.Mochi.write_to_channel_prog prog file; Out_channel.close file; - (* let (res_out, res_err) = CallMoCHi.call_mochi in - print_endline res_out; - print_endline res_err; *) match ownership_res with None -> Unverified Aliasing | Some _ -> Verified diff --git a/src/dune b/src/dune index 32fa851f..bb8c9fa4 100644 --- a/src/dune +++ b/src/dune @@ -44,7 +44,7 @@ Z3BasedBackend Consort HoiceBackend NullSolver ExternalFileBackend EldaricaBackend ParallelBackend - ConvMoCHi CallMoCHi)) + ConvMoCHi)) (executable (name test) From 088f7eee97bccb7bb9269dee0e5c19612037f3cf Mon Sep 17 00:00:00 2001 From: artoy Date: Thu, 21 Mar 2024 16:43:08 +0900 Subject: [PATCH 108/108] add comment --- src/test/list/reverse2.imp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/test/list/reverse2.imp b/src/test/list/reverse2.imp index d15e56db..adb79657 100644 --- a/src/test/list/reverse2.imp +++ b/src/test/list/reverse2.imp @@ -10,6 +10,7 @@ mklist(n) { _reverse(l, l_next) { match l_next with Nil -> { + // FIXME: this alias statement is (maybe) wrong // alias(*(l.Cons.2) = l_next); return l } @@ -51,4 +52,4 @@ len(l) { let len_l = len(l) in let rev_l = reverse(l) in assert(len_l = len(rev_l)) -} \ No newline at end of file +}