├── _config.yml ├── dune-project ├── src ├── horn_solver │ ├── dune │ ├── smtParse.mly │ ├── smtLex.mll │ ├── parseBase.ml │ └── solver.ml ├── loader │ ├── dune │ ├── readFml.ml │ ├── readQual.ml │ ├── genQual.ml │ ├── qualparser.mly │ ├── loader.ml │ ├── fmlparser.mly │ ├── runner.ml │ ├── quallexer.mll │ ├── fmllexer.mll │ ├── optimizeVc.ml │ └── verificationCondition.ml ├── concern │ ├── showsexp.ml │ ├── diggable.ml │ ├── mappable.ml │ ├── assocable.ml │ ├── decomposable.ml │ ├── quantifiable.ml │ ├── util.ml │ ├── logical.ml.unused │ └── formatable.ml ├── data │ ├── identity.ml │ ├── label.ml │ ├── hashRow.ml │ ├── unknownPredicate.ml │ ├── variableArray.ml │ ├── objt.ml │ ├── op.ml │ ├── simpleType.ml │ ├── bitVector.ml │ ├── effectInfer.ml │ ├── vcControl.ml │ ├── program.ml │ └── type.ml ├── mlLoader │ ├── elimAssert.ml │ ├── convMain.ml │ ├── simplify.ml │ ├── letNormal.ml │ ├── betaReduction.ml │ ├── bindValueReduction.ml │ ├── kNormal.ml │ ├── alphaConv.ml │ ├── desugar.ml │ ├── mlLoader.ml │ ├── closureConv.ml │ └── sugarProgram.ml ├── dune ├── common │ ├── lib.ml │ └── conf.ml └── r_type.ml ├── .gitignore ├── .github └── workflows │ ├── setup.sh │ └── ci.yml ├── README.md └── LICENSE /_config.yml: -------------------------------------------------------------------------------- 1 | theme: jekyll-theme-midnight -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.8) 2 | (using menhir 2.1) 3 | -------------------------------------------------------------------------------- /src/horn_solver/dune: -------------------------------------------------------------------------------- 1 | (ocamllex (modules smtLex)) 2 | (menhir (modules smtParse)) 3 | -------------------------------------------------------------------------------- /src/loader/dune: -------------------------------------------------------------------------------- 1 | (ocamllex (modules fmllexer quallexer)) 2 | (menhir (modules fmlparser qualparser)) 3 | -------------------------------------------------------------------------------- /src/concern/showsexp.ml: -------------------------------------------------------------------------------- 1 | 2 | module type S = sig 3 | type t 4 | 5 | val sexp_of_t : t -> Sexplib.Sexp.t 6 | end 7 | 8 | module Make (M : S) = struct 9 | let show_sexp (v : M.t) = M.sexp_of_t v |> Sexplib.Sexp.to_string 10 | end 11 | -------------------------------------------------------------------------------- /src/concern/diggable.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | module type S = sig 4 | type t 5 | val dig : t -> (t -> t) -> t 6 | end 7 | 8 | module Make = functor(M : S) -> struct 9 | let dig = M.dig 10 | let rec recdig e f = f (M.dig e (fun e -> recdig e f)) 11 | end 12 | -------------------------------------------------------------------------------- /src/concern/mappable.ml: -------------------------------------------------------------------------------- 1 | 2 | open Core 3 | 4 | module type S = sig 5 | type t [@@deriving eq, ord, sexp, hash] 6 | end 7 | 8 | module Make = functor(M : S) -> struct 9 | include M 10 | include Comparable.Make(M) 11 | include Hashable.Make(M) 12 | end 13 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | *.omc 11 | .omakedb* 12 | *.html 13 | 14 | # Backup files 15 | *~ 16 | \#* 17 | 18 | # dune working directory 19 | _build/ 20 | 21 | # build targets 22 | src/r_type.exe 23 | -------------------------------------------------------------------------------- /src/data/identity.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | include Mappable.Make ( 4 | struct 5 | include String 6 | let show = ident [@@ocaml.warning "-32"] 7 | end 8 | ) 9 | 10 | module Short = struct 11 | type nonrec t = t 12 | let show vid = 13 | Label.shorten vid |> Result.ok |> Option.value ~default:vid 14 | end 15 | -------------------------------------------------------------------------------- /src/mlLoader/elimAssert.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open SugarProgram 3 | 4 | 5 | let main (sprogram : t) : t = 6 | let mapper = { Mapper.default_mapper with 7 | Mapper.assert_ = ( 8 | fun self e1 -> IfExp (self.Mapper.exp self e1, mk_true, FailExp) 9 | ) 10 | } in 11 | expr_map sprogram ~f:(Mapper.apply_expr mapper) 12 | -------------------------------------------------------------------------------- /src/concern/assocable.ml: -------------------------------------------------------------------------------- 1 | 2 | open Core 3 | 4 | module type S = sig 5 | type t 6 | type key_t 7 | type value_t 8 | val mapping : t -> (key_t * value_t) list 9 | end 10 | 11 | module Make = functor(M : S) -> struct 12 | let assoc obj key = 13 | List.Assoc.find (M.mapping obj) key 14 | 15 | let assoc_exn obj key = 16 | List.Assoc.find_exn (M.mapping obj) key 17 | end 18 | -------------------------------------------------------------------------------- /src/mlLoader/convMain.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open SugarProgram 3 | open! Util 4 | 5 | module L = Label.Make (struct 6 | let label = "convMain" 7 | end) 8 | 9 | let main (sprogram : t) : t = 10 | List.map sprogram ~f:(fun el -> 11 | match el with 12 | | BindValue (v, e) when Poly.(v = "main") -> BindFunc (Func.make ~name:"main" ~args:[L.gen ()] ~exp:e ()) 13 | | _ -> el 14 | ) 15 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name r_type) 3 | (libraries core re2 ppx_deriving ppx_deriving.create ppx_deriving.eq ppx_deriving.ord ppx_deriving.show ppx_sexp_conv ppx_hash ppx_variants_conv ppx_fields_conv ppx_compare compiler-libs.common unionFind) 4 | (flags (:standard -warn-error A -thread)) 5 | (ocamlopt_flags (:standard -inline 100)) 6 | (preprocess (pps ppx_deriving.create ppx_deriving.eq ppx_deriving.ord ppx_deriving.show ppx_sexp_conv ppx_hash ppx_variants_conv ppx_fields_conv ppx_compare)) 7 | (promote)) 8 | 9 | (include_subdirs unqualified) 10 | -------------------------------------------------------------------------------- /src/mlLoader/simplify.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open SugarProgram 3 | 4 | let simplify_arith_exp (p : t) : t = 5 | let mapper = { Mapper.default_mapper with 6 | Mapper.op2 = (fun self (e1, op, e2) -> 7 | match self.Mapper.exp self e1, op, self.Mapper.exp self e2 with 8 | | ObjExp (Objt.IntObj 0), Op.Plus, e2' -> e2' 9 | | ObjExp (Objt.IntObj 0), Op.Times, _e2' -> mk_int 0 10 | | ObjExp (Objt.IntObj 1), Op.Times, e2' -> e2' 11 | | e1', _, e2' -> OpExp(e1', op, e2')) 12 | } in 13 | SugarProgram.expr_map p ~f:(Mapper.apply_expr mapper) 14 | 15 | 16 | let main p = 17 | simplify_arith_exp p 18 | -------------------------------------------------------------------------------- /.github/workflows/setup.sh: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | 3 | opam --version 4 | ocamlc --version 5 | 6 | eval $(opam config env) 7 | opam update 8 | eval $(opam env) 9 | 10 | echo "installing dependencies" 11 | opam install -y \ 12 | dune.2.8.1 \ 13 | menhir.20201216 \ 14 | core.v0.14.0 \ 15 | ppx_compare.v0.14.0 \ 16 | ppx_deriving.5.1 \ 17 | ppx_fields_conv.v0.14.1 \ 18 | ppx_hash.v0.14.0 \ 19 | ppx_sexp_conv.v0.14.1 \ 20 | ppx_variants_conv.v0.14.1 \ 21 | re2.v0.14.0 \ 22 | unionFind.20200320 23 | echo "done installing dependencies" 24 | eval $(opam env) 25 | 26 | opam --version 27 | ocamlc --version 28 | dune --version 29 | -------------------------------------------------------------------------------- /src/concern/decomposable.ml: -------------------------------------------------------------------------------- 1 | 2 | open Core 3 | 4 | module type S = sig 5 | type t 6 | type 'a decompose_t 7 | 8 | val decompose : t -> (t -> 'a) -> 'a decompose_t 9 | val reassemble : t decompose_t -> t 10 | end 11 | 12 | module type T = sig 13 | type t 14 | type 'a decompose_t 15 | val decompose : t -> (t -> 'a) -> 'a decompose_t 16 | val reassemble : t decompose_t -> t 17 | val dmap : t -> ('a decompose_t -> 'a) -> 'a 18 | end 19 | 20 | module Make (M : S) : (T with type 'a decompose_t = 'a M.decompose_t and type t := M.t) = struct 21 | include M 22 | let decompose = M.decompose 23 | let reassemble = M.reassemble 24 | let rec dmap e f = f (decompose e (fun e' -> dmap e' f)) 25 | end 26 | -------------------------------------------------------------------------------- /src/concern/quantifiable.ml: -------------------------------------------------------------------------------- 1 | 2 | open Core 3 | module type S = sig 4 | type t 5 | 6 | val mk_or : t -> t -> t 7 | val mk_and : t -> t -> t 8 | val mk_false : t 9 | val mk_true : t 10 | end 11 | 12 | 13 | module Make (M : S) = struct 14 | let forall group func = 15 | match group with 16 | | [] -> M.mk_true 17 | | hd :: tails -> 18 | List.fold_left 19 | ~f:(fun left_exp group_el -> M.mk_and left_exp (func group_el)) 20 | ~init:(func hd) 21 | tails 22 | 23 | let exists group func = 24 | match group with 25 | | [] -> M.mk_false 26 | | hd :: tails -> 27 | List.fold_left 28 | ~f:(fun left_exp group_el -> M.mk_or left_exp (func group_el)) 29 | ~init:(func hd) 30 | tails 31 | end 32 | -------------------------------------------------------------------------------- /src/data/label.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | let cnt = ref 0 4 | 5 | let alpha_vid id vid = 6 | "$alpha-" ^ string_of_int id ^ ":" ^ vid 7 | 8 | let freevar_vid vid = 9 | "$freevar:" ^ vid 10 | 11 | let binop_vid vid = "$binop:" ^ string_of_int vid 12 | 13 | let tmp_vid vid = "$tmp:" ^ string_of_int vid 14 | 15 | let strip_wrapper vid = 16 | Re2.replace 17 | (Re2.create_exn "\\$[^:]*:") ~f:(fun _ -> "") vid 18 | 19 | let shorten vid = 20 | Re2.replace 21 | (Re2.create_exn "\\$(.)[^:]*:") ~f:(fun t -> "$" ^ Re2.Match.get_exn t ~sub:(`Index 1)) vid 22 | 23 | module type Context = sig 24 | val label : string 25 | end 26 | 27 | module Make (C : Context) = struct 28 | let cnt = ref 0 29 | let gen ?(prefix = "") () = cnt := !cnt + 1; prefix ^ "$" ^ C.label ^ ":" ^ string_of_int !cnt 30 | end 31 | -------------------------------------------------------------------------------- /src/mlLoader/letNormal.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open SugarProgram 3 | 4 | let letnormal_mapper : Mapper.t = 5 | let open Mapper in 6 | { default_mapper with 7 | let_ = (fun self (vid, e1, e2) -> 8 | let rec anormal exp = 9 | match exp with 10 | | IfExp (ce, te, ee) -> 11 | IfExp (self.exp self ce, anormal te, anormal ee) 12 | | LetExp (vid', e1', e2') -> 13 | LetExp (vid', e1', anormal e2') 14 | | BranchExp (bs) -> 15 | BranchExp (List.map bs ~f:(fun (ce, te) -> (self.exp self ce, anormal te))) 16 | | FailExp -> FailExp 17 | | _ -> LetExp (vid, exp, self.exp self e2) 18 | in anormal (self.exp self e1) 19 | ); 20 | } 21 | 22 | let main (sprogram : t) : t = 23 | SugarProgram.expr_map sprogram ~f:(Mapper.apply_expr letnormal_mapper) 24 | -------------------------------------------------------------------------------- /src/loader/readFml.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Lexing 3 | 4 | let print_position outx lexbuf = 5 | let pos = lexbuf.lex_curr_p in 6 | fprintf outx "%s:%d:%d" pos.pos_fname 7 | pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) 8 | 9 | let main filename = 10 | let inx = In_channel.create filename in 11 | let lexbuf = Lexing.from_channel inx in 12 | lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = filename }; 13 | let tyenv = 14 | try Fmlparser.main Fmllexer.token lexbuf with 15 | | Fmllexer.SyntaxError msg -> 16 | fprintf stderr "%a: %s\n" print_position lexbuf msg; 17 | failwith "SyntaxError" 18 | | Fmlparser.Error -> 19 | fprintf stderr "%a: syntax error\n" print_position lexbuf; 20 | failwith "SyntaxError" 21 | in 22 | In_channel.close inx; 23 | Type.Env.ty_map tyenv ~f:(fun ty -> ty |> Type.RefType.fresh) 24 | -------------------------------------------------------------------------------- /src/loader/readQual.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Data 3 | open Lexer 4 | open Lexing 5 | 6 | let print_position outx lexbuf = 7 | let pos = lexbuf.lex_curr_p in 8 | fprintf outx "%s:%d:%d" pos.pos_fname 9 | pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) 10 | 11 | let main filename : Cond.t list = 12 | match Sys.file_exists ~follow_symlinks:true filename with 13 | | `Yes -> 14 | let inx = In_channel.create filename in 15 | let lexbuf = Lexing.from_channel inx in 16 | lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = filename }; 17 | let quals = 18 | try Qualparser.main Quallexer.token lexbuf with 19 | | Quallexer.SyntaxError msg -> 20 | fprintf stderr "%a: %s\n" print_position lexbuf msg; 21 | failwith "SyntaxError" 22 | | Qualparser.Error -> 23 | fprintf stderr "%a: syntax error\n" print_position lexbuf; 24 | failwith "SyntaxError" 25 | in 26 | In_channel.close inx; 27 | quals |> List.map ~f:Cond.inspect 28 | | _ -> 29 | Logger.warn ("This file does not exist: " ^ filename); [] 30 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | # This is a basic workflow to help you get started with Actions 2 | 3 | name: CI 4 | 5 | # Controls when the action will run. 6 | on: 7 | # Triggers the workflow on push or pull request events but only for the master branch 8 | push: 9 | branches: [ master ] 10 | pull_request: 11 | branches: [ master ] 12 | 13 | # Allows you to run this workflow manually from the Actions tab 14 | workflow_dispatch: 15 | 16 | # A workflow run is made up of one or more jobs that can run sequentially or in parallel 17 | jobs: 18 | # This workflow contains a single job called "build" 19 | build: 20 | strategy: 21 | fail-fast: false 22 | matrix: 23 | os: [ubuntu-latest, macos-latest] 24 | ocaml-version: [ 4.11.1 ] 25 | 26 | runs-on: ${{ matrix.os }} 27 | 28 | steps: 29 | - uses: actions/checkout@v2 30 | 31 | - name: Use OCaml ${{ matrix.ocaml-version }} 32 | uses: avsm/setup-ocaml@v1 33 | with: 34 | ocaml-version: ${{ matrix.ocaml-version }} 35 | 36 | - name: Setup 37 | run: ./.github/workflows/setup.sh 38 | 39 | - name: Compile 40 | run: eval $(opam env) && dune build 41 | -------------------------------------------------------------------------------- /src/mlLoader/betaReduction.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open SugarProgram 3 | 4 | module Env = struct 5 | type t = (Identity.t * Identity.t) list 6 | 7 | let empty = [] 8 | 9 | let add (self : t) (key : Identity.t) (data : Identity.t) : t = (key, data) :: self 10 | 11 | let rec find (self : t) (key : Identity.t) : Identity.t option = 12 | match self with 13 | | [] -> None 14 | | (k, v) :: self when Poly.(k = key) -> Some (Option.value (find self v) ~default:v) 15 | | _ :: self -> find self key 16 | end 17 | 18 | let rec mapper_fn (env : Env.t) : Mapper.t = 19 | { Mapper.default_mapper with 20 | Mapper.let_ = (fun self (vid, e1, e2) -> 21 | match self.Mapper.exp self e1 with 22 | | ObjExp objt when Objt.is_var objt -> 23 | let env = Env.add env vid (Objt.vid_of_exn objt) in 24 | Mapper.apply_expr (mapper_fn env) e2 25 | | e1 -> LetExp (vid, e1, self.Mapper.exp self e2) 26 | ); 27 | Mapper.funccall = (fun self (fid, exps) -> 28 | let exps = List.map exps ~f:(self.Mapper.exp self) in 29 | match Env.find env fid with 30 | | None -> FuncCallExp (fid, exps) 31 | | Some x -> FuncCallExp (x, exps) 32 | ); 33 | Mapper.obj = (fun _self objt -> 34 | match (Objt.vid_of objt |> (fun x -> Option.bind x ~f:(Env.find env))) with 35 | | None -> ObjExp objt 36 | | Some x -> ObjExp (Objt.mk_var x) 37 | ); 38 | } 39 | 40 | let main (sprogram : t) : t = 41 | SugarProgram.expr_map sprogram ~f:(Mapper.apply_expr (mapper_fn Env.empty)) 42 | -------------------------------------------------------------------------------- /src/concern/util.ml: -------------------------------------------------------------------------------- 1 | 2 | open Core 3 | 4 | module Util = struct 5 | let rec join (sep : string) (strings : string list) = 6 | match strings with 7 | | [] -> "" 8 | | [str] -> str 9 | | x :: xs -> x ^ sep ^ join sep xs 10 | 11 | let join_with strs ~separator = 12 | join separator strs 13 | 14 | let insert_indent indent str = 15 | let rec spaces indent = 16 | if indent > 0 then " " ^ spaces (indent - 1) else "" 17 | in 18 | let hd = spaces indent in 19 | String.split_lines str |> List.map ~f:(fun x -> hd ^ x) |> join_with ~separator:"\n" 20 | 21 | let wrap str = "(" ^ str ^ ")" 22 | 23 | let some_break (self : 'a option) ~f : 'a = 24 | match self with 25 | | Some x -> x 26 | | None -> f () 27 | 28 | let shuffle (xs : 'a list) : 'a list = 29 | let ys = List.map xs ~f:(fun x -> (Random.float 1., x)) in 30 | let ys' = List.sort ~compare:(fun (score, _) (score', _) -> Float.compare score score') ys in 31 | List.map ys' ~f:(fun (_, x) -> x) 32 | 33 | let random (xs : 'a list) : ('a * 'a list) option = 34 | let len = List.length xs in 35 | if len <= 0 then 36 | None 37 | else 38 | let pick_idx = Random.int len in 39 | List.foldi xs ~init:(List.hd_exn xs, []) ~f:(fun idx (picked, others) x -> 40 | if idx = pick_idx then 41 | (x, others) 42 | else 43 | (picked, x :: others) 44 | ) |> (fun (picked, xs') -> (picked, List.rev xs')) |> Option.some 45 | 46 | let (@<) g f = fun x -> g (f x) 47 | let (<|) f x = f @@ x 48 | end 49 | include Util 50 | -------------------------------------------------------------------------------- /src/loader/genQual.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Data 3 | 4 | module Dict = struct 5 | type 'a t = (Identity.t * 'a) list 6 | 7 | let empty = [] 8 | let add (dict : 'a t) ~key ~data : 'a t = (key, data) :: dict 9 | end 10 | 11 | let condify (exp : Program.Exp.t) : Cond.t option = 12 | let open Program.Exp in 13 | match exp with 14 | | Term cond -> Some cond 15 | | _ -> None 16 | 17 | let to_qualifier (cond : Cond.t) (env : Cond.t Dict.t) : Cond.t = 18 | let cond = List.fold env ~init:cond ~f:(fun cond (vid, cond') -> 19 | Cond.subst_cond cond (Cond.T.(var vid), cond') 20 | ) in 21 | cond 22 | 23 | 24 | let rec from_exp (exp : Program.Exp.t) (env : Cond.t Dict.t) : Cond.Set.t = 25 | let open Program.Exp in 26 | match exp with 27 | | Let_ (vid, e1, e2) -> 28 | let env' = Option.map (condify e1) ~f:(fun c -> Dict.add env ~key:vid ~data:c) |> Option.value ~default:env in 29 | from_exp e2 env' 30 | | Branch (es) -> 31 | List.fold es ~init:Cond.Set.empty ~f:(fun cs (cond, e) -> 32 | let new_q = to_qualifier cond env in 33 | Cond.Set.add cs new_q |> Cond.Set.union (from_exp e env) 34 | ) 35 | | Term cond -> Cond.Set.singleton Cond.T.(var "vvvvv" == (to_qualifier cond env)) 36 | | _ -> Cond.Set.empty 37 | 38 | 39 | let main (program : Program.t) : Cond.Set.t = 40 | let exps = List.map (Program.recfuns program) ~f:(fun rf -> rf.exp) in 41 | List.fold exps ~init:Cond.Set.empty ~f:(fun cs exp -> Cond.Set.union cs (from_exp exp Dict.empty)) |> 42 | Logger.inspect ~tag:"gened qualifiers" ~f:(fun x -> (List.to_string (Cond.Set.to_list x) ~f:Cond.to_string)) 43 | -------------------------------------------------------------------------------- /src/common/lib.ml: -------------------------------------------------------------------------------- 1 | (** Helper types and functions. *) 2 | 3 | 4 | (** Result type to make caml slightly less unsafe. *) 5 | module Res = struct 6 | 7 | (** Ok or an error. *) 8 | type ('ok, 'err) res = 9 | | Ok of 'ok 10 | | Err of 'err 11 | 12 | (** Map over `Ok`. *) 13 | let map f = function 14 | | Ok res -> Ok (f res) 15 | | Err e -> Err e 16 | 17 | (** Map over `err`. *) 18 | let map_err f = function 19 | | Err e -> Err (f e) 20 | | ok -> ok 21 | 22 | (** Chains an error. *) 23 | let chain_err e = function 24 | | Err err -> Err (e :: err) 25 | | ok -> ok 26 | 27 | (** Creates an `Ok`. *) 28 | let ok something = Ok something 29 | (** True if variant is `Ok`. *) 30 | let is_ok = function | Ok _ -> true | _ -> false 31 | (** True if variant is `Err`. *) 32 | let is_err = function | Err _ -> true | _ -> false 33 | (** Creates an `Err`. *) 34 | let err something = Err something 35 | 36 | (** Does something if not an error. *) 37 | let and_then ( 38 | work: 'a -> ('b, 'err) res 39 | ): ('a, 'err) res -> ('b, 'err) res = function 40 | | Ok res -> work res 41 | | Err err -> Err err 42 | 43 | (** Return the value in `Ok` or prints an error and exits. *) 44 | let unwrap blah = function 45 | | Ok res -> res 46 | | Err e -> 47 | Format.fprintf Format.err_formatter "Error %s:" blah ; 48 | List.iter (Format.fprintf Format.err_formatter "@. %s") e ; 49 | Format.fprintf Format.err_formatter "@." ; 50 | exit 2 51 | 52 | end 53 | 54 | 55 | 56 | (** Wraps unsafe code in a result. *) 57 | let sanitize (blah: string) (f: unit -> 'a): ('a, string list) Res.res = 58 | try f () |> Res.ok with e -> [ 59 | blah ; Printexc.to_string e 60 | ] |> Res.err -------------------------------------------------------------------------------- /src/mlLoader/bindValueReduction.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open SugarProgram 3 | open! Util 4 | 5 | module Env = struct 6 | module Element = struct 7 | type t = SugarProgram.Expr.t 8 | end 9 | 10 | type t = Element.t Identity.Map.t 11 | 12 | let empty = Identity.Map.empty 13 | let find = Identity.Map.find 14 | 15 | let of_alist xs : t = 16 | Identity.Map.of_alist_reduce xs ~f:(fun a _ -> a) 17 | 18 | let map (self : t) ~f : t = 19 | Identity.Map.map self ~f 20 | end 21 | 22 | let main (sprogram : t) : t = 23 | let env = List.filter_map sprogram ~f:(fun el -> 24 | match el with 25 | | BindValue (v, exp) -> Some (v, exp) 26 | | _ -> None 27 | ) |> Env.of_alist in 28 | let rec replace_free_var (env : Env.t) (vars : Identity.Set.t) (exp : SugarProgram.Expr.t) : SugarProgram.Expr.t = 29 | let free_var_set = Identity.Set.diff (free_var_set_of exp) vars in 30 | Identity.Set.fold ~init:exp free_var_set ~f:(fun exp v -> 31 | match Env.find env v with 32 | | Some fv_exp -> 33 | let fv_exp = replace_free_var env Identity.Set.empty fv_exp in 34 | LetExp (v, fv_exp, exp) 35 | | None -> exp 36 | ) 37 | in 38 | let recfun_names = List.filter_map sprogram ~f:(fun el -> match el with BindFunc recfun -> Some recfun.name | _ -> None) |> Identity.Set.of_list in 39 | let env = Env.map env ~f:(replace_free_var env Identity.Set.empty) in 40 | SugarProgram.map sprogram ~f:(fun el -> 41 | match el with 42 | | BindFunc recfun -> BindFunc { recfun with exp = replace_free_var env (Identity.Set.union recfun_names (Identity.Set.of_list recfun.args)) recfun.exp } 43 | | _ -> StructureItem.expr_map el ~f:(replace_free_var env Identity.Set.empty) 44 | ) 45 | -------------------------------------------------------------------------------- /src/data/hashRow.ml: -------------------------------------------------------------------------------- 1 | 2 | open Core 3 | 4 | module Make = functor(M : Hashtbl.Key) -> struct 5 | module H = Hashable.Make_and_derive_hash_fold_t(M) 6 | 7 | type t = { 8 | els: M.t list; 9 | rev: (M.t list) Lazy.t; 10 | table: int H.Table.t; 11 | length: int; 12 | } 13 | [@@deriving fields] 14 | 15 | let find (self : t) (cond : M.t) : int option = H.Table.find (self.table) cond 16 | 17 | let elements (self : t) : M.t list = 18 | Lazy.force_val self.rev 19 | 20 | let add (self : t) (qual : M.t) : t = 21 | match H.Table.add self.table ~key:qual ~data:self.length with 22 | | `Ok -> 23 | let new_els = qual :: self.els in 24 | Fields.create ~els:new_els ~rev:(Lazy.from_fun (fun () -> List.rev new_els)) ~table:self.table ~length:(self.length + 1) 25 | | _ -> self 26 | 27 | let mem (self : t) (el : M.t) : bool = H.Table.mem self.table el 28 | 29 | let add_multi (self : t) (quals : M.t list) : t = List.fold quals ~init:self ~f:add 30 | 31 | let create quals = 32 | let table = H.Table.create () in 33 | let empty = Fields.create ~els:[] ~rev:(Lazy.from_val []) ~table ~length:0 in 34 | add_multi empty quals 35 | 36 | (* Return rev elements from (old.length)-th to (self.length - 1)-th. Assume old is subset of self *) 37 | let new_elements (self : t) (old : t) : M.t list = 38 | let size = self.length - old.length in 39 | let rec take i xs acc = 40 | if i <= 0 then acc 41 | else 42 | match xs with 43 | | [] -> acc 44 | | x' :: xs' -> take (i - 1) xs' (x' :: acc) 45 | in 46 | take size self.els [] 47 | 48 | let length (self : t) = self.length 49 | 50 | let to_alist (self : t) : (M.t * int) list = 51 | List.mapi (elements self) ~f:(fun i x -> (x, i)) 52 | end 53 | -------------------------------------------------------------------------------- /src/horn_solver/smtParse.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open! ParseBase 3 | %} 4 | 5 | %token OP 6 | %token EXISTS FORALL LET 7 | 8 | %token EOF OPAREN CPAREN 9 | 10 | %token SAT UNSAT MODEL ERROR DEFINE 11 | %token DQUOTED 12 | 13 | %token IDENT CINT CBOOL 14 | %token INT BOOL 15 | 16 | %start top 17 | %type top 18 | 19 | %% 20 | 21 | top: 22 | | SAT { ParseBase.Sat } 23 | | UNSAT { ParseBase.Unsat } 24 | | error = err { ParseBase.Error error } 25 | | model = model { ParseBase.Model model } 26 | | EOF { ParseBase.None } 27 | 28 | err: 29 | | OPAREN ; ERROR ; msg = DQUOTED ; CPAREN { msg } 30 | 31 | model: 32 | | OPAREN ; MODEL ; defs = list(pred_def) ; CPAREN { defs } 33 | 34 | pred_def: 35 | | OPAREN ; 36 | DEFINE ; id = ident ; OPAREN ; args = list(arg) ; CPAREN ; 37 | BOOL ; body = body ; 38 | CPAREN { (id, (args, body)) } 39 | 40 | arg: 41 | | OPAREN ; id = ident ; t = typ ; CPAREN { (id, t) } 42 | 43 | binding: 44 | | OPAREN ; id = ident ; expr = body ; CPAREN { (id, expr) } 45 | 46 | typ: 47 | | INT { "Int" } 48 | | BOOL { "Bool" } 49 | 50 | body: 51 | | OPAREN ; 52 | EXISTS ; OPAREN ; args = list(arg) ; CPAREN ; body = body ; 53 | CPAREN { ParseBase.EQtf (args, body) } 54 | | OPAREN ; 55 | FORALL ; OPAREN ; args = list(arg) ; CPAREN ; body = body ; 56 | CPAREN { ParseBase.UQtf (args, body) } 57 | | OPAREN ; LET ; OPAREN ; 58 | bindings = list(binding) ; CPAREN ; body = body ; 59 | CPAREN { 60 | ParseBase.Let (bindings, body) 61 | } 62 | | OPAREN ; op = OP ; args = list(body) ; CPAREN { 63 | ParseBase.App(op, args) 64 | } 65 | | OPAREN ; id = IDENT ; args = list(body) ; CPAREN { 66 | ParseBase.PApp(id, args) 67 | } 68 | | CBOOL { ParseBase.Leaf $1 } 69 | | CINT { ParseBase.Leaf $1 } 70 | | ident { ParseBase.Leaf $1 } 71 | 72 | ident: 73 | | IDENT { $1 } 74 | -------------------------------------------------------------------------------- /src/loader/qualparser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Objt 3 | open Cond 4 | open Op 5 | %} 6 | 7 | %token IMPL 8 | %token AND OR 9 | %token NOT 10 | %token EQ LEQ GEQ GT LT NEQ 11 | 12 | %token INT 13 | %token ID 14 | %token MINUS PLUS TIMES DIV 15 | %token EOF LPAREN RPAREN TRUE FALSE NU SEMICOLON 16 | 17 | %right IMPL 18 | %left AND OR 19 | 20 | %nonassoc EQ LEQ GEQ GT LT NEQ 21 | 22 | %left PLUS MINUS 23 | 24 | %left TIMES DIV 25 | 26 | %right NOT 27 | 28 | %start main 29 | %type main 30 | 31 | %% 32 | 33 | main: 34 | | EOF { [] } 35 | | condition EOF { [$1] } 36 | | condition SEMICOLON main { $1 :: $3 } 37 | 38 | condition: 39 | | LPAREN condition RPAREN { $2 } 40 | | condition PLUS condition { Op2($1, Plus , $3) } 41 | | condition MINUS condition { Op2($1, Minus, $3) } 42 | | condition TIMES condition { Op2($1, Times, $3) } 43 | | condition DIV condition { Op2($1, Div , $3) } 44 | | condition EQ condition { Op2($1, Eq , $3) } 45 | | condition NEQ condition { Op2($1, Neq , $3) } 46 | | condition LEQ condition { Op2($1, Leq , $3) } 47 | | condition LT condition { Op2($1, Lt , $3) } 48 | | condition GEQ condition { Op2($1, Geq , $3) } 49 | | condition GT condition { Op2($1, Gt , $3) } 50 | | condition AND condition { Op2($1, And_, $3) } 51 | | condition OR condition { Op2($1, Or_, $3) } 52 | | condition IMPL condition { Op2($1, Impl, $3) } 53 | | MINUS condition { Op1(Minus, $2) } 54 | | NOT condition { Op1(Not_, $2) } 55 | | value { Value($1) } 56 | ; 57 | 58 | value: 59 | | NU { VarObj("V") } 60 | | ID { VarObj($1) } 61 | | INT { IntObj($1) } 62 | | TRUE { IntObj(1) } 63 | | FALSE { IntObj(0) } 64 | ; 65 | -------------------------------------------------------------------------------- /src/r_type.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Lib 3 | 4 | module Map = Identity.Map 5 | module Typ = Type.RefType 6 | 7 | 8 | let print_type_env type_env model = 9 | Format.printf "Program is safe with types@.@." ; 10 | let types = Cond.UnknownSubst.Map.empty in 11 | Type.Env.assign_unknown type_env types |> Type.Env.to_string 12 | |> Format.printf "%s" ; 13 | if Poly.(model <> []) then ( 14 | Format.printf "where@.@." ; 15 | List.iter model ~f:( 16 | Format.printf "@[%a@]@." ParseBase.fmt_def 17 | ) 18 | ) ; 19 | () 20 | 21 | 22 | 23 | let work filename = 24 | if ! Conf.verb then Format.printf "loading file '%s'...@." filename ; 25 | Loader.main Loader.Config.( 26 | { filename ; qualfilename = "" ; 27 | reduce_vc = false ; 28 | allow_to_reduce_multi_impl = false ; 29 | do_effect_analysis = ! Conf.effect_analysis 30 | } 31 | ) 32 | 33 | |> Res.and_then (fun { Loader.horn_clauses ; Loader.type_env ; _ } -> 34 | 35 | if ! Conf.run_solver |> not then 36 | (fun () -> 37 | Cond.ToSmt2.clauses_to_smt2 38 | Format.std_formatter false filename horn_clauses 39 | ) |> sanitize "during horn clause generation" 40 | else ( 41 | if ! Conf.verb then Format.printf "running solver...@." ; 42 | Solver.solve filename horn_clauses 43 | |> Res.chain_err "during horn clause solving" 44 | |> Res.and_then (function 45 | | Some model -> 46 | if ! Conf.verb then Format.printf "success, printing model...@.@." ; 47 | print_type_env type_env model ; 48 | Res.Ok () 49 | | None -> 50 | Format.printf 51 | "This program is not typeable with refinement types@." ; 52 | Format.printf "It might be unsafe.@." ; 53 | Res.Ok () 54 | ) 55 | ) 56 | 57 | ) 58 | 59 | 60 | 61 | let _ = 62 | let ml_file = Conf.init () in 63 | work ml_file |> Res.unwrap (Format.asprintf "on file %s" ml_file) ; 64 | exit 0 65 | -------------------------------------------------------------------------------- /src/loader/loader.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | module Config = struct 4 | type t = { 5 | filename : string; 6 | qualfilename : string; 7 | reduce_vc : bool; 8 | allow_to_reduce_multi_impl : bool; 9 | do_effect_analysis : bool; 10 | } 11 | [@@deriving create, eq, ord, hash] 12 | end 13 | 14 | type t = { 15 | type_env: Type.Env.t; 16 | unknown_predicates: UnknownPredicate.t list; 17 | horn_clauses: Cond.t list; 18 | } 19 | [@@deriving create, fields] 20 | 21 | let (|->) (a : 'a) (f : 'a -> unit) : 'a = f a; a 22 | 23 | let switch_use_refinement_annotation b = Program.use_refinement_annotation := b 24 | let use_test_run = ref true 25 | let switch_use_test_run b = use_test_run := b 26 | 27 | let main (config : Config.t) = (fun () -> 28 | config.Config.filename |> 29 | MlLoader.parse |> MlLoader.desugar |> 30 | (fun pr -> 31 | let tyenv = Program.reftype_env_of pr in 32 | let fml = VerificationCondition.main tyenv pr in 33 | let clauses = Cond.Horn.main fml in 34 | let (clauses, tyenv) = 35 | if Config.(config.reduce_vc) || Config.(config.do_effect_analysis) then 36 | OptimizeVc.run 37 | clauses tyenv pr 38 | Config.(config.do_effect_analysis) 39 | else 40 | (clauses, tyenv) 41 | in 42 | let unknowns_of ty = 43 | List.map (Type.RefType.conds_of ty) ~f:Cond.uapps_of |> List.concat |> List.map ~f:Cond.UnknownApp.predicate_of in 44 | let unknown_predicates = 45 | List.map (Type.Env.types_of tyenv) ~f:unknowns_of |> 46 | List.concat |> List.dedup_and_sort ~compare:UnknownPredicate.compare 47 | in 48 | create 49 | ~type_env:tyenv 50 | ~unknown_predicates 51 | ~horn_clauses:clauses 52 | () 53 | ) 54 | ) |> Lib.sanitize "during caml loading" 55 | 56 | let read_given_tyenv prfname tyfname = 57 | let program = prfname |> MlLoader.parse |> MlLoader.desugar in 58 | let tyenv = ReadFml.main tyfname in 59 | let fml = VerificationCondition.main tyenv program in 60 | let clauses = Cond.Horn.main fml in 61 | (tyenv, clauses) 62 | -------------------------------------------------------------------------------- /src/data/unknownPredicate.ml: -------------------------------------------------------------------------------- 1 | 2 | open Core 3 | 4 | module V = Label.Make(struct let label = "unknown" end) 5 | 6 | type id = Identity.t 7 | [@@deriving eq, sexp, ord, hash] 8 | 9 | module T = struct 10 | type t = 11 | { id: Identity.t; vars: Identity.t list; [@ignore] var_set: Identity.Set.t [@ignore] } 12 | [@@deriving compare, sexp, hash] 13 | 14 | let equal (self : t) (another : t) : bool = Identity.equal self.id another.id 15 | let compare (self : t) (another : t) : int = Identity.compare self.id another.id 16 | let to_string self = 17 | Identity.Short.show self.id ^ List.to_string self.vars ~f:Identity.Short.show 18 | end 19 | include T 20 | include Comparable.Make(T) 21 | include Hashable.Make(T) 22 | 23 | let init ?prefix variables : t = 24 | { id = V.gen ?prefix (); vars = variables; var_set = Identity.Set.of_list variables } 25 | 26 | (* let subst self orig_var new_var = 27 | if List.mem self.vars orig_var then 28 | { self with var_subst = Subst.add self.var_subst (orig_var, new_var) } 29 | else 30 | { self with var_subst = Subst.subst self.var_subst orig_var new_var } *) 31 | 32 | (* let subst_of self = self.var_subst *) 33 | let get_vids self = self.vars 34 | let vids_of self = self.vars 35 | let var_set_of self = self.var_set 36 | (* let substed_vids_of self = 37 | List.map self.vars ~f:(fun v -> 38 | Option.value (Subst.find self.var_subst v) ~default:v 39 | ) *) 40 | 41 | let sort_vars = List.sort ~compare:(Identity.compare) 42 | 43 | (* let get_obj_substs (self : t) = 44 | List.fold (List.map self.vars ~f:(fun x -> (x, x)) @ self.var_subst) ~init:ObjSubst.Map.empty ~f:(fun acc (k, v) -> 45 | match ObjSubst.Map.find self.obj_subst v with 46 | | Some x -> ObjSubst.Map.add acc ~key:k ~data:x 47 | | None -> acc 48 | ) *) 49 | 50 | let id_of self = self.id 51 | let short_id_of self = Identity.Short.show self.id 52 | let compare self other = Identity.compare (id_of self) (id_of other) 53 | 54 | let show_id = short_id_of 55 | 56 | let mem self vid = Identity.Set.mem self.var_set vid 57 | 58 | module Testability = struct 59 | let create name : t = { id = name; vars = []; var_set = Identity.Set.empty; } 60 | end 61 | -------------------------------------------------------------------------------- /src/mlLoader/kNormal.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open SugarProgram 3 | 4 | module V = Label.Make(struct let label = "knormal" end) 5 | 6 | module Context = struct 7 | type 'a t = 'a -> Expr.t 8 | 9 | let insert_let (exp : Expr.t) (context : Expr.t t) : Expr.t = 10 | match exp with 11 | | ObjExp _objt -> context exp 12 | | _ -> 13 | let vid = V.gen () in 14 | let obj_exp = ObjExp (Objt.mk_var vid) in 15 | LetExp (vid, exp, context obj_exp) 16 | 17 | let insert_let_unless_var (exp : Expr.t) (var_context : Identity.t t) : Expr.t = 18 | match exp with 19 | | ObjExp objt when Objt.is_var objt -> var_context (Objt.vid_of_exn objt) 20 | | _ -> 21 | let vid = V.gen () in 22 | LetExp (vid, exp, var_context vid) 23 | end 24 | 25 | let knormal_mapper : Mapper.t = 26 | { Mapper.default_mapper with 27 | Mapper.op2 = (fun self (e1, op, e2) -> 28 | Context.insert_let (self.Mapper.exp self e1) (fun x -> 29 | Context.insert_let (self.Mapper.exp self e2) (fun y -> 30 | OpExp (x, op, y) 31 | ) 32 | ) 33 | ); 34 | Mapper.op1 = (fun self (op, e) -> 35 | Context.insert_let (self.Mapper.exp self e) (fun x -> 36 | SingleOpExp (op, x) 37 | ) 38 | ); 39 | Mapper.funccall = (fun self (fid, exps) -> 40 | let exps = List.map exps ~f:(self.Mapper.exp self) in 41 | List.fold exps ~init:(ObjExp (Objt.mk_var fid)) ~f:(fun fe x -> 42 | Context.insert_let_unless_var x (fun v -> 43 | Context.insert_let_unless_var fe (fun fid -> 44 | Context.insert_let (FuncCallExp (fid, [ObjExp (Objt.mk_var v)])) (fun x -> x) 45 | ) 46 | ) 47 | ) 48 | ); 49 | Mapper.if_ = (fun self (cond_e, then_e, else_e) -> 50 | Context.insert_let (self.Mapper.exp self cond_e) (fun e -> 51 | IfExp (e, self.Mapper.exp self then_e, self.Mapper.exp self else_e) 52 | ) 53 | ); 54 | Mapper.assert_ = (fun self e -> 55 | Context.insert_let (self.Mapper.exp self e) (fun e -> 56 | AssertExp e 57 | ) 58 | ); 59 | } 60 | 61 | let main (sprogram : t) : t = 62 | SugarProgram.expr_map sprogram ~f:(Mapper.apply_expr knormal_mapper) 63 | -------------------------------------------------------------------------------- /src/concern/logical.ml.unused: -------------------------------------------------------------------------------- 1 | 2 | open Core.Std 3 | 4 | type 'a logic_t = 5 | | Impl of 'a logic_t * 'a logic_t 6 | | And of 'a logic_t * 'a logic_t 7 | | Or of 'a logic_t * 'a logic_t 8 | | Not of 'a logic_t 9 | | Atom of 'a 10 | | Bool of bool 11 | 12 | type 'a 'b delogic_t = 13 | | DImpl of 'a * 'a 14 | | DAnd of 'a * 'a 15 | | DOr of 'a * 'a 16 | | DNot of 'a 17 | | DAtom of 'b 18 | | DBool of bool 19 | 20 | let decompose e f = 21 | match e with 22 | | Impl (d1, d2) -> DImpl (f d1, f d2) 23 | | And (d1, d2) -> DAnd (f d1, f d2) 24 | | Or (d1, d2) -> DOr (f d1, f d2) 25 | | Not d -> DNot (f d) 26 | | Atom at -> DAtom at 27 | | Bool bl -> DBool bl 28 | 29 | let reassemble = function 30 | | DImpl (d1, d2) -> Impl (d1, d2) 31 | | DAnd (d1, d2) -> And (d1, d2) 32 | | DOr (d1, d2) -> Or (d1, d2) 33 | | DNot d -> Not d 34 | | DAtom at -> Atom at 35 | 36 | let is_true = function 37 | | DBool bl -> bl 38 | | _ -> false 39 | 40 | let is_false = function 41 | | DBool bl -> !bl 42 | | _ -> false 43 | 44 | module type S = sig 45 | type t 46 | type atom_t 47 | 48 | val to_logic : t -> logic_t 49 | 50 | module Comp : Map.Key with type t = atom_t 51 | end 52 | 53 | module Make (M : S) = struct 54 | module AtomMap = Map.Make(S.Comp) 55 | module Decompose = Decomposable.Make(struct 56 | type 'a t = 'a S.t delogic_t 57 | let decompose = decompose 58 | let reassemble = reassemble 59 | end) 60 | 61 | type env_t = { truthy: AtomMap.t; falsy: AtomMap.t; } 62 | 63 | let compress e env = 64 | let loop = function 65 | | DImpl (d1, d2) when is_true d1 || is_false d2 -> Bool true 66 | | DImpl (d1, d2) when is_false d1 && is_true d2 -> Bool false 67 | | DAnd (d1, d2) when is_true d1 && is_true d2 -> Bool true 68 | | DAnd (d1, d2) when is_false d1 || is_false d2 -> Bool false 69 | | DOr (d1, d2) when is_true d1 || is_true d2 -> Bool true 70 | | DOr (d1, d2) when is_false d1 && is_false d2 -> Bool false 71 | | DNot d when is_true d -> Bool false 72 | | DNot d when is_false d -> Bool true 73 | | DAtom at -> 74 | match Atom.find env at with 75 | Some b -> Bool b 76 | | None -> Atom at 77 | in Decompose.dmap e loop 78 | end 79 | -------------------------------------------------------------------------------- /src/data/variableArray.ml: -------------------------------------------------------------------------------- 1 | 2 | open Core 3 | type 'a t = { 4 | mutable els: ('a option) Array.t; 5 | mutable content_length: int; 6 | } 7 | 8 | let chunk_length = 200 9 | 10 | let create length = 11 | { els = Array.create ~len:chunk_length None; content_length = 0; } 12 | 13 | let get (self : 'a t) (idx : int) : 'a option = 14 | if idx >= self.content_length then None 15 | else Array.get self.els idx 16 | 17 | let expand_array (self : 'a t) (amount : int) : unit = 18 | let len = ((amount % chunk_length) + 1) * chunk_length in 19 | self.els <- Array.append self.els (Array.create ~len None) 20 | 21 | let set (self : 'a t) (idx : int) (el : 'a) : unit = 22 | let expands = idx - (Array.length self.els - 1) in 23 | let () = if expands > 0 then expand_array self expands else () in 24 | let () = if idx >= self.content_length then self.content_length <- idx + 1 else () in 25 | Array.set self.els idx (Some el) 26 | 27 | 28 | let iter (self : 'a t) ~f : unit = 29 | let rec loop (idx : int) : unit = 30 | if idx >= self.content_length then () 31 | else 32 | match get self idx with 33 | | None -> loop (idx + 1) 34 | | Some x -> let () = f x in loop (idx + 1) 35 | in loop 0 36 | 37 | let iter2 (self : 'a t) (xs : 'b list) ~f : unit = 38 | let rec loop (idx : int) (ys : 'b list) : unit = 39 | if idx >= self.content_length then () 40 | else 41 | match get self idx with 42 | | None -> loop (idx + 1) ys 43 | | Some x -> 44 | match ys with 45 | | [] -> () 46 | | y :: ys' -> let () = f x y in loop (idx + 1) ys' 47 | in loop 0 xs 48 | 49 | let fold (self : 'a t) ~init ~f = 50 | let rec loop (idx : int) (acc : 'b) : 'b = 51 | if idx >= self.content_length then acc 52 | else 53 | match get self idx with 54 | | None -> loop (idx + 1) acc 55 | | Some x -> loop (idx + 1) (f acc x) 56 | in loop 0 init 57 | 58 | let to_alist (self : 'a t) : (int * 'a) list = 59 | let rec loop (idx : int) (acc : (int * 'a) list) : (int * 'a) list = 60 | if idx < 0 then acc 61 | else 62 | match get self idx with 63 | | None -> loop (idx - 1) acc 64 | | Some x -> loop (idx - 1) ((idx, x) :: acc) 65 | in loop self.content_length [] 66 | -------------------------------------------------------------------------------- /src/loader/fmlparser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Objt 3 | open Cond 4 | open Type 5 | open Op 6 | %} 7 | 8 | %token EQ LEQ GEQ GT LT NEQ 9 | %token AND OR 10 | %token NOT 11 | 12 | %token INT 13 | %token ID 14 | %token MINUS PLUS TIMES DIV MOD 15 | %token EOF LPAREN RPAREN LBRACE RBRACE COLON VLINE IF THEN ELSE LET REC FUNC INTEGER IN FAIL ASSERT RECAND SELECT WHEN ARROW TRUE FALSE IMPL 16 | 17 | %left ASSERT 18 | 19 | %left AND OR IMPL 20 | 21 | %nonassoc EQ LEQ GEQ GT LT NEQ 22 | 23 | %left PLUS MINUS 24 | 25 | %left TIMES DIV 26 | 27 | %nonassoc UMINUS 28 | %right NOT 29 | 30 | %start main 31 | %type main 32 | 33 | %% 34 | 35 | main: 36 | | typedef EOF { Type.Env.T.(Type.Env.empty @<< from_map $1) } 37 | | typedef main { Type.Env.T.($2 @<< from_map $1) } 38 | 39 | typedef: 40 | | ID COLON ref_type { ($1, $3) } 41 | 42 | ref_type: 43 | | LPAREN ref_type RPAREN { $2 } 44 | | LBRACE ID COLON INTEGER VLINE condition RBRACE { RefType.Int_ ($2, $6)} 45 | | func_type { $1 } 46 | 47 | func_type: 48 | | LPAREN func_type RPAREN { $2 } 49 | | ID COLON ref_type ARROW ref_type { RefType.Func ($1, $3, $5) } 50 | | ref_type ARROW ref_type { RefType.Func (RefType.L.gen (), $1, $3) } 51 | 52 | condition: 53 | | LPAREN condition RPAREN { $2 } 54 | | condition PLUS condition { Op2($1, Plus , $3) } 55 | | condition MINUS condition { Op2($1, Minus, $3) } 56 | | condition MOD condition { Op2($1, Mod, $3) } 57 | | condition TIMES condition { Op2($1, Times, $3) } 58 | | condition DIV condition { Op2($1, Div , $3) } 59 | | condition EQ condition { Op2($1, Eq , $3) } 60 | | condition NEQ condition { Op2($1, Neq , $3) } 61 | | condition LEQ condition { Op2($1, Leq , $3) } 62 | | condition LT condition { Op2($1, Lt , $3) } 63 | | condition GEQ condition { Op2($1, Geq , $3) } 64 | | condition GT condition { Op2($1, Gt , $3) } 65 | | condition AND condition { Op2($1, And_, $3) } 66 | | condition OR condition { Op2($1, Or_, $3) } 67 | | condition IMPL condition { Op2($1, Impl, $3) } 68 | | MINUS condition { Op1(Minus, $2) } 69 | | NOT condition { Op1(Not_, $2) } 70 | | value { Value($1) } 71 | ; 72 | 73 | value: 74 | | ID { VarObj($1) } 75 | | INT { IntObj($1) } 76 | | TRUE { IntObj(1) } 77 | | FALSE { IntObj(0) } 78 | ; 79 | -------------------------------------------------------------------------------- /src/concern/formatable.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | type t = Text of string | Indent of t list | Inline of t list | Block of t list 4 | type fmt = t list 5 | 6 | let is_inline = function 7 | | Text _ -> true 8 | | Inline _ -> true 9 | | _ -> false 10 | 11 | let rec sort blk = 12 | let mk_group blks = 13 | let sort_queue = 14 | function 15 | (sum, []) -> sum 16 | | (sum, xs) -> Block (List.rev xs) :: sum 17 | in let loop (sum, current) blk = 18 | if is_inline blk 19 | then (sum, blk :: current) 20 | else (blk :: sort_queue (sum, current), []) 21 | in List.fold_left blks ~f:loop ~init:([], []) |> sort_queue |> List.rev 22 | in match blk with 23 | | Inline blks -> 24 | let blks' = List.map blks ~f:sort in 25 | if List.for_all blks' ~f:is_inline 26 | then Inline blks' 27 | else Indent (mk_group blks') 28 | | Block blks -> Block (mk_group blks) 29 | | Indent blks -> Indent (mk_group blks) 30 | | _ -> blk 31 | 32 | let to_string blk = 33 | let rec to_string' indent blk = 34 | let join ls = List.fold_left ls ~init:"" ~f:(fun sum l -> sum ^ l) in 35 | match blk with 36 | | Text str -> str 37 | | Inline blks -> 38 | List.map blks ~f:(to_string' indent) |> join 39 | | Block blks -> 40 | if List.for_all blks ~f:is_inline 41 | then Util.insert_indent indent (List.map blks ~f:(to_string' indent) |> join) ^ "\n" 42 | else List.map blks ~f:(to_string' indent) |> join 43 | | Indent blks -> 44 | if List.for_all blks ~f:is_inline 45 | then Util.insert_indent (indent + 1) (List.map blks ~f:(to_string' (indent + 1)) |> join) ^ "\n" 46 | else List.map blks ~f:(to_string' (indent + 1)) |> join 47 | in to_string' 0 blk 48 | 49 | let indent blk = Indent [blk] 50 | let block str = Block str 51 | let to_block el = Block [el] 52 | let inline str = Inline str 53 | let text str = Text str 54 | let line str = block [text str] 55 | let noline str = inline [text str] 56 | 57 | let rec joint (xs : 'a list) (y : 'a) : 'a list = 58 | match xs with 59 | [] -> [] 60 | | hd :: [] -> 61 | [hd] 62 | | hd :: tl -> 63 | hd :: y :: joint tl y 64 | 65 | type format_t = t 66 | module type S = sig 67 | type t 68 | val to_format : t -> format_t 69 | end 70 | let s (type a) (to_format : a -> format_t) = 71 | (module struct 72 | type t = a 73 | let to_format = to_format 74 | end : S) 75 | 76 | module Make (M : S) = struct 77 | let to_format tr = tr |> M.to_format |> sort 78 | let to_string tr = tr |> to_format |> to_string 79 | end 80 | -------------------------------------------------------------------------------- /src/mlLoader/alphaConv.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open SugarProgram 3 | 4 | module AssignMap = Map.Make(String) 5 | 6 | let (<*>) a1 a2 = List.zip_exn a1 a2 7 | 8 | class ['a] scope = 9 | object (_self) 10 | val mutable vmap = (AssignMap.empty : 'a AssignMap.t) 11 | method get = vmap 12 | method set nmap = vmap <- nmap 13 | method add vkey vid = 14 | match AssignMap.add vmap ~key:vkey ~data:vid with 15 | | `Ok vmap' -> vmap <- vmap' 16 | | `Duplicate -> () 17 | method mem vkey = AssignMap.mem vmap vkey 18 | method find vkey = AssignMap.find vmap vkey 19 | end 20 | 21 | class flesh_var scope = 22 | object (self) 23 | val mutable id = 0 24 | val current = scope 25 | method private intro vid = 26 | id <- id + 1; 27 | Label.alpha_vid id vid 28 | method conv vid = 29 | let rec loop aid = 30 | if current#mem aid then loop (self#intro aid) else (current#add vid aid; aid) 31 | in loop (self#intro vid) 32 | end 33 | 34 | let main (sprogram : SugarProgram.t) : SugarProgram.t = 35 | let scope = new scope in 36 | let nest f = 37 | let backup = scope#get in 38 | let res = f () in 39 | scope#set backup; res 40 | in 41 | let alpha = new flesh_var scope in 42 | 43 | let conv_vid vid = 44 | match scope#find vid with 45 | | Some v -> v 46 | | None -> vid (* (Label.freevar_vid vid) *) in 47 | let mapper : Mapper.t = { Mapper.default_mapper with 48 | Mapper.abs = (fun self (vids, exp) -> 49 | nest (fun () -> 50 | let vids' = List.map vids ~f:(fun v -> alpha#conv v) in 51 | AbsExp (vids', self.Mapper.exp self exp) 52 | ) 53 | ); 54 | Mapper.let_ = (fun self (vid, exp1, exp2) -> 55 | let exp1' = self.Mapper.exp self exp1 in 56 | nest (fun () -> 57 | let alpha_vid = alpha#conv vid in 58 | LetExp (alpha_vid, exp1', self.Mapper.exp self exp2) 59 | ) 60 | ); 61 | Mapper.funccall = (fun self (fid, exps) -> 62 | FuncCallExp (conv_vid fid, List.map exps ~f:(self.Mapper.exp self)) 63 | ); 64 | Mapper.obj = (fun _self (obj) -> 65 | if Objt.is_var obj 66 | then 67 | mk_var (conv_vid (Objt.vid_of_exn obj)) 68 | else 69 | ObjExp obj 70 | ); 71 | } 72 | in 73 | SugarProgram.map sprogram ~f:(fun el -> 74 | match el with 75 | | BindFunc recfun -> 76 | nest (fun () -> 77 | let alpha_args = List.map recfun.args ~f:(fun x -> alpha#conv x) in 78 | let exp = Mapper.apply_expr mapper recfun.SugarProgram.exp in 79 | BindFunc { recfun with exp = exp; args = alpha_args; } 80 | ) 81 | | _ -> StructureItem.expr_map el ~f:(Mapper.apply_expr mapper) 82 | ) 83 | -------------------------------------------------------------------------------- /src/loader/runner.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Program 3 | 4 | module Defs = struct 5 | module Map = Identity.Map 6 | type closure_t = { 7 | name: Identity.t; 8 | exp: Exp.t; 9 | vars: Identity.t list; 10 | ty: Type.RefType.t; 11 | mutable env: env_t; 12 | } 13 | [@@deriving fields, sexp, eq, ord] 14 | and value_t = Fail | Basic of Objt.t | Clos of closure_t 15 | [@@deriving sexp, eq, ord] 16 | and env_t = value_t Map.t 17 | [@@deriving sexp, eq, ord] 18 | end 19 | 20 | module Env = struct 21 | include Defs.Map 22 | type tt = Defs.env_t 23 | end 24 | 25 | module Value = struct 26 | module T = struct 27 | type t = Defs.value_t 28 | [@@deriving sexp, eq, ord] 29 | end 30 | include T 31 | include Showsexp.Make(T) 32 | 33 | let is_fail (self : t) = match self with Defs.Fail -> true | _ -> false 34 | let is_safe (self : t) = not (is_fail self) 35 | 36 | let obj_of (self : t) = match self with Defs.Basic obj -> Some obj | _ -> None 37 | let obj_value (obj : Objt.t) : t = Defs.Basic obj 38 | let pure cond = Defs.Basic cond 39 | 40 | module Closure = struct 41 | type t = Defs.closure_t 42 | [@@deriving sexp, eq, ord] 43 | 44 | let is_satisfied (self : t) = List.is_empty self.Defs.vars 45 | 46 | (* let assign (self : t) (v : Defs.value_t) : t = 47 | let (x, xs) = (List.hd_exn self.Defs.vars, List.tl_exn self.Defs.vars) in 48 | let (arg_ty, rtn_ty) = ( 49 | Type.RefType.arg self.Defs.ty, Type.RefType.rtn self.Defs.ty 50 | ) in 51 | let (arg_ty, rtn_ty) = 52 | (match obj_of v with 53 | | Some obj -> ( 54 | Type.RefType.assign_obj arg_ty (Type.RefType.name_of arg_ty) obj, 55 | Type.RefType.assign_obj rtn_ty ( 56 | Type.RefType.name_of self.Defs.ty 57 | ) obj 58 | ) 59 | | None -> (arg_ty, rtn_ty) )in 60 | let examples = ([get_unknown arg_ty] |> List.filter_opt) @ self.examples 61 | in { self with vars = xs; ty = rtn_ty; env = Env.add self.env ~key:x ~data:v; examples = examples } *) 62 | 63 | let random_input (self : t) = 64 | let arg_types = Type.RefType.argument_types self.Defs.ty in 65 | List.map arg_types ~f:(fun ty -> 66 | if Type.RefType.is_base ty then 67 | Objt.mk_int (Random.int 20) |> obj_value 68 | else failwith "unsupported" 69 | ) 70 | 71 | let func_to_closure (func : Func.t) (ty : Type.RefType.t) (env : Env.tt) : t = { 72 | Defs.name = func.Func.name ; 73 | Defs.exp = func.Func.exp ; 74 | Defs.vars = func.Func.args ; 75 | Defs.ty = ty ; 76 | Defs.env = env ; 77 | } 78 | 79 | let to_string (self : t) : string = 80 | "{ name: " ^ self.Defs.name ^ ";\n" ^ 81 | " ty: " ^ Type.RefType.to_string self.Defs.ty ^ "; }" 82 | end 83 | 84 | let to_string (self : t) : string = 85 | match self with 86 | | Defs.Fail -> "fail" 87 | | Defs.Basic (v) -> Objt.to_string v 88 | | Defs.Clos (v) -> Closure.to_string v 89 | 90 | let closure_value (c : Closure.t) : t = Defs.Clos c 91 | let closure_of (self : t) : Closure.t option = match self with Defs.Clos c -> Some c | _ -> None 92 | end 93 | -------------------------------------------------------------------------------- /src/mlLoader/desugar.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | module Verification = struct 4 | open SugarProgram 5 | 6 | let rec disallow_without_simple_exp (exp : Expr.t) = 7 | match exp with 8 | | ObjExp _obj -> () 9 | | SingleOpExp (_op, e) -> disallow_without_simple_exp e 10 | | AssertExp e -> disallow_without_simple_exp e 11 | | FuncCallExp (_fid, es) -> List.iter es ~f:disallow_without_simple_exp 12 | | OpExp (e1, _op, e2) -> let () = disallow_without_simple_exp e1 in disallow_without_simple_exp e2 13 | | _ -> failwith ("not simple expression: " ^ Expr.to_string exp) 14 | end 15 | 16 | module Converter = struct 17 | let rec exp_to_cond (exp : SugarProgram.Expr.t) : Cond.t = 18 | let open SugarProgram in 19 | match exp with 20 | | ObjExp obj -> Cond.Value obj 21 | | SingleOpExp (op, e) -> Cond.Op1 (op, exp_to_cond e) 22 | | OpExp (e1, op, e2) -> Cond.Op2 (exp_to_cond e1, op, exp_to_cond e2) 23 | | _ -> failwith ("not allowed expression for condition: " ^ Expr.to_string exp) 24 | 25 | let exp_to_vid (exp : SugarProgram.Expr.t) : Identity.t = 26 | let open SugarProgram in 27 | match exp with 28 | | ObjExp obj when Objt.is_var obj -> Objt.vid_of_exn obj 29 | | _ -> failwith ("not allowed expression for condition: " ^ Expr.to_string exp) 30 | 31 | let sprogram_to_program (sprogram : SugarProgram.t) : Program.t = 32 | let open Program in 33 | let rec conv_exp (exp : SugarProgram.Expr.t) = 34 | match exp with 35 | | SugarProgram.LetExp (vid, e1, e2) -> 36 | let () = Verification.disallow_without_simple_exp e1 in 37 | Exp.Let_ (vid, conv_exp e1, conv_exp e2) 38 | | SugarProgram.BranchExp (branches) -> 39 | let bs = List.map branches ~f:(fun (cond_e, then_e) -> 40 | (exp_to_cond cond_e, conv_exp then_e) 41 | ) in 42 | Exp.Branch bs 43 | | SugarProgram.IfExp (e1, e2, e3) -> 44 | let cond = exp_to_cond e1 in 45 | Exp.Branch ([(cond, conv_exp e2); (Cond.DSL.not_ cond, conv_exp e3)]) 46 | | SugarProgram.FailExp -> 47 | Exp.Fail 48 | | SugarProgram.FuncCallExp (fid, es) -> 49 | begin 50 | match es with 51 | | [e] -> Exp.App (fid, exp_to_vid e) 52 | | _ -> failwith ("unexpected expession: " ^ SugarProgram.Expr.to_string exp) 53 | end 54 | | SugarProgram.OpExp (_, _, _) -> 55 | Exp.Term (exp_to_cond exp) 56 | | SugarProgram.SingleOpExp (_, _) -> 57 | Exp.Term (exp_to_cond exp) 58 | | SugarProgram.ObjExp _ -> 59 | Exp.Term (exp_to_cond exp) 60 | | _ -> failwith ("unexpected expression: " ^ SugarProgram.Expr.to_string exp) 61 | in 62 | let from_recfun recfun : Program.Func.t = 63 | SugarProgram.to_pfun recfun ~exp:(conv_exp recfun.SugarProgram.exp) in 64 | Program.Program ( 65 | List.map (SugarProgram.recfuns_of sprogram) ~f:from_recfun 66 | ) 67 | end 68 | 69 | let main sprogram = 70 | sprogram 71 | |> ConvMain.main 72 | |> BindValueReduction.main 73 | |> ClosureConv.main 74 | |> AlphaConv.main 75 | |> ElimAssert.main 76 | |> KNormal.main 77 | |> LetNormal.main 78 | |> BetaReduction.main 79 | |> Simplify.main 80 | |> Converter.sprogram_to_program 81 | -------------------------------------------------------------------------------- /src/loader/quallexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | (* A sample input for ocamllex. 3 | Usage: 4 | 1. Run "ocamllex lexer.mll" 5 | 2. Invoke an ocaml interpreter; and run: 6 | #use "lexer.ml";; 7 | main 8 | *) 9 | (* This part will be attached to the beginning of the generated code *) 10 | open Qualparser 11 | open Lexing 12 | 13 | let line_no = ref 1 (* the current line number, used for error reporting *) 14 | let end_of_previousline = ref 0 15 | exception SyntaxError of string 16 | 17 | let next_line lexbuf = 18 | let pos = lexbuf.lex_curr_p in 19 | lexbuf.lex_curr_p <- 20 | { pos with pos_bol = lexbuf.lex_curr_pos; 21 | pos_lnum = pos.pos_lnum + 1 22 | } 23 | (* data type declaration for tokens *) 24 | (* 25 | type token = EQ | NEQ | LEQ | LT | GEQ | GT | PLUS | MINUS | TIMES | LPAREN | RPAREN 26 | | LET | REC| IN | IF | THEN | ELSE | FUNC | INT of int | ID of string | EOF 27 | *) 28 | } 29 | 30 | (* abbreviations *) 31 | let space = [' ' '\t' '\r'] 32 | let newline = ['\n'] 33 | let digit = ['0'-'9'] 34 | let digitnz = ['1'-'9'] 35 | let mark = ['_'] 36 | let lower = ['a'-'z'] 37 | let higher = ['A'-'Z'] 38 | let minus = ['-'] 39 | 40 | (* The main part, defining tokens and the corresponding actions *) 41 | rule token = parse 42 | | space+ { token lexbuf } 43 | | newline 44 | { next_line lexbuf; 45 | token lexbuf} 46 | | "+" {PLUS} 47 | | "-" {MINUS} 48 | | "(*" { comment lexbuf; token lexbuf } 49 | | "*" {TIMES} 50 | | "(" {LPAREN} 51 | | ")" {RPAREN} 52 | | ";" {SEMICOLON} 53 | | "=" {EQ} 54 | | "!=" {NEQ} 55 | | "<>" {NEQ} 56 | | "<=" {LEQ} 57 | | "<" {LT} 58 | | ">=" {GEQ} 59 | | "->" {IMPL} 60 | | ">" {GT} 61 | | "!" {NOT} 62 | | "not" {NOT} 63 | | "0" {INT(0)} 64 | | "&&" {AND} 65 | | "||" {OR} 66 | | digitnz digit* 67 | {let s = Lexing.lexeme lexbuf in INT(int_of_string s)} 68 | (* | minus digitnz digit* 69 | {let s = Lexing.lexeme lexbuf in INT(int_of_string s)} *) 70 | | "v" { NU } 71 | | "V" { NU } 72 | | (lower|higher) (mark|digit|higher|lower)* 73 | { let s = Lexing.lexeme lexbuf in ID(s)} 74 | | eof { EOF } 75 | | _ 76 | { Format.eprintf "unknown token %s in line %d, column %d-%d @." 77 | (Lexing.lexeme lexbuf) 78 | (!line_no) 79 | ((Lexing.lexeme_start lexbuf)- (!end_of_previousline)) 80 | ((Lexing.lexeme_end lexbuf)-(!end_of_previousline)); 81 | failwith "lex error" } 82 | 83 | (* For nested comments. *) 84 | and comment = parse 85 | | "*)" 86 | { () } 87 | | "(*" 88 | { comment lexbuf; comment lexbuf } 89 | | eof 90 | { print_string "Lex error: unterminated comment\n"; 91 | failwith "unterminated comment" } 92 | | _ 93 | { comment lexbuf } 94 | 95 | { 96 | (* This part is added to the end of the generated code *) 97 | (* The following is a piece of code for testing the generated lexical analyzer. *) 98 | (* 99 | let rec readloop lexbuf = 100 | let t = token lexbuf in 101 | if t=EOF then [] 102 | else t::(readloop lexbuf) 103 | *) 104 | 105 | (* main takes a filename, performs a lexical analysis, and 106 | returns the result as a list of tokens. 107 | *) 108 | let read filename = Lexing.from_channel (open_in filename) 109 | let main filename = token (read filename) 110 | } 111 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![CI](https://github.com/hopv/r_type/workflows/CI/badge.svg) 2 | 3 | # `r_type` 4 | 5 | A model-checker for caml programs. 6 | 7 | `r_type` translates caml programs to Horn clauses and feeds them to a Horn clause solver, such as 8 | [hoice][hoice] for instance. 9 | 10 | It supports a subset of caml including higher-order functions, nested recursive calls, integers and booleans. Floats, ADTs, modules... are currently not supported. You can get a sense of the fragment `r_type` supports by looking at [our benchmarks][benchs]. 11 | 12 | # Build 13 | 14 | Make sure you have [opam][opam] installed, ideally switched to the latest stable ocaml compiler (`4.11.1` at the time of writing). `r_type` requires the following opam libraries: 15 | 16 | - `dune.2.8.1` (build only) 17 | - `menhir.20201216` 18 | - `core.v0.14.0` 19 | - `ppx_compare.v0.14.0` 20 | - `ppx_deriving.5.1` 21 | - `ppx_fields_conv.v0.14.1` 22 | - `ppx_hash.v0.14.0` 23 | - `ppx_sexp_conv.v0.14.1` 24 | - `ppx_variants_conv.v0.14.1` 25 | - `re2.v0.14.0` 26 | - `unionFind.20200320` 27 | 28 | So, a complete setup to compile `r_type` looks like 29 | 30 | ```bash 31 | > opam update && opam upgrade 32 | # Switch to 4.11.1... 33 | > opam switch 4.11.1 34 | > eval `opam config env` 35 | # Install relevant packages... 36 | > opam install -y dune.2.8.1 menhir.20201216 core.v0.14.0 ppx_compare.v0.14.0 ppx_deriving.5.1 ppx_fields_conv.v0.14.1 ppx_hash.v0.14.0 ppx_sexp_conv.v0.14.1 ppx_variants_conv.v0.14.1 re2.v0.14.0 unionFind.20200320 37 | ``` 38 | 39 | Then, simply run `dune build` at the root of this repository. The binary will be located at `src/r_type.exe`. 40 | 41 | This should work, but the most up to date build workflow is always the [travis build script][travis script]. 42 | 43 | # Running 44 | 45 | ``` 46 | Usage: r_type [options]* 47 | NB: r_type verifies that function `main` from the input caml 48 | file never fails. Hence, make sure that entry point of your 49 | program is a function called `main`. 50 | Options: 51 | -v verbose output 52 | --effect_analysis [on|true|off|false] (de)activates effect analysis 53 | default 'on' 54 | --infer [on|true|off|false] (de)activates inference (prints the clauses on stdout if off) 55 | default 'on' 56 | --solver command running the horn clause solver, e.g. `hoice` or `z3` 57 | default 'hoice' 58 | ``` 59 | 60 | You will need a Horn clause solver for `r_type` to do anything, such as [hoice][hoice] or [z3][z3]. The default is hoice using the command `hoice`. 61 | 62 | If you want to use z3, or hoice but with a different command, pass the name of the command using `--solver ` when calling `r_type`. 63 | 64 | **NB**: by default, z3 does *not* read from `stdin`, which `r_type` requires. Make sure you pass z3 the `-in` flag: 65 | 66 | ```bash 67 | > rtype --solver "z3 -in" path_to_my_file.ml 68 | ``` 69 | 70 | If you only want to inspect the Horn clauses encoding the correctness of your caml program, run `r_type` with `--infer off`. The clauses will be printed on `stdout`. 71 | 72 | [benchs]: https://github.com/hopv/benchmarks/tree/master/caml/lia (hopv benchmarks) 73 | [travis script]: https://github.com/hopv/r_type/blob/master/.travis.sh (travis build script) 74 | [hoice]: https://github.com/hopv/hoice (hoice repository on github) 75 | [z3]: https://github.com/Z3Prover/z3 (z3 repository on github) 76 | [opam]: https://opam.ocaml.org/doc/Install.html (opam official page) 77 | -------------------------------------------------------------------------------- /src/data/objt.ml: -------------------------------------------------------------------------------- 1 | 2 | open Core 3 | open Sexplib.Std 4 | 5 | type id = Identity.t 6 | [@@deriving eq, ord, sexp, hash] 7 | 8 | module Typedef = struct 9 | type t = 10 | | VarObj of id 11 | | SpecialVar of id 12 | | IntObj of int 13 | | BoolObj of bool 14 | | Array of int list 15 | [@@deriving eq, ord, sexp, variants, hash] 16 | 17 | let to_format obj = 18 | Formatable.text ( 19 | match obj with 20 | | VarObj vid -> Identity.Short.show vid 21 | | SpecialVar vid -> vid 22 | | IntObj i -> string_of_int i 23 | | BoolObj i -> string_of_bool i 24 | | _ -> failwith "unexpected" 25 | ) 26 | end 27 | include Typedef 28 | include Showsexp.Make(Typedef) 29 | include Formatable.Make(Typedef) 30 | 31 | type typing = IntType | BoolType 32 | 33 | let return_vid = "#return" 34 | let return_vid_of _fid = return_vid (* ("#return-" ^ fid) *) 35 | let return_vid_main = return_vid (* "#main-return" *) 36 | 37 | let wrap_to_string vid = Label.strip_wrapper vid 38 | 39 | let mk_var (vid : id) = VarObj vid 40 | let mk_int n = IntObj n 41 | 42 | let mk_nu = SpecialVar "V" 43 | let mk_program_variable = SpecialVar "X" 44 | 45 | let get_vids = function 46 | | VarObj vid -> [vid] 47 | | _ -> [] 48 | 49 | let vids_of = get_vids 50 | 51 | let true_ = BoolObj true 52 | let false_ = BoolObj false 53 | let mk_bool n = if n then true_ else false_ 54 | 55 | let is_truthy = function 56 | | VarObj _ -> false 57 | | IntObj i -> i <> 0 58 | | BoolObj b -> b 59 | | _ -> failwith "unexpected" 60 | 61 | let is_falsey = function 62 | | VarObj _ -> false 63 | | IntObj i -> i = 0 64 | | BoolObj b -> not b 65 | | _ -> failwith "unexpected" 66 | 67 | let is_bool = function 68 | | BoolObj _ -> true 69 | | _ -> false 70 | 71 | let get_bool obj = 72 | if is_truthy obj 73 | then Some true 74 | else if is_falsey obj 75 | then Some false 76 | else None 77 | 78 | let get_int = function 79 | | VarObj _ -> None 80 | | IntObj i -> Some i 81 | | BoolObj b -> Some (if b then 1 else 0) 82 | | _ -> failwith "unexpected" 83 | 84 | let is_var = function 85 | | VarObj _ -> true 86 | | _ -> false 87 | 88 | let int_of = function 89 | | IntObj n -> n 90 | | x -> failwith ("unexpected" ^ to_string x) 91 | 92 | let vid_of = function 93 | | VarObj vid -> Some vid 94 | | _ -> None 95 | 96 | let vid_of_exn = function 97 | | VarObj vid -> vid 98 | | _ -> failwith "unexpected" 99 | 100 | let does_match_vid obj k = 101 | match obj with 102 | | VarObj vid -> String.equal vid k 103 | | SpecialVar vid -> String.equal vid k 104 | | _ -> false 105 | 106 | let subst obj (k, v) = 107 | if does_match_vid obj k then v else obj 108 | 109 | let subst_obj obj (k, v) = 110 | if equal obj k then v else obj 111 | 112 | let string_of = to_string 113 | 114 | let orig_string_of obj = Label.strip_wrapper (string_of obj) 115 | 116 | let string_of_typing = function 117 | | IntType -> "int" 118 | | BoolType -> "bool" 119 | 120 | let type_of _ = IntType 121 | 122 | let is_int = function IntObj _i -> true | _ -> false 123 | 124 | (* let vid_set vid_list = List.sort_uniq String.compare vid_list *) 125 | 126 | module VarSet = Set.Make(String) 127 | 128 | 129 | let get_fv t = 130 | match t with 131 | | VarObj x -> [x] 132 | | SpecialVar _ -> assert false 133 | | IntObj _ 134 | | BoolObj _ 135 | | Array _ -> [] 136 | -------------------------------------------------------------------------------- /src/data/op.ml: -------------------------------------------------------------------------------- 1 | 2 | type t = 3 | Plus 4 | | Minus 5 | | Times 6 | | Div 7 | | Mod 8 | | Eq 9 | | Neq 10 | | Leq 11 | | Lt 12 | | Geq 13 | | Gt 14 | | Not_ 15 | | And_ 16 | | Or_ 17 | | Iff 18 | | Impl 19 | | BtoI 20 | | ItoB 21 | | Forall of Identity.t 22 | | Exists of Identity.t 23 | [@@deriving eq, ord, sexp, hash] 24 | 25 | 26 | 27 | 28 | 29 | 30 | let string_of = function 31 | Plus -> "+" 32 | | Minus -> "-" 33 | | Times -> "*" 34 | | Div -> "/" 35 | | Mod -> "mod" 36 | | Eq -> "=" 37 | | Neq -> "<>" 38 | | Leq -> "<=" 39 | | Lt -> "<" 40 | | Geq -> ">=" 41 | | Gt -> ">" 42 | | Not_ -> "!" 43 | | And_ -> "&&" 44 | | Or_ -> "||" 45 | | Iff -> "<=>" 46 | | Impl -> "==>" 47 | | BtoI -> "btoi" 48 | | ItoB -> "itob" 49 | | Forall v -> "Forall(" ^ Identity.Short.show v ^ ")" 50 | | Exists v -> "Exists(" ^ Identity.Short.show v ^ ")" 51 | 52 | let of_string = function 53 | | "+" -> Some Plus 54 | | "~-" -> Some Minus 55 | | "-" -> Some Minus 56 | | "/" -> Some Div 57 | | "*" -> Some Times 58 | | "mod" -> Some Mod 59 | | "=" -> Some Eq 60 | | "<>" -> Some Neq 61 | | "<=" -> Some Leq 62 | | "<" -> Some Lt 63 | | ">" -> Some Gt 64 | | ">=" -> Some Geq 65 | | "!" -> Some Not_ 66 | | "&&" -> Some And_ 67 | | "||" -> Some Or_ 68 | | "<=>" -> Some Iff 69 | | "==>" -> Some Impl 70 | | "not" -> Some Not_ 71 | | _ -> None 72 | 73 | let is_value_bool = function 74 | | Eq -> true 75 | | Neq -> true 76 | | Leq -> true 77 | | Lt -> true 78 | | Geq -> true 79 | | Gt -> true 80 | | Not_ -> true 81 | | And_ -> true 82 | | Or_ -> true 83 | | Iff -> true 84 | | Impl -> true 85 | | ItoB -> true 86 | | Forall _ -> true 87 | | Exists _ -> true 88 | | _ -> false 89 | 90 | let is_arg_bool = function 91 | | Not_ -> true 92 | | And_ -> true 93 | | Or_ -> true 94 | | Iff -> true 95 | | Impl -> true 96 | | BtoI -> true 97 | | Forall _ -> true 98 | | Exists _ -> true 99 | | _ -> false 100 | 101 | let is_arg_polymorphic = function 102 | | Eq -> true 103 | | _ -> false 104 | 105 | let is_quantifier = function 106 | | Forall _ -> true 107 | | Exists _ -> true 108 | | _ -> false 109 | 110 | let type_of op = 111 | let bool_to_op bl = if bl then Objt.BoolType else Objt.IntType in 112 | (is_arg_bool op |> bool_to_op, is_value_bool op |> bool_to_op) 113 | 114 | let equal_quantifier (self : t) (another : t) : bool = 115 | match self with 116 | | Forall _ -> (match another with | Forall _ -> true | _ -> false) 117 | | Exists _ -> (match another with | Exists _ -> true | _ -> false) 118 | | _ -> false 119 | 120 | let forall v = Forall v 121 | let exists v = Exists v 122 | 123 | let quantifier_label = function 124 | | Forall _ -> "Forall" 125 | | Exists _ -> "Exists" 126 | | _ -> "" 127 | 128 | 129 | 130 | module ToSmt2 = struct 131 | 132 | let op_strings op = match op with 133 | | Plus -> [ "+" ] 134 | | Minus -> [ "-" ] 135 | | Times -> [ "*" ] 136 | | Div -> [ "div" ] 137 | | Mod -> [ "mod" ] 138 | | Eq -> [ "=" ] 139 | | Neq -> [ "not" ; "=" ] 140 | | Leq -> [ "<=" ] 141 | | Lt -> [ "<" ] 142 | | Geq -> [ ">=" ] 143 | | Gt -> [ ">" ] 144 | | Not_ -> [ "not" ] 145 | | And_ -> [ "and" ] 146 | | Or_ -> [ "or" ] 147 | | Iff -> [ "=" ] 148 | | Impl -> [ "=>" ] 149 | | ItoB -> [ "not" ; "= 0" ] 150 | | op -> string_of op |> Format.sprintf "unsupported operator %s" |> failwith 151 | 152 | end 153 | -------------------------------------------------------------------------------- /src/loader/fmllexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | (* A sample input for ocamllex. 3 | Usage: 4 | 1. Run "ocamllex lexer.mll" 5 | 2. Invoke an ocaml interpreter; and run: 6 | #use "lexer.ml";; 7 | main 8 | *) 9 | (* This part will be attached to the beginning of the generated code *) 10 | open Fmlparser 11 | open Lexing 12 | 13 | let line_no = ref 1 (* the current line number, used for error reporting *) 14 | let end_of_previousline = ref 0 15 | exception SyntaxError of string 16 | 17 | let next_line lexbuf = 18 | let pos = lexbuf.lex_curr_p in 19 | lexbuf.lex_curr_p <- 20 | { pos with pos_bol = lexbuf.lex_curr_pos; 21 | pos_lnum = pos.pos_lnum + 1 22 | } 23 | (* data type declaration for tokens *) 24 | (* 25 | type token = EQ | NEQ | LEQ | LT | GEQ | GT | PLUS | MINUS | TIMES | LPAREN | RPAREN 26 | | LET | REC| IN | IF | THEN | ELSE | FUNC | INT of int | ID of string | EOF 27 | *) 28 | } 29 | 30 | (* abbreviations *) 31 | let space = [' ' '\t' '\r'] 32 | let newline = ['\n'] 33 | let digit = ['0'-'9'] 34 | let digitnz = ['1'-'9'] 35 | let mark = ['_'] 36 | let lower = ['a'-'z'] 37 | let higher = ['A'-'Z'] 38 | let minus = ['-'] 39 | 40 | (* The main part, defining tokens and the corresponding actions *) 41 | rule token = parse 42 | | space+ { token lexbuf } 43 | | newline 44 | { next_line lexbuf; 45 | token lexbuf} 46 | | "+" {PLUS} 47 | | "-" {MINUS} 48 | | "*" {TIMES} 49 | | "(" {LPAREN} 50 | | ")" {RPAREN} 51 | | "{" {LBRACE} 52 | | "}" {RBRACE} 53 | | ":" {COLON} 54 | | "=" {EQ} 55 | | "!=" {NEQ} 56 | | "<=" {LEQ} 57 | | "<" {LT} 58 | | ">=" {GEQ} 59 | | "->" {ARROW} 60 | | "==>" {IMPL} 61 | | ">" {GT} 62 | | "0" {INT(0)} 63 | | "&&" {AND} 64 | | "||" {OR} 65 | | "|" {VLINE} 66 | | "let" {LET} 67 | | "rec" {REC} 68 | | "not" {NOT} 69 | | "in" {IN} 70 | | "int" {INTEGER} 71 | | "true" {TRUE} 72 | | "false" {FALSE} 73 | | "if" {IF} 74 | | "then" {THEN} 75 | | "else" {ELSE} 76 | | "assert" {ASSERT} 77 | | "fail" {FAIL} 78 | | "select" {SELECT} 79 | | "when" {WHEN} 80 | | "mod" {MOD} 81 | | digitnz digit* 82 | {let s = Lexing.lexeme lexbuf in INT(int_of_string s)} 83 | | minus digitnz digit* 84 | {let s = Lexing.lexeme lexbuf in INT(int_of_string s)} 85 | | (lower|higher) (mark|digit|higher|lower)* 86 | { let s = Lexing.lexeme lexbuf in ID(s)} 87 | | eof { EOF } 88 | | "(*" { comment lexbuf; token lexbuf } 89 | | _ 90 | { Format.eprintf "unknown token %s in line %d, column %d-%d @." 91 | (Lexing.lexeme lexbuf) 92 | (!line_no) 93 | ((Lexing.lexeme_start lexbuf)- (!end_of_previousline)) 94 | ((Lexing.lexeme_end lexbuf)-(!end_of_previousline)); 95 | failwith "lex error" } 96 | 97 | (* For nested comments. *) 98 | and comment = parse 99 | | "*)" 100 | { () } 101 | | "(*" 102 | { comment lexbuf; comment lexbuf } 103 | | eof 104 | { print_string "Lex error: unterminated comment\n"; 105 | failwith "unterminated comment" } 106 | | _ 107 | { comment lexbuf } 108 | 109 | { 110 | (* This part is added to the end of the generated code *) 111 | (* The following is a piece of code for testing the generated lexical analyzer. *) 112 | (* 113 | let rec readloop lexbuf = 114 | let t = token lexbuf in 115 | if t=EOF then [] 116 | else t::(readloop lexbuf) 117 | *) 118 | 119 | (* main takes a filename, performs a lexical analysis, and 120 | returns the result as a list of tokens. 121 | *) 122 | let read filename = Lexing.from_channel (open_in filename) 123 | let main filename = token (read filename) 124 | } 125 | -------------------------------------------------------------------------------- /src/horn_solver/smtLex.mll: -------------------------------------------------------------------------------- 1 | { 2 | open SmtParse 3 | open Lexing 4 | 5 | let line_no = ref 1 (* the current line number, used for error reporting *) 6 | let end_of_previousline = ref 0 7 | exception SyntaxError of string 8 | 9 | let next_line lexbuf = 10 | let pos = lexbuf.lex_curr_p in 11 | lexbuf.lex_curr_p <- { 12 | pos with 13 | pos_bol = lexbuf.lex_curr_pos ; 14 | pos_lnum = pos.pos_lnum + 1 15 | } 16 | } 17 | 18 | (* abbreviations *) 19 | let space = [' ' '\t' '\r'] 20 | let newline = ['\n'] 21 | let digit = ['0'-'9'] 22 | let digitnz = ['1'-'9'] 23 | let lcase = ['a'-'z'] 24 | let hcase = ['A'-'Z'] 25 | let idlegal = [ 26 | '~' '!' '@' '$' '%' '^' '&' '*' '_' '-' '+' '=' '<' '>' '.' '?' '/' 27 | ] 28 | 29 | (* The main part, defining tokens and the corresponding actions *) 30 | rule token = parse 31 | | newline { 32 | next_line lexbuf ; 33 | token lexbuf 34 | } 35 | 36 | | space+ { token lexbuf } 37 | | ";" { comment lexbuf } 38 | 39 | | "unsat" {UNSAT} 40 | | "sat" {SAT} 41 | | "model" {MODEL} 42 | | "define-fun" {DEFINE} 43 | | "exists" {EXISTS} 44 | | "forall" {FORALL} 45 | | "let" {LET} 46 | 47 | | "Int" {INT} 48 | | "Bool" {BOOL} 49 | 50 | | "(" {OPAREN} 51 | | ")" {CPAREN} 52 | 53 | | "=>" {OP (Lexing.lexeme lexbuf)} 54 | | "and" {OP (Lexing.lexeme lexbuf)} 55 | | "or" {OP (Lexing.lexeme lexbuf)} 56 | | "not" {OP (Lexing.lexeme lexbuf)} 57 | 58 | | "=" {OP (Lexing.lexeme lexbuf)} 59 | | "ite" {OP (Lexing.lexeme lexbuf)} 60 | 61 | | "<=" {OP (Lexing.lexeme lexbuf)} 62 | | "<" {OP (Lexing.lexeme lexbuf)} 63 | | ">=" {OP (Lexing.lexeme lexbuf)} 64 | | ">" {OP (Lexing.lexeme lexbuf)} 65 | 66 | | "+" {OP (Lexing.lexeme lexbuf)} 67 | | "-" {OP (Lexing.lexeme lexbuf)} 68 | | "*" {OP (Lexing.lexeme lexbuf)} 69 | | "/" {OP (Lexing.lexeme lexbuf)} 70 | 71 | | digit+ { CINT (Lexing.lexeme lexbuf) } 72 | | "true" { CBOOL (Lexing.lexeme lexbuf) } 73 | | "false" { CBOOL (Lexing.lexeme lexbuf) } 74 | 75 | | "\"" { dquoted (Buffer.create 17) lexbuf } 76 | | "|" { piped (Buffer.create 17) lexbuf } 77 | | (lcase|hcase) (lcase|hcase|idlegal|digit)* { IDENT (Lexing.lexeme lexbuf) } 78 | | (idlegal) (lcase|hcase|idlegal|digit)+ { IDENT (Lexing.lexeme lexbuf) } 79 | 80 | | eof { EOF } 81 | | _ 82 | { Format.eprintf "unknown token %s in line %d, column %d-%d @." 83 | (Lexing.lexeme lexbuf) 84 | (!line_no) 85 | ((Lexing.lexeme_start lexbuf)- (!end_of_previousline)) 86 | ((Lexing.lexeme_end lexbuf)-(!end_of_previousline)); 87 | failwith "lex error" } 88 | 89 | and comment = parse 90 | | newline { next_line lexbuf ; token lexbuf } 91 | | _ { comment lexbuf } 92 | 93 | and dquoted buf = parse 94 | | "\"" { DQUOTED (Buffer.contents buf) } 95 | | newline { 96 | next_line lexbuf ; 97 | Buffer.add_char buf '\n' ; 98 | dquoted buf lexbuf 99 | } 100 | | [^ '|' ]+ { 101 | Buffer.add_string buf (Lexing.lexeme lexbuf) ; 102 | dquoted buf lexbuf 103 | } 104 | | _ { 105 | raise ( 106 | SyntaxError ( 107 | "Illegal string character: " ^ Lexing.lexeme lexbuf 108 | ) 109 | ) 110 | } 111 | | eof { raise (SyntaxError ("unterminated string")) } 112 | 113 | and piped buf = parse 114 | | "|" { IDENT (Buffer.contents buf) } 115 | | newline { 116 | next_line lexbuf ; 117 | Buffer.add_char buf '\n' ; 118 | piped buf lexbuf 119 | } 120 | | [^ '|' ]+ { 121 | Buffer.add_string buf (Lexing.lexeme lexbuf) ; 122 | piped buf lexbuf 123 | } 124 | | _ { 125 | raise ( 126 | SyntaxError ( 127 | "Illegal piped ident character: " ^ Lexing.lexeme lexbuf 128 | ) 129 | ) 130 | } 131 | | eof { raise (SyntaxError ("unterminated piped ident")) } 132 | 133 | { 134 | let read filename = Lexing.from_channel (open_in filename) 135 | let main filename = token (read filename) 136 | } 137 | -------------------------------------------------------------------------------- /src/loader/optimizeVc.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | let (=) = Poly.(=) 4 | 5 | let not_true t = 6 | match Cond.decomp_hc t with 7 | | _, Cond.Value (Objt.BoolObj true) -> false 8 | | _ -> true 9 | 10 | module RemoveNonRecursiveUnknown = struct 11 | let rec run ?(reports = []) (clauses : Cond.Horn.t) (reduce_multi_impl : bool) : (VcControl.DetectNonRecursiveUnknown.Report.t list * Cond.Horn.t) = 12 | let new_reports = VcControl.DetectNonRecursiveUnknown.run clauses reduce_multi_impl in 13 | match VcControl.DetectNonRecursiveUnknown.Report.select_effective_one new_reports with 14 | | None -> (reports, clauses) 15 | | Some new_one -> 16 | let new_clauses = Cond.Horn.map clauses ~f:(VcControl.DetectNonRecursiveUnknown.Report.apply_to_cond new_one) |> List.concat |> List.map ~f:Cond.simplify_alpha in 17 | let reports = List.map reports ~f:(VcControl.DetectNonRecursiveUnknown.Report.apply_to_report new_one) in 18 | run ~reports:(new_one :: reports) new_clauses reduce_multi_impl 19 | end 20 | 21 | 22 | let rec remove_non_recursive ?(reports = []) (clauses : Cond.Horn.t) (reduce_multi_impl : bool) : (VcControl.DetectNonRecursiveUnknown.Report.t list * Cond.Horn.t) = 23 | let new_reports = VcControl.DetectNonRecursiveUnknown.run clauses reduce_multi_impl in 24 | if new_reports = [] then 25 | reports, clauses 26 | else 27 | let rec apply new_reports (reports,clauses) = 28 | match new_reports with 29 | | [] -> reports, clauses 30 | | (un,conds as new_one)::new_reports' -> 31 | if List.for_all conds ~f:(fun cond -> VcControl.DetectNonRecursiveUnknown.Report.is_not_recursive un cond) then 32 | let new_clauses = Cond.Horn.map clauses ~f:(VcControl.DetectNonRecursiveUnknown.Report.apply_to_cond new_one) |> List.concat |> List.map ~f:Cond.simplify_alpha in 33 | let app = List.map ~f:(VcControl.DetectNonRecursiveUnknown.Report.apply_to_report new_one) in 34 | let reports = app reports in 35 | let new_reports'' = app new_reports' in 36 | apply new_reports'' (new_one :: reports, new_clauses) 37 | else 38 | apply new_reports' (reports, clauses) 39 | in 40 | let new_reports = VcControl.DetectNonRecursiveUnknown.Report.sort_by_count new_reports in 41 | let reports,clauses = apply new_reports (reports,clauses) in 42 | remove_non_recursive ~reports clauses reduce_multi_impl 43 | 44 | let eliminate_unused_conds t = 45 | let fv = Cond.get_fv t in 46 | let body,head = Cond.decomp_hc ~full:true t in 47 | let body = 48 | let may_used t = 49 | match t with 50 | | Cond.Op2(Cond.Value (Objt.VarObj x), Op.Eq, Cond.Value (Objt.IntObj _ | Objt.BoolObj _)) -> 51 | 1 < List.length @@ List.filter fv ~f:([%compare.equal: Identity.t] x) 52 | | _ -> true 53 | in 54 | List.filter body ~f:may_used 55 | in 56 | Cond.compose_hc body head 57 | 58 | 59 | let eliminate_precond_of_safe_fun tyenv pr clauses = 60 | let preds = EffectInfer.assumed_as_true tyenv pr in 61 | let apps = List.concat_map clauses ~f:Cond.get_apps in 62 | let reports = 63 | let f app = 64 | let p = UnknownPredicate.id_of app in 65 | List.exists preds ~f:(Identity.equal p) 66 | in 67 | List.filter ~f apps 68 | in 69 | let clauses = List.fold reports ~init:clauses ~f:(fun clauses report -> Cond.Horn.map clauses ~f:(VcControl.DetectTruthyUnknown.Report.apply_to_cond report)) in 70 | reports, clauses 71 | 72 | 73 | let run (clauses : Cond.Horn.t) (tyenv : Type.Env.t) (pr : Program.t) (do_effect_analysis : bool) : (Cond.Horn.t * Type.Env.t) = 74 | let clauses = List.concat_map ~f:Cond.flatten clauses in 75 | let truthy_reports, clauses = 76 | if do_effect_analysis then 77 | eliminate_precond_of_safe_fun tyenv pr clauses 78 | else 79 | [], clauses 80 | in 81 | let non_recursive_reports = [] in 82 | let tyenv = 83 | let reduced_un_reports = VcControl.ReducedUnknownReport.build truthy_reports non_recursive_reports in 84 | (VcControl.ReducedUnknownReport.remove_reduced_unknowns_from_tyenv reduced_un_reports tyenv) in 85 | clauses, tyenv 86 | -------------------------------------------------------------------------------- /src/horn_solver/parseBase.ml: -------------------------------------------------------------------------------- 1 | open! Lib 2 | 3 | (** A list of variable and type pairs. *) 4 | type args = (string * string) list 5 | 6 | (** An ADT representing a predicate definition's body. *) 7 | type body = 8 | (** A existential quantifier. *) 9 | | EQtf of args * body 10 | (** A universall quantifier. *) 11 | | UQtf of args * body 12 | (** Operator application. *) 13 | | App of string * body list 14 | (** Predicate application. *) 15 | | PApp of string * body list 16 | (** A let-binding. *) 17 | | Let of (string * body) list * body 18 | (** Variable or constant. *) 19 | | Leaf of string 20 | 21 | 22 | let needs_parens = function 23 | | Leaf _ -> false 24 | | _ -> true 25 | 26 | (** Pretty printer for arguments. *) 27 | let fmt_args fmt (args: args) = 28 | Core.List.iter args ~f:( 29 | fun (id, _) -> 30 | Format.fprintf fmt " %s" id 31 | ) 32 | 33 | (** Pretty printer for body, good old ugly recursion. *) 34 | let rec fmt_body fmt: body -> unit = function 35 | | EQtf (args, body) -> 36 | Format.fprintf fmt "Exists (%a). %a" fmt_args args fmt_body body 37 | | UQtf (args, body) -> 38 | Format.fprintf fmt "Forall (%a). %a" fmt_args args fmt_body body 39 | | App ("and", arg :: []) -> Format.fprintf fmt "%a" fmt_body arg 40 | | App ("or", arg :: []) -> Format.fprintf fmt "%a" fmt_body arg 41 | | App (op, arg :: []) -> 42 | if needs_parens arg then 43 | Format.fprintf fmt "(%s (%a))" op fmt_body arg 44 | else 45 | Format.fprintf fmt "(%s %a)" op fmt_body arg 46 | | App ("ite", c :: t :: e :: []) -> 47 | Format.fprintf fmt "if %a then %a else %a" fmt_body c fmt_body t fmt_body e 48 | | App (op, args) -> Core.List.fold_left args ~init:true ~f:( 49 | fun is_first arg -> 50 | let parens = needs_parens arg in 51 | ( if is_first then ( 52 | if parens then 53 | Format.fprintf fmt "(@ @[%a@]@ )" fmt_body arg 54 | else 55 | Format.fprintf fmt "%a" fmt_body arg 56 | ) else ( 57 | if parens then 58 | Format.fprintf fmt " %s (@ @[%a@]@ )" op fmt_body arg 59 | else 60 | Format.fprintf fmt " %s %a" op fmt_body arg 61 | ) 62 | ) ; 63 | false 64 | ) |> ignore 65 | | PApp (pred, args) -> 66 | Format.fprintf fmt "@[(%s" pred ; 67 | Core.List.iter args ~f:( 68 | fun arg -> 69 | let (opn, cls) = if needs_parens arg then ("(", ")") else ("", "") in 70 | Format.fprintf fmt "@ @[%s%a%s@]" opn fmt_body arg cls 71 | ) ; 72 | Format.fprintf fmt "@ )@]" 73 | | Let ((id, expr) :: [], body) -> 74 | Format.fprintf fmt "let %s =@ @[%a@]@ in@ %a" id fmt_body expr fmt_body body 75 | | Let (bindings, _body) -> 76 | Format.fprintf fmt "@[let (@ " ; 77 | Core.List.fold_left bindings ~init:true ~f:( 78 | fun is_first (id, _) -> 79 | ( if is_first then 80 | Format.fprintf fmt " %s" id 81 | else 82 | Format.fprintf fmt ",@ %s" id 83 | ) ; 84 | false 85 | ) |> ignore ; 86 | Format.fprintf fmt "@ ) = (@ " ; 87 | Core.List.fold_left bindings ~init:true ~f:( 88 | fun is_first (_, expr) -> 89 | ( if is_first then 90 | Format.fprintf fmt " %a" fmt_body expr 91 | else 92 | Format.fprintf fmt ",@ %a" fmt_body expr 93 | ) ; 94 | false 95 | ) |> ignore ; 96 | Format.fprintf fmt "@ ) in@ @]" 97 | | Leaf s -> Format.fprintf fmt "%s" s 98 | 99 | (** A model maps predicate identifiers to optional definitions. *) 100 | type model = (string * (args * body)) list 101 | 102 | (** Pretty printer for a predicate definition. *) 103 | let fmt_def fmt (name, (args, body)) = 104 | Format.fprintf fmt "let %s%a =@ @[%a@]" 105 | name fmt_args args fmt_body body 106 | 107 | (** Result of parsing the solver's output. *) 108 | type parse = 109 | | Sat 110 | | Unsat 111 | | Error of string 112 | | Model of model 113 | | None 114 | 115 | (** String description of a parse result. *) 116 | let desc_of = function 117 | | Sat -> "sat" 118 | | Unsat -> "unsat" 119 | | Error _ -> "error" 120 | | Model _ -> "model" 121 | | None -> "nothing" 122 | -------------------------------------------------------------------------------- /src/loader/verificationCondition.ml: -------------------------------------------------------------------------------- 1 | open Program 2 | open Core 3 | 4 | exception ConvertError 5 | 6 | type t = Cond.t 7 | module RefType = Type.RefType 8 | 9 | let fold_exn ~f = function 10 | | (x :: xs) -> List.fold xs ~f ~init:x 11 | | _ -> failwith "unexpected" 12 | 13 | let make_type tyenv term condition = 14 | if Cond.is_var term 15 | then 16 | let vtype = Type.Env.find_exn tyenv (Cond.vid_exn term) in 17 | if Type.RefType.is_base vtype 18 | then Type.RefType.from_condition ~f:condition 19 | else vtype 20 | else Type.RefType.from_condition ~f:condition 21 | 22 | let rec gen tyenv exp : Cond.t * Type.Extended.t = 23 | try 24 | begin 25 | match exp with 26 | (* | Exp.Term term when Cond.is_var term -> (Cond.true_, Type.T.(Cond.true_ ==> Type.Env.find_exn tyenv (Cond.vid_exn term))) *) 27 | | Exp.Term term -> 28 | (Cond.true_, Type.T.(Cond.true_ ==> make_type tyenv term (fun v -> Cond.T.(var v == term)))) 29 | | Exp.Fail -> 30 | (* Logger.debug "fail"; 31 | Type.Env.log tyenv; 32 | Cond.log (Type.Env.denote tyenv); *) 33 | (Cond.T.(Type.Env.denote tyenv ==> false_), Type.lift Type.RefType.top) 34 | | Exp.Branch choices -> 35 | let iter (cond, exp) = 36 | let (const, ty) = gen Type.Env.T.(tyenv @<< from_condition cond) exp in 37 | (const, Type.T.(cond ==>& ty)) 38 | in 39 | let (constraints, types) = List.map choices ~f:iter |> List.unzip in 40 | (fold_exn constraints ~f:Cond.and_, fold_exn types ~f:Type.and_) 41 | | Exp.Let_ (vid, exp1, exp2) -> 42 | (match exp1 with 43 | | Exp.Term term -> 44 | let term_type = make_type tyenv term (fun v -> Cond.T.(var v == term)) in 45 | let (constraint_, new_type) = gen Type.Env.T.(tyenv @<< from_map (vid, term_type)) exp2 in 46 | (constraint_, Type.T.(Cond.T.(var vid == term) ==>& new_type)) 47 | | Exp.App (vid1, vid2) -> 48 | let fun_type = Type.Env.find_exn tyenv vid1 in 49 | let arg_type = Type.Env.find_exn tyenv vid2 in 50 | let fun_type_arg = Type.RefType.arg fun_type in 51 | let rtn_type = 52 | let fun_type_rtn = Type.RefType.rtn fun_type in 53 | let fun_type_vid = Type.RefType.vid fun_type in 54 | Type.RefType.subst fun_type_rtn fun_type_vid vid2 in 55 | let (constraint1, new_type) = gen Type.Env.T.(tyenv @<< from_map (vid, rtn_type)) exp2 in 56 | let new_type' = Type.T.(Type.RefType.denote vid rtn_type ==>& new_type) in 57 | let constraint2 = 58 | let arg_type = Type.RefType.subst_nu arg_type vid2 in 59 | let fun_type_arg = Type.RefType.subst_nu fun_type_arg vid2 in 60 | Cond.Horn.hornize (Type.Ord.denote tyenv (Type.lift arg_type, fun_type_arg)) in 61 | (Cond.T.(constraint1 && constraint2), new_type') 62 | | Exp.Fail -> 63 | (Cond.T.(Type.Env.denote tyenv ==> false_), Type.lift Type.RefType.top) 64 | | _ -> failwith "unexpected" 65 | ) 66 | | _ -> failwith "illigal pattern exp" 67 | end 68 | with 69 | | e -> Exn.reraise e "verification condition calculation failed" 70 | 71 | let vc tyenv (Program (fs)) = 72 | let vc_f ({ Func.name ; Func.args ; Func.exp ; _ } : Func.t) = 73 | let ftype = Type.Env.find_exn tyenv name in 74 | let var_types = 75 | let rec to_list xs t = 76 | match xs with 77 | [] -> [] 78 | | x :: xs' -> 79 | match t with 80 | Type.RefType.Func (v, arg_type, rtn_type) -> (x, arg_type) :: to_list xs' (Type.RefType.subst rtn_type v x) 81 | | _ -> (x, t) :: [] 82 | in to_list args ftype 83 | in 84 | let tyenv' = List.fold var_types ~init:tyenv ~f:(fun tyenv tuple -> Type.Env.T.(tyenv @<< from_map tuple)) in 85 | let (cond, exty) = gen tyenv' exp in 86 | let exty' = List.fold var_types ~init:exty ~f:(fun acc (vid, ty) -> Type.T.(Type.RefType.denote vid ty ==>& acc)) in 87 | let rtn_type_expected = 88 | let rec get_rtn_type xs t = 89 | match xs with 90 | [] -> t 91 | | x :: xs' -> 92 | match t with 93 | Type.RefType.Func (v, _arg_type, rtn_type) -> get_rtn_type xs' (Type.RefType.subst rtn_type v x) 94 | | _ -> t 95 | in get_rtn_type args ftype 96 | in 97 | Cond.T.(cond && Cond.Horn.hornize (Type.Ord.denote tyenv (exty', rtn_type_expected))) 98 | in 99 | List.fold fs ~init:Cond.true_ ~f:(fun cond f -> Cond.T.(cond && vc_f f)) 100 | 101 | let main tyenv program = vc tyenv program 102 | -------------------------------------------------------------------------------- /src/data/simpleType.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Sexplib.Std 3 | 4 | module Essential = struct 5 | (* simple type with top type *) 6 | type t = Func of t * t | Int_ | Bool_ | Top | Var of Identity.t 7 | [@@deriving sexp, variants, eq, ord, hash] 8 | 9 | let multiple_func arg_types rtn_type = 10 | List.fold_right arg_types ~f:func ~init:rtn_type 11 | 12 | let is_simple = function Int_ | Bool_ | Top -> true | _ -> false 13 | 14 | let rec to_string (self : t) : string = 15 | match self with 16 | | Func (t1, t2) -> "(" ^ to_string t1 ^ " -> " ^ to_string t2 ^ ")" 17 | | Int_ -> "int" 18 | | Bool_ -> "bool" 19 | | Top -> "top" 20 | | Var vid -> vid 21 | 22 | end 23 | include Essential 24 | 25 | module L = Label.Make(struct let label = "simple-type" end) 26 | let gen_var ?(suffix = "") ?(prefix = "") () = Var (prefix ^ L.gen () ^ suffix) 27 | 28 | module Env = struct 29 | (* mapping of program variables to simple types *) 30 | include Identity.Map 31 | type tt = Essential.t t 32 | 33 | let to_string el = 34 | "\n" ^ List.fold (to_alist el) ~init:"" ~f:(fun str (key, data) -> 35 | key ^ ": " ^ Essential.to_string data ^ "\n" ^ str) 36 | let cons x (key, data) = 37 | match add x ~key ~data with 38 | | `Ok x -> x 39 | | `Duplicate -> x 40 | let cons_int x key = cons x (key, Int_) 41 | module T = struct 42 | let (%<<) (x : tt) (key, data) = 43 | match add x ~key ~data with 44 | | `Ok x -> x 45 | | `Duplicate -> x 46 | end 47 | 48 | let find_exn (self : 'a t) (key : Identity.t) : 'a = 49 | try find_exn self key with 50 | | e -> failwith ("Error searching for " ^ key ^ " (" ^ (Exn.to_string e) ^ ")") 51 | end 52 | 53 | module Subst = struct 54 | (* mapping of type variables to simple types *) 55 | include Identity.Map 56 | type tt = Essential.t t 57 | 58 | let to_string el = 59 | "\n" ^ List.fold (to_alist el) ~init:"" ~f:(fun str (key, data) -> 60 | key ^ ": " ^ Essential.to_string data ^ "\n" ^ str) 61 | 62 | let find_or_fallback tysubst key = 63 | match find tysubst key with 64 | | Some ty -> ty 65 | | None -> Int_ (* fallback top type to int type *) 66 | 67 | let find_or_var tysubst key = 68 | match find tysubst key with 69 | | Some ty -> ty 70 | | None -> Var key 71 | 72 | let rec assoc tysubst ty = 73 | let find_and_dig key = match find tysubst key with 74 | | Some ty -> assoc tysubst ty 75 | | None -> Var key in 76 | match ty with 77 | | Var vid -> find_and_dig vid 78 | | Func (t1, t2) -> Func (assoc tysubst t1, assoc tysubst t2) 79 | | ty -> ty 80 | 81 | let add tysubst ~key ~data = 82 | match data with 83 | | Var vid when String.equal vid key -> tysubst 84 | | _ -> 85 | match add tysubst ~key ~data with 86 | | `Ok tysubst -> tysubst 87 | | `Duplicate -> assert false 88 | 89 | let resolve (tyenv : Env.tt) tysubst = 90 | let assoc_or_fallback tysubst ty = 91 | let rec fallback_var = function 92 | | Var _vid -> Int_ 93 | | Func (t1, t2) -> 94 | Func (fallback_var t1, fallback_var t2) 95 | | x -> x in 96 | fallback_var (assoc tysubst ty) in 97 | Env.map tyenv ~f:(assoc_or_fallback (tysubst)) 98 | 99 | module T = struct 100 | let (%<<) (x : tt) (key, data) = add x ~key ~data 101 | end 102 | end 103 | 104 | module Relation = struct 105 | type t = Essential.t list list 106 | [@@deriving sexp, eq, ord, hash] 107 | 108 | let empty = [] 109 | let bind vid ty = [Var vid; ty] 110 | 111 | module T = struct 112 | let (==) x y = [x; y] 113 | 114 | let (%<<) (x : t) y = y :: x 115 | 116 | let var_ v = Var v 117 | end 118 | 119 | let to_string el = 120 | let show_rel tys = List.fold tys ~init:"{" ~f:(fun str ty -> str ^ Essential.to_string ty ^ "|") ^ "}" in 121 | "\n" ^ List.fold el ~init:"" ~f:(fun str tys -> show_rel tys ^ "\n" ^ str) 122 | 123 | let to_subst (tyrel : t) = 124 | let ignore_top elem = List.filter elem ~f:(function Top -> false | _ -> true) in 125 | let rec (%%) (tysubst : Subst.tt) (elem : Essential.t list) = 126 | match elem with 127 | | [] -> tysubst 128 | | _ :: [] -> tysubst 129 | | t1 :: t2 :: tys -> 130 | match (Subst.assoc tysubst t1, Subst.assoc tysubst t2) with 131 | | (t1, t2) when Essential.equal t1 t2 -> tysubst %% (t2 :: tys) 132 | | (Func (a1, a2), Func (b1, b2)) -> 133 | tysubst %% T.(a1 == b1) %% T.(a2 == b2) %% (Func (b1, b2) :: tys) 134 | | (Var tv, ty) -> 135 | Subst.T.(tysubst %<< (tv, ty)) %% (ty :: tys) 136 | | (ty, Var tv) -> 137 | Subst.T.(tysubst %<< (tv, ty)) %% (ty :: tys) 138 | | (t1, t2) -> 139 | failwith ("Unsatisfiable type constraints. (" ^ Essential.to_string t1 ^ " = " ^ Essential.to_string t2 ^ ")") 140 | in List.fold (tyrel) ~init:Subst.empty ~f:(fun tysubst elem -> tysubst %% (ignore_top elem)) 141 | 142 | let unify (tyenv : Env.tt) (tyrel : t) = 143 | try Subst.resolve tyenv (to_subst tyrel) with 144 | | e -> raise e 145 | end 146 | -------------------------------------------------------------------------------- /src/data/bitVector.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | module Chunk = struct 4 | open Int63 5 | type t = Int63.t 6 | let empty = zero 7 | let get t i = bit_and t (shift_left one i) <> zero 8 | let set t i v = 9 | if v then bit_or t (shift_left one i) 10 | else bit_and t (bit_xor minus_one (shift_left one i)) 11 | 12 | let mul (self : t) (another : t) = bit_and self another 13 | let rev (self : t) = bit_not self 14 | let nonzero (self : t) = self <> zero 15 | let equal (self : t) (another : t) = self = another 16 | 17 | let count_bit (self : t) : int = 18 | let (%&) x y = bit_and x y in 19 | let count32 (i : t) : t = 20 | let i = i - (shift_right_logical i 1 %& of_int 0x55555555) in 21 | let i = (i %& of_int 0x33333333) + (shift_right_logical i 2 %& of_int 0x33333333) in 22 | let i = (i + shift_right_logical i 4) %& of_int 0x0f0f0f0f in 23 | let i = i + shift_right_logical i 8 in 24 | let i = i + shift_right_logical i 16 in 25 | i %& of_int 0x3f 26 | in 27 | Option.value_exn ( 28 | to_int ( 29 | count32 (shift_right_logical self 32) 30 | + count32 (self %& of_int 0xffffffff) 31 | ) 32 | ) 33 | end 34 | 35 | type t = { 36 | mutable length: int; 37 | mutable data: Int63.t Array.t; 38 | } 39 | [@@deriving fields, sexp] 40 | 41 | let chunk_length = 62 42 | let chunk_index i = i / chunk_length 43 | let index i = i mod chunk_length 44 | 45 | let create length = 46 | Fields.create length (Array.create ~len:(1 + (length / chunk_length)) Int63.zero) 47 | 48 | let get (self : t) i = 49 | Chunk.get self.data.(chunk_index i) (index i) 50 | 51 | let set (self : t) i v = 52 | let chunk = (chunk_index i) in 53 | self.data.(chunk) <- Chunk.set self.data.(chunk) (index i) v 54 | 55 | let mul (self : t) (another : t) : t = 56 | let len = if self.length > another.length then another.length else self.length in 57 | let bv = create len in 58 | let intrange = List.range 0 (chunk_index (len - 1) + 1) in 59 | let () = List.iter intrange ~f:(fun i -> 60 | bv.data.(i) <- Chunk.mul self.data.(i) another.data.(i) 61 | ) in 62 | bv 63 | 64 | let rev (self : t) : t = 65 | let bv = create self.length in 66 | let intrange = List.range 0 (chunk_index (self.length - 1) + 1) in 67 | let () = List.iter intrange ~f:(fun i -> 68 | bv.data.(i) <- Chunk.rev self.data.(i) 69 | ) in 70 | bv 71 | 72 | let nonzero (self : t) : bool = 73 | let max = chunk_index (self.length - 1) in 74 | let rec loop i = 75 | if i >= max then false 76 | else if Chunk.nonzero self.data.(i) then true 77 | else loop (i + 1) 78 | in loop 0 79 | 80 | let equal (self : t) (another : t) : bool = 81 | if self.length <> another.length then false 82 | else 83 | let max = chunk_index (self.length - 1) in 84 | let rec loop i = 85 | if i >= max then false 86 | else if Chunk.equal self.data.(i) another.data.(i) then loop (i + 1) 87 | else loop (i + 1) 88 | in loop 0 89 | 90 | let expand (self : t) amount = 91 | let append_chunk_size = chunk_index (self.length + amount) - chunk_index self.length in 92 | let () = self.length <- self.length + amount in 93 | if append_chunk_size > 0 94 | then self.data <- Array.append self.data (Array.create ~len:append_chunk_size Int63.zero) 95 | else () 96 | 97 | let foldi (self : t) ~init ~f = 98 | let intrange = List.range 0 self.length in 99 | List.fold intrange ~init ~f:(fun acc i -> 100 | f i acc (get self i) 101 | ) 102 | 103 | let iteri (self : t) ~f = 104 | let intrange = List.range 0 self.length in 105 | List.iteri intrange ~f:(fun acc i -> 106 | f i (get self i) 107 | ) 108 | 109 | let count_bit (self : t) : int = 110 | let intrange = List.range 0 (chunk_index (self.length - 1) + 1) in 111 | List.fold intrange ~init:0 ~f:(fun acc i -> 112 | acc + Chunk.count_bit self.data.(i) 113 | ) 114 | 115 | let rec shift (self : t) amount : t = 116 | let el = create (self.length + amount) in 117 | let () = iteri self ~f:(fun i v -> 118 | set el (i + amount) v 119 | ) in 120 | el 121 | 122 | let bor (self : t) (another : t) : t = 123 | let len = if self.length > another.length then self.length else another.length in 124 | let el = create len in 125 | let sclen = chunk_index self.length in 126 | let aclen = chunk_index another.length in 127 | let new_data = Array.mapi el.data ~f:(fun i _ -> 128 | let sd = if i > sclen then Int63.zero else self.data.(i) in 129 | let ad = if i > aclen then Int63.zero else another.data.(i) in 130 | Int63.bit_or sd ad 131 | ) in 132 | { length = len; data = new_data; } 133 | 134 | let fold (self : t) ~init ~f = 135 | let rec loop acc i = 136 | if i < self.length 137 | then loop (f acc (get self i)) (i + 1) 138 | else acc 139 | in loop init 0 140 | 141 | let sexp_of_t self = 142 | Array.sexp_of_t Bool.sexp_of_t 143 | (Array.init self.length ~f:(fun i -> get self i)) 144 | 145 | let t_of_sexp sexp = 146 | let a = Array.t_of_sexp Bool.t_of_sexp sexp in 147 | let t = create (Array.length a) in 148 | Array.iteri a ~f:(fun i v -> set t i v); 149 | t 150 | 151 | let hash self : int = Int63.to_int_exn (Int63.rem (Array.get self.data 0) (Int63.of_int Int.max_value)) 152 | let compare self other = 153 | if self.length <> other.length 154 | then Int.compare self.length other.length 155 | else List.fold (List.range 0 (1 + chunk_index self.length) |> List.rev) ~init:0 ~f:(fun acc i -> 156 | if acc = 0 then Int63.compare (Array.get self.data i) (Array.get other.data i) else acc 157 | ) 158 | -------------------------------------------------------------------------------- /src/common/conf.ml: -------------------------------------------------------------------------------- 1 | (** Settings of the run. *) 2 | 3 | open Core 4 | 5 | (** Effect analysis flag. *) 6 | let effect_analysis = ref true 7 | 8 | (** Whether or not to run the solver. *) 9 | let run_solver = ref true 10 | 11 | (** Command and options running the solver. *) 12 | let clause_solver = ref [ "hoice" ] 13 | (** String version of `clause_solver`. *) 14 | let clause_solver_str () = 15 | String.concat ~sep:" " ! clause_solver 16 | 17 | (** Caml file we're analyzing. *) 18 | let ml_file = ref None 19 | 20 | (** Verbose flag. *) 21 | let verb = ref false 22 | 23 | 24 | (** CLAP stuff. *) 25 | module Clap = struct 26 | 27 | open Core 28 | open Lib 29 | 30 | type 'a parse_res = ('a, (string * string)) Res.res 31 | 32 | let parse_res_chain msg = function 33 | | Res.Ok res -> Res.Ok res 34 | | Res.Err (arg, msg') -> Res.Err ( 35 | arg, Format.sprintf "%s\n%s" msg msg' 36 | ) 37 | 38 | let is_okay = function 39 | | Res.Ok _ -> true 40 | | _ -> false 41 | 42 | let res_map f = function 43 | | Res.Ok res -> Res.Ok (f res) 44 | | Res.Err err -> Res.Err err 45 | 46 | let bool_to_str = function 47 | | true -> "on" 48 | | false -> "off" 49 | let bool_format = "[on|true|off|false]" 50 | let bool_validator = function 51 | | "on" | "true" -> Res.Ok true 52 | | "off" | "false" -> Res.Ok false 53 | | arg -> Res.Err ( 54 | arg, sprintf "expected boolean argument `%s`" bool_format 55 | ) 56 | 57 | (* Nullary arguments (flags). *) 58 | let n_args = [ 59 | ( "-v", ("verbose output", fun () -> verb := true) ) 60 | ] 61 | 62 | (* Unary arguments (options). *) 63 | let u_args = [ 64 | ( "--effect_analysis", 65 | "(de)activates effect analysis", 66 | bool_format, 67 | bool_to_str ! effect_analysis, 68 | fun arg -> bool_validator arg |> res_map ( 69 | fun b -> effect_analysis := b 70 | ) 71 | ) ; 72 | ( "--infer", 73 | "(de)activates inference (prints the clauses on stdout if off)", 74 | bool_format, 75 | bool_to_str ! run_solver, 76 | fun arg -> bool_validator arg |> res_map ( 77 | fun b -> run_solver := b 78 | ) 79 | ) ; 80 | ( "--solver", 81 | "command running the horn clause solver, e.g. `hoice` or `z3`", 82 | "", 83 | clause_solver_str (), 84 | fun arg -> 85 | clause_solver := ( 86 | let split = String.split_on_chars arg ~on:[ ' ' ; '\t' ; '\r' ] in 87 | List.fold_left split ~init:[] ~f:( 88 | fun acc s -> 89 | let s = String.strip s in 90 | if not (String.is_empty s) then ( 91 | (* Format.printf "%s@." s ; *) 92 | s :: acc 93 | ) else acc 94 | ) 95 | |> List.rev 96 | ) ; 97 | Res.ok () 98 | ) ; 99 | ] 100 | 101 | let help_format_len = 30 102 | 103 | let print_help () = 104 | Format.printf "\ 105 | Usage: r_type [options]* @.\ 106 | NB: r_type verifies that function `main` from the input caml@. \ 107 | file never fails. Hence, make sure that entry point of your@. \ 108 | program is a function called `main`.@.\ 109 | Options:@.\ 110 | " ; 111 | List.iter n_args ~f:( 112 | fun (opt, (desc, _)) -> 113 | Format.printf 114 | " @[%-20s %-20s %s@]@." (Format.sprintf " %s" opt) "" desc 115 | ) ; 116 | List.iter u_args ~f:( 117 | fun (opt, desc, fmt, default, _) -> 118 | Format.printf 119 | " @[%-20s %-20s %s@ default '%s'@]@." opt fmt desc default 120 | ) ; 121 | () 122 | 123 | 124 | let try_clap = function 125 | | Res.Ok res -> res 126 | | Res.Err (arg, msg) -> ( 127 | print_help () ; 128 | Format.printf "@.\ 129 | Error during command-line argument parsing on '%s':@. %s\ 130 | " arg msg ; 131 | exit 2 132 | ) 133 | 134 | let run () = 135 | let first_is (expected: string) ((got, _): string * 'a): bool = String.equal expected got in 136 | 137 | let rec loop = function 138 | | "-h" :: _tail | "--help" :: _tail -> ( 139 | print_help () ; 140 | exit 0 141 | ) 142 | 143 | | [ file ] -> ml_file := Some file ; Res.Ok () 144 | 145 | (* This case is actually necessarily an error **for now**. The error 146 | will be caught after, when checking that the file is not `None. *) 147 | | [] -> Res.Ok () 148 | 149 | | arg :: value :: tail -> ( 150 | match List.find n_args ~f:(first_is arg) with 151 | | Some (_, (_, action)) -> ( 152 | action (); 153 | value :: tail |> loop 154 | ) 155 | | None -> ( 156 | match List.find u_args ~f:(fun (opt, _, _, _, _) -> String.equal opt arg) with 157 | | Some (_opt, _, _, _, action) -> ( 158 | let res = 159 | action value |> parse_res_chain ( 160 | sprintf "on option '%s'" arg 161 | ) 162 | in 163 | if is_okay res then loop tail else res 164 | ) 165 | | None -> Res.Err (arg, "unknown option") 166 | ) 167 | ) 168 | in 169 | 170 | let argv = Sys.get_argv () in 171 | let res = 172 | Array.sub argv ~pos:1 ~len:(Array.length argv - 1) 173 | |> Array.to_list |> loop 174 | in 175 | ( if is_okay res then match ! ml_file with 176 | | Some f -> Res.Ok f 177 | | None -> Res.Err ( 178 | "", "expected path to caml file, found nothing" 179 | ) 180 | else res |> res_map (fun _ -> "unused") 181 | ) |> try_clap 182 | 183 | 184 | end 185 | 186 | 187 | 188 | (** Runs clap and initializes the configuration. *) 189 | let init () = 190 | Sys.catch_break true ; 191 | Clap.run () 192 | -------------------------------------------------------------------------------- /src/horn_solver/solver.ml: -------------------------------------------------------------------------------- 1 | (** Runs a solver to find a solution for some Horn clauses. *) 2 | 3 | open Lib 4 | 5 | (** Solver's pid. *) 6 | let solver_pid = ref None 7 | (** Solver's stdout. *) 8 | let stdout = ref None 9 | (** Solver's stderr. *) 10 | let stderr = ref None 11 | (** Solver's stdin. *) 12 | let stdin: Format.formatter option ref = ref None 13 | 14 | let rec print_stderr () = try ( 15 | match ! stderr with 16 | | None -> () 17 | | Some stderr -> 18 | Format.printf "%s@." (input_line stderr) ; 19 | print_stderr () 20 | ) with _ -> () 21 | let rec print_stdout () = try ( 22 | match ! stdout with 23 | | None -> () 24 | | Some stdout -> 25 | Format.printf "%s@." (input_line stdout) ; 26 | print_stdout () 27 | ) with _ -> () 28 | 29 | 30 | (** Kills the solver if any. *) 31 | let kill () = (fun () -> 32 | match ! solver_pid with 33 | | Some pid -> Unix.kill pid 9 34 | | _ -> () 35 | ) |> sanitize "while killing horn clause solver" 36 | 37 | 38 | (** Signal handler that kills the solver. *) 39 | let kill_handle = Sys.Signal_handle( 40 | fun _ -> kill () |> Res.unwrap "while killing solver" 41 | ) 42 | 43 | 44 | (** Spawns the solver. *) 45 | let spawn () = (fun () -> 46 | Sys.set_signal Sys.sigalrm kill_handle ; 47 | Sys.set_signal Sys.sigint kill_handle ; 48 | Sys.set_signal Sys.sigquit kill_handle ; 49 | Sys.set_signal Sys.sigterm kill_handle ; 50 | Sys.set_signal Sys.sigpipe kill_handle ; 51 | 52 | (* Initialize pipes. *) 53 | let ( 54 | (solver_stdin_in, solver_stdin_out ), 55 | (solver_stdout_in, solver_stdout_out), 56 | (solver_stderr_in, solver_stderr_out) 57 | ) = ( Unix.pipe (), Unix.pipe (), Unix.pipe () ) 58 | in 59 | (* Spawn solver. *) 60 | let pid = 61 | match ! Conf.clause_solver with 62 | | (bin :: _) as cmd -> 63 | Unix.create_process 64 | bin 65 | (cmd |> Array.of_list) 66 | solver_stdin_in 67 | solver_stdout_out 68 | solver_stderr_out 69 | | [] -> Failure "empty solver command" |> raise 70 | in 71 | (* Close useless pipes. *) 72 | Unix.close solver_stdin_in ; 73 | Unix.close solver_stdout_out ; 74 | Unix.close solver_stderr_out ; 75 | 76 | (* Remember pid. *) 77 | solver_pid := Some pid ; 78 | stdout := Some ( 79 | Unix.in_channel_of_descr solver_stdout_in 80 | ) ; 81 | stderr := Some ( 82 | Unix.in_channel_of_descr solver_stderr_in 83 | ) ; 84 | let solver_stdin = 85 | Unix.out_channel_of_descr solver_stdin_out 86 | |> Format.formatter_of_out_channel 87 | in 88 | stdin := Some solver_stdin ; 89 | 90 | solver_stdin 91 | ) |> sanitize "while spawning horn clause solver" 92 | 93 | 94 | let print_position outx lexbuf = 95 | let pos = lexbuf.Lexing.lex_curr_p in 96 | Format.fprintf outx "%s:%d:%d" pos.Lexing.pos_fname pos.Lexing.pos_lnum ( 97 | pos.Lexing.pos_cnum - pos.Lexing.pos_bol + 1 98 | ) 99 | 100 | 101 | (** Parses the output of the solver. *) 102 | let parse lexbuf = 103 | try 104 | (SmtParse.top SmtLex.token lexbuf, lexbuf) |> Res.ok 105 | with 106 | | SmtLex.SyntaxError msg -> Res.err [ 107 | Format.asprintf "%a: %s" print_position lexbuf msg 108 | ] 109 | | SmtParse.Error -> Res.err [ 110 | Format.asprintf 111 | "%a: syntax error on character '%c' (%b)" print_position lexbuf 112 | (Lexing.lexeme_char lexbuf lexbuf.Lexing.lex_last_pos) 113 | lexbuf.Lexing.lex_eof_reached 114 | ] 115 | | e -> Res.err [ 116 | "unexpected error during parsing" ; 117 | Format.asprintf "%s" (Printexc.to_string e) 118 | ] 119 | 120 | let start_parsing stdout = 121 | let lexbuf = Lexing.from_channel stdout in 122 | parse lexbuf 123 | 124 | 125 | (** Spawns the solver, feeds it the clauses, and parses its output before 126 | closing it. *) 127 | let solve filename clauses = 128 | let res = 129 | if ! Conf.verb then Format.printf " spawning solver...@." ; 130 | spawn () 131 | |> Res.and_then (fun stdin -> 132 | (fun () -> 133 | if ! Conf.verb then Format.printf " printing clauses...@." ; 134 | let res = Cond.ToSmt2.clauses_to_smt2 stdin false filename clauses in 135 | ( match ! solver_pid with 136 | | Some pid -> 137 | if ! Conf.verb then 138 | Format.printf " waiting for solver to terminate...@." ; 139 | let _ = Unix.waitpid [ Unix.WNOHANG ; Unix.WUNTRACED ] pid in 140 | solver_pid := None ; 141 | () 142 | | None -> 143 | failwith "unreachable, no solver pid registered" 144 | ) ; 145 | res 146 | ) 147 | |> sanitize "waiting for the solver to terminate" 148 | |> Res.map (fun () -> stdin) 149 | ) 150 | |> Res.and_then ( 151 | fun _stdin -> ( 152 | if ! Conf.verb then Format.printf " parsing result...@." ; 153 | match ! stdout with 154 | | Some stdout -> start_parsing stdout |> Res.and_then ( 155 | function 156 | | (ParseBase.Sat, lex) -> 157 | if ! Conf.verb then Format.printf " sat@." ; 158 | Res.ok (true, lex) 159 | | (ParseBase.Unsat, lex) -> 160 | if ! Conf.verb then Format.printf " unsat@." ; 161 | Res.ok (false, lex) 162 | | (res, _) -> Res.err [ 163 | ParseBase.desc_of res 164 | |> Format.sprintf "expected sat or unsat, got %s" 165 | ] 166 | ) 167 | | None -> Res.err ["cannot access solver's stdout"] 168 | ) 169 | ) 170 | |> Res.chain_err "while retrieving sat result" 171 | |> Res.and_then(function 172 | | (true, lex) -> 173 | if ! Conf.verb then Format.printf " retrieving model...@." ; 174 | parse lex |> Res.map fst |> Res.and_then( 175 | function 176 | | ParseBase.Model model -> Some model |> Res.ok 177 | | parse_res -> Res.err [ 178 | ParseBase.desc_of parse_res 179 | |> Format.sprintf "expected model, got %s" 180 | ] 181 | ) 182 | |> Res.chain_err "while retrieving model" 183 | | (false, _) -> Res.ok None 184 | ) 185 | in 186 | if ! Conf.verb then Format.printf 187 | " cleaning up...@." ; 188 | let kill_res = kill () in 189 | if Res.is_ok kill_res || Res.is_err res then 190 | res 191 | else kill_res |> Res.map (fun _ -> None) 192 | -------------------------------------------------------------------------------- /src/mlLoader/mlLoader.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | module L = Label.Make(struct 4 | let label = "mlloader" 5 | end) 6 | 7 | module P = struct 8 | open Asttypes 9 | open Parsetree 10 | open SugarProgram 11 | 12 | type t = { 13 | structure: t -> structure -> SugarProgram.t; 14 | structure_item: t -> structure_item -> StructureItem.t list; 15 | value_binding: t -> value_binding -> (Identity.t * Expr.t) list; 16 | expr: t -> expression -> Expr.t; 17 | construct: t -> (Longident.t loc * expression option) -> Expr.t; 18 | apply: t -> expression -> expression list -> Expr.t; 19 | constant: t -> constant -> Objt.t; 20 | bind_pattern: t -> Expr.t -> pattern -> (Identity.t * Expr.t) list; 21 | } [@@deriving fields] 22 | 23 | let p_structure (self : t) (st : structure) : SugarProgram.t = 24 | List.map st ~f:(self.structure_item self) |> List.concat 25 | 26 | let rec pile_multi_abs (expr : Expr.t) : Expr.t = 27 | match expr with 28 | | AbsExp (vids, fun_expr) -> 29 | begin 30 | match pile_multi_abs fun_expr with 31 | | AbsExp (vids', fun_expr') -> AbsExp (vids @ vids', fun_expr') 32 | | fun_expr -> AbsExp (vids, fun_expr) 33 | end 34 | | _ -> expr 35 | 36 | let p_structure_item (self : t) ({ pstr_loc = _loc; pstr_desc = desc } : structure_item) : StructureItem.t list = 37 | match desc with 38 | | Pstr_eval (expr, _attr) -> [StructureItem.eval (self.expr self expr)] 39 | | Pstr_value (_is_recursive, vbs) -> 40 | List.map vbs ~f:(self.value_binding self) |> List.concat |> List.map ~f:(fun (vid, expr) -> 41 | match pile_multi_abs expr with 42 | | AbsExp (vids, fun_expr) -> Some (SugarProgram.Func.make ~name:vid ~args:vids ~exp:fun_expr () |> SugarProgram.StructureItem.bind_func) 43 | | expr -> Some (SugarProgram.StructureItem.bind_value (vid, expr)) 44 | ) |> List.filter_opt 45 | | _ -> [] 46 | 47 | let p_value_binding (self : t) ({ pvb_pat = pat; pvb_expr = expr; pvb_attributes = _attrs; pvb_loc = _loc } : value_binding) = 48 | let sp_expr = self.expr self expr in self.bind_pattern self sp_expr pat 49 | 50 | let p_expr (self : t) ({pexp_loc = _loc; pexp_desc = desc; pexp_attributes = _attrs; _}: expression) : Expr.t = 51 | match desc with 52 | | Pexp_fun (alabel, defe, fun_pat, fun_expr) -> 53 | let () = 54 | begin 55 | match (alabel, defe) with 56 | | (Nolabel, None) -> () 57 | | _ -> failwith "unsupported syntax" 58 | end 59 | in 60 | begin 61 | match self.bind_pattern self (self.expr self fun_expr) fun_pat with 62 | | [(vid, exp)] -> pile_multi_abs (AbsExp ([vid], exp)) 63 | | _ -> failwith "unsupported syntax" 64 | end 65 | | Pexp_let (rec_flag, value_bindings, cont_expr) -> 66 | let bindings = List.map value_bindings ~f:(fun x -> self.value_binding self x) |> List.concat in 67 | begin 68 | match rec_flag with 69 | | Asttypes.Recursive -> LetRecExp (bindings, self.expr self cont_expr) 70 | | _ -> List.fold_right bindings ~init:(self.expr self cont_expr) ~f:(fun (vid, expr) cont -> LetExp (vid, expr, cont)) 71 | end 72 | | Pexp_apply (fexp, alabels) -> 73 | self.apply self fexp (List.map alabels ~f:(fun (_, x) -> x)) 74 | | Pexp_ifthenelse (cond_exp, then_exp, else_exp_opt) -> 75 | let else_exp = (match else_exp_opt with Some e -> self.expr self e | None -> mk_true) in 76 | IfExp (self.expr self cond_exp, self.expr self then_exp, else_exp) 77 | | Pexp_sequence (exp1, exp2) -> 78 | let vid = L.gen () in 79 | LetExp (vid, self.expr self exp1, self.expr self exp2) 80 | | Pexp_constraint (expr, _type) -> self.expr self expr 81 | | Pexp_assert expr -> AssertExp (self.expr self expr) 82 | | Pexp_constant const -> ObjExp (self.constant self const) 83 | | Pexp_ident { txt = ident; loc = _loc; } -> ObjExp (Objt.varobj (Longident.last ident)) 84 | | Pexp_construct (loct, exp) -> self.construct self (loct, exp) 85 | | _ -> failwith "unsupported expr" 86 | 87 | let p_construct (_self : t) ({ txt = ident; loc = _loc; }, exp) : Expr.t = 88 | match (Longident.last ident, exp) with 89 | | ("()", None) -> mk_true 90 | | ("false", None) -> mk_false 91 | | ("true", None) -> mk_true 92 | | _ -> failwith "unsupported construction" 93 | 94 | let p_apply (self : t) (f_expr : expression) (a_exprs : expression list) : Expr.t = 95 | let sp_expr = self.expr self f_expr in 96 | let arg_exprs = List.map a_exprs ~f:(self.expr self) in 97 | match sp_expr with 98 | | ObjExp ob when Objt.is_var ob -> 99 | let vid = Objt.vid_of_exn ob in 100 | begin 101 | match (Op.of_string vid, arg_exprs) with 102 | | (Some (Op.Minus as op), [t1]) -> SingleOpExp (op, t1) 103 | | (Some (Op.Not_ as op), [t1]) -> SingleOpExp (op, t1) 104 | | (Some op, [t1; t2]) -> OpExp (t1, op, t2) 105 | | (Some _op, _) -> failwith "unsupported operator" 106 | | (_, _) -> FuncCallExp (vid, arg_exprs) 107 | end 108 | | _ -> 109 | let vid = L.gen () in 110 | LetExp (vid, sp_expr, FuncCallExp (vid, arg_exprs)) 111 | 112 | let p_constant (_self : t) (const : constant) : Objt.t = 113 | match const with 114 | | Pconst_integer (int_str, _suffix) -> Objt.intobj (Int.of_string int_str) 115 | | Pconst_char c -> Objt.varobj (String.of_char c) 116 | | Pconst_string (str, _, _) -> Objt.varobj str 117 | | _ -> failwith "unsupported constant" 118 | 119 | let p_bind_pattern (self : t) (e : Expr.t) ({ ppat_desc = pat; ppat_loc = _loc; ppat_attributes = _attrs; _ } : pattern) : (Identity.t * Expr.t) list = 120 | match pat with 121 | | Ppat_any -> [(L.gen (), e)] 122 | | Ppat_var ({ txt = vid; loc = _loc; }) -> [(vid, e)] 123 | | Ppat_constraint (pat, _type) -> self.bind_pattern self e pat 124 | | _ -> failwith "unsupported pattern" 125 | 126 | let converter : t = { 127 | structure = p_structure; 128 | structure_item = p_structure_item; 129 | value_binding = p_value_binding; 130 | expr = p_expr; 131 | construct = p_construct; 132 | apply = p_apply; 133 | constant = p_constant; 134 | bind_pattern = p_bind_pattern; 135 | } 136 | 137 | let convert (self : t) (str : structure) : SugarProgram.t = self.structure self str 138 | end 139 | 140 | let parse filename : SugarProgram.t = 141 | let structure = Pparse.parse_implementation ~tool_name:"fpice" filename in 142 | P.convert P.converter structure 143 | 144 | let desugar (sprogram : SugarProgram.t) : Program.t = Desugar.main sprogram 145 | -------------------------------------------------------------------------------- /src/mlLoader/closureConv.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open SugarProgram 3 | open Util 4 | 5 | module L = Label.Make (struct 6 | let label = "innerFunc" 7 | end) 8 | 9 | module BindClosure = struct 10 | let main (sprogram : t) : t = 11 | let mapper = 12 | { Mapper.default_mapper with 13 | Mapper.let_ = (fun self (vid, exp1, exp2) -> 14 | let exp1 = 15 | match exp1 with 16 | | AbsExp (vids, exp) -> AbsExp (vids, self.Mapper.exp self exp) 17 | | _ -> self.Mapper.exp self exp1 18 | in 19 | LetExp (vid, exp1, self.Mapper.exp self exp2) 20 | ); 21 | Mapper.letrec_ = (fun self (bindings, exp2) -> 22 | let bindings = List.map bindings ~f:(fun (v, exp) -> 23 | let exp = 24 | match exp with 25 | | AbsExp (vids, exp) -> AbsExp (vids, self.Mapper.exp self exp) 26 | | _ -> self.Mapper.exp self exp2 27 | in 28 | (v, exp) 29 | ) in 30 | LetRecExp (bindings, self.Mapper.exp self exp2) 31 | ); 32 | Mapper.abs = (fun self (vids, exp) -> 33 | let v = L.gen () in 34 | LetExp (v, AbsExp (vids, self.Mapper.exp self exp), ObjExp (Objt.mk_var v)) 35 | ); 36 | } 37 | in 38 | SugarProgram.expr_map sprogram ~f:(mapper.Mapper.exp mapper) 39 | end 40 | 41 | module InnerFunc = struct 42 | type t = Identity.t * exp * Identity.t list * Identity.t list 43 | 44 | let name_of ((name, _, _, _) : t) = name 45 | let exp_of ((_, exp, _, _) : t) = exp 46 | let extra_vids_of ((_, _, vids, _) : t) = vids 47 | let abs_vids_of ((_, _, _, vids) : t) = vids 48 | 49 | let to_func (self : t) : recfun = 50 | { name = (name_of self); args = (extra_vids_of self @ abs_vids_of self); exp = (exp_of self); annotation = Program.Func.Annotation.make (); } 51 | end 52 | 53 | module Env = struct 54 | module Element = struct 55 | type t = (Identity.t * Identity.t list) 56 | end 57 | 58 | type t = Element.t Identity.Map.t 59 | 60 | let empty = Identity.Map.empty 61 | let add (self : t) ~key ~data = 62 | match Identity.Map.add self ~key ~data with 63 | | `Ok self -> self 64 | | `Duplicate -> self 65 | let add_closure self ~key ~data = add self ~key ~data:(data) 66 | let add_global_function self ~key ~data = add self ~key ~data:(data, []) 67 | 68 | let global_function_key_set_of (self : t) = 69 | Identity.Map.filteri self ~f:(fun ~key:_ ~data -> 70 | match data with 71 | | (_, []) -> true 72 | | _ -> false 73 | ) |> Identity.Map.keys |> Identity.Set.of_list 74 | 75 | let keys (self : t) = 76 | self |> Identity.Map.keys 77 | 78 | let key_set_of (self : t) = 79 | Identity.Set.of_list (keys self) 80 | 81 | let find = Identity.Map.find 82 | end 83 | 84 | let main (sprogram : t) : t = 85 | let inner_funcs : (InnerFunc.t list) ref = ref [] in 86 | let mapping_expr (mapper : Mapper.t) (expr : Expr.t) : Expr.t = Mapper.apply_expr mapper expr in 87 | let sort_vars (var_set : Identity.Set.t) (vars : Identity.t list) = List.filter vars ~f:(Identity.Set.mem var_set) in 88 | let rec mapper_fn (env : Env.t) (vars_rev : Identity.t list) : Mapper.t = 89 | { Mapper.default_mapper with 90 | Mapper.let_ = (fun self (vid, exp1, exp2) -> 91 | match self.Mapper.exp self exp1 with 92 | | (AbsExp (args, abs_exp)) -> 93 | let env_keys = Env.key_set_of env in 94 | let (fname, free_vars) as closure = (L.gen () ^ "-" ^ vid, sort_vars (Identity.Set.diff (Identity.Set.of_list vars_rev) (env_keys)) (List.rev vars_rev)) in 95 | let inner_func : InnerFunc.t = (fname, abs_exp, free_vars, args) in 96 | let () = inner_funcs := inner_func :: !inner_funcs in 97 | mapping_expr (mapper_fn (Env.add_closure env ~key:vid ~data:closure) (vid :: vars_rev)) exp2 98 | | x -> LetExp (vid, x, mapping_expr (mapper_fn env (vid :: vars_rev)) exp2) 99 | ); 100 | Mapper.letrec_ = (fun _self (bindings, exp2) -> 101 | let env_keys = Env.key_set_of env in 102 | let letrec_bound_names = List.map bindings ~f:Tuple2.get1 in 103 | let letrec_bound_name_set = Identity.Set.of_list letrec_bound_names in 104 | let env = 105 | let vid_closures = List.map bindings ~f:(fun (vid, _exp) -> 106 | let free_vars = Identity.Set.diff (Identity.Set.diff (Identity.Set.of_list vars_rev) (env_keys)) letrec_bound_name_set in 107 | let closure = (L.gen () ^ "-" ^ vid, sort_vars free_vars (List.rev vars_rev)) in 108 | (vid, closure) 109 | ) in 110 | List.fold vid_closures ~init:env ~f:(fun env (key, data) -> Env.add_closure env ~key ~data) 111 | in 112 | let mapper = mapper_fn env (letrec_bound_names @ vars_rev) in 113 | let bindings = List.map bindings ~f:(fun (vid, exp) -> 114 | match mapping_expr mapper exp with 115 | | (AbsExp (args, abs_exp)) -> 116 | let (fname, free_vars) = Option.value_exn (Env.find env vid) in 117 | let inner_func : InnerFunc.t = (fname, abs_exp, free_vars, args) in 118 | let () = inner_funcs := inner_func :: !inner_funcs in 119 | None 120 | | x -> Some (vid, x) 121 | ) |> List.filter_opt in 122 | List.fold bindings ~init:(Mapper.apply_expr mapper exp2) ~f:(fun cont (vid, exp) -> LetExp (vid, exp, cont)) 123 | ); 124 | Mapper.abs = (fun _self (vids, exp) -> 125 | AbsExp (vids, mapping_expr (mapper_fn env (List.rev vids @ vars_rev)) exp) 126 | ); 127 | Mapper.obj = (fun _self objt -> 128 | match (Objt.vid_of objt |> (fun x -> Option.bind x ~f:(Env.find env))) with 129 | | None -> ObjExp objt 130 | | Some (fname, []) -> ObjExp (Objt.mk_var fname) 131 | | Some (fname, free_vars) -> FuncCallExp (fname, List.map free_vars ~f:(fun x -> ObjExp (Objt.mk_var x))) 132 | ); 133 | Mapper.funccall = (fun self (fid, aes) -> 134 | let aes = List.map aes ~f:(self.Mapper.exp self) in 135 | match Env.find env fid with 136 | | None -> FuncCallExp (fid, aes) 137 | | Some (fname, []) -> FuncCallExp (fname, aes) 138 | | Some (fname, free_vars) -> FuncCallExp (fname, List.map free_vars ~f:(fun x -> ObjExp (Objt.mk_var x)) @ aes) 139 | ); 140 | } 141 | in 142 | let initial_env = List.fold (SugarProgram.recfuns_of sprogram) ~init:Env.empty ~f:(fun env recfun -> 143 | Env.add_global_function env ~key:(Func.name_of recfun) ~data:(Func.name_of recfun) 144 | ) in 145 | let env_keys = Env.keys initial_env in 146 | let sprogram = BindClosure.main sprogram in 147 | let sprogram = SugarProgram.map sprogram ~f:(fun el -> 148 | match el with 149 | | BindFunc recfun -> 150 | let exp = mapping_expr ( 151 | mapper_fn initial_env ( 152 | List.rev recfun.SugarProgram.args @ env_keys 153 | ) 154 | ) recfun.SugarProgram.exp in 155 | BindFunc { recfun with exp = exp; } 156 | | _ -> StructureItem.expr_map el ~f:(mapping_expr (mapper_fn initial_env env_keys)) 157 | ) in 158 | sprogram @ List.map ~f:(SugarProgram.StructureItem.bind_func @< InnerFunc.to_func) !inner_funcs 159 | -------------------------------------------------------------------------------- /src/data/effectInfer.ml: -------------------------------------------------------------------------------- 1 | type t = raw * effect 2 | and raw = Base | Fun of raw * t | Bot (* Bot is used only for Fail *) 3 | and effect = Var of int | Safe | MayFail 4 | 5 | type env = (Identity.t * raw) list 6 | 7 | (** subtyping constraints *) 8 | type constr = 9 | | TypeC of t * t 10 | | RawC of raw * raw 11 | | EffectC of effect * effect 12 | 13 | let print_effect fm ef = 14 | match ef with 15 | | Var x -> Format.fprintf fm "?%d" x 16 | | Safe -> Format.fprintf fm "_" 17 | | MayFail -> Format.fprintf fm "!" 18 | 19 | let rec print_raw fm raw = 20 | match raw with 21 | | Base -> Format.fprintf fm "b" 22 | | Fun(raw1,tmp) -> Format.fprintf fm "@[(%a ->@ %a)@]" print_raw raw1 print_template tmp 23 | | Bot -> Format.fprintf fm "_|_" 24 | 25 | and print_template fm (raw,ef) = 26 | Format.fprintf fm "%a^%a" print_raw raw print_effect ef 27 | 28 | let print_constr fm ef = 29 | match ef with 30 | | TypeC(tmp1,tmp2) -> Format.fprintf fm "@[%a <: %a@]" print_template tmp1 print_template tmp2 31 | | RawC(raw1,raw2) -> Format.fprintf fm "@[%a <: %a@]" print_raw raw1 print_raw raw2 32 | | EffectC(ef1,ef2) -> Format.fprintf fm "@[%a <: %a@]" print_effect ef1 print_effect ef2 33 | 34 | 35 | module Debug = struct 36 | let debug = false 37 | let fprintf fm f = if debug then Format.fprintf fm f else Format.ifprintf fm f 38 | let printf fm = fprintf Format.std_formatter fm 39 | end 40 | 41 | let counter = ref 0 42 | let new_var () = incr counter; !counter 43 | 44 | let rec raw_of_ref ty = 45 | let open Type.RefType in 46 | match ty with 47 | | Int_ _ -> Base 48 | | Func(_, ty1, ty2) -> Fun(raw_of_ref ty1, template_of_ref ty2) 49 | | Bottom -> assert false 50 | | Top -> assert false 51 | and template_of_ref ty = 52 | raw_of_ref ty, Var (new_var()) 53 | 54 | let rec fresh_template (raw,_) = 55 | let rec fresh_raw raw = 56 | match raw with 57 | | Base -> Base 58 | | Fun(raw1,tmp) -> Fun(fresh_raw raw1, fresh_template tmp) 59 | | Bot -> Bot 60 | in 61 | fresh_raw raw, Var (new_var()) 62 | 63 | let rec gen acc env e : t * constr list = 64 | let open Program.Exp in 65 | match e with 66 | | Let_(x, e1, e2) -> 67 | let (raw1,ef1),acc' = gen acc env e1 in 68 | let (raw2,ef2),acc'' = gen acc' ((x,raw1)::env) e2 in 69 | let ef = Var (new_var()) in 70 | (raw2,ef), EffectC(ef1,ef)::EffectC(ef2,ef)::acc'' 71 | | Branch cs -> 72 | let tmps,acc' = 73 | let aux (_,e) (tmps,acc) = 74 | let tmp,acc' = gen acc env e in 75 | tmp::tmps, acc' 76 | in 77 | List.fold_right aux cs ([],acc) 78 | in 79 | let tmp = fresh_template @@ List.hd tmps in 80 | tmp, List.map (fun tmp' -> TypeC(tmp', tmp)) tmps @ acc' 81 | | App(f, x) -> 82 | let tmp11,tmp12 = 83 | match List.assoc f env with 84 | | Fun(tmp11, tmp12) -> tmp11, tmp12 85 | | _ -> assert false 86 | in 87 | let tmp2 = List.assoc x env in 88 | tmp12, RawC(tmp2, tmp11)::acc 89 | | Term fml when Cond.is_var fml -> 90 | (List.assoc (Cond.vid_exn fml) env, Safe), acc 91 | | Term _fml -> (Base, Safe), acc 92 | | Fail -> (Bot, MayFail), acc 93 | 94 | 95 | let generate env (Program.Program fs) = 96 | let tmp_env = List.map (fun {Program.Func.name;_} -> name, raw_of_ref @@ Type.Env.find_exn env name) fs in 97 | let f {Program.Func.name; args; exp; _} acc = 98 | let raw = List.assoc name tmp_env in 99 | let tmp1,tmp_env' = 100 | let rec decomp acc tmp args = 101 | match tmp,args with 102 | | _, [] -> tmp, acc 103 | | (Fun(raw,tmp2),_), x::args' -> decomp ((x,raw)::acc) tmp2 args' 104 | | _ -> assert false 105 | in 106 | assert (args <> []); 107 | decomp tmp_env (raw,Var(new_var())) args 108 | in 109 | let tmp2,constr = gen acc tmp_env' exp in 110 | TypeC(tmp2,tmp1)::constr 111 | in 112 | List.fold_right f fs [], tmp_env 113 | 114 | let rec flatten constr = 115 | match constr with 116 | | TypeC((raw1,ef1), (raw2,ef2)) -> flatten (EffectC(ef1,ef2)) @ flatten (RawC(raw1,raw2)) 117 | | RawC(Base, Base) -> [] 118 | | RawC(Fun(raw1,tmp1), Fun(raw2,tmp2)) -> flatten (RawC(raw2,raw1)) @ flatten (TypeC(tmp1,tmp2)) 119 | | RawC(Bot, _) -> [] 120 | | EffectC(Safe,_ef2) -> [] 121 | | EffectC(ef1,ef2) -> [ef1,ef2] 122 | | _ -> assert false 123 | 124 | module IntSet = 125 | Set.Make( 126 | struct 127 | type t = int 128 | let compare = compare 129 | end) 130 | 131 | let solve constrs = 132 | let constrs' = 133 | let to_int ef = 134 | match ef with 135 | | Var x -> x 136 | | Safe -> assert false 137 | | MayFail -> 0 138 | in 139 | List.map (fun (x,y) -> to_int x, to_int y) constrs 140 | in 141 | let upper = 142 | let n = !counter + 1 in 143 | let a = Array.make n [] in 144 | List.iter (fun (x,y) -> a.(x) <- y::a.(x)) constrs'; 145 | a 146 | in 147 | let rec solve may_fail rest = 148 | Debug.printf "|rest|: %d@." (List.length rest); 149 | match rest with 150 | | [] -> may_fail 151 | | x::rest' -> 152 | let up = List.filter (fun y -> not @@ IntSet.mem y may_fail) upper.(x) in 153 | List.iter (Debug.printf "%d ADDED@.") up; 154 | let may_fail' = List.fold_right IntSet.add up may_fail in 155 | solve may_fail' (up@rest') 156 | in 157 | let may_fail = solve IntSet.empty [0] in 158 | fun x -> 159 | if IntSet.mem x may_fail then 160 | MayFail 161 | else 162 | Safe 163 | 164 | let apply_sol sol env = 165 | let rec to_raw raw = 166 | match raw with 167 | | Base -> Base 168 | | Fun(raw,tmp2) -> Fun(to_raw raw, to_tmp tmp2) 169 | | Bot -> Bot 170 | and to_tmp (raw,ef) = 171 | let ef' = 172 | match ef with 173 | | Var x -> sol x 174 | | Safe -> Safe 175 | | MayFail -> MayFail 176 | in 177 | to_raw raw, ef' 178 | in 179 | List.map (fun (f,raw) -> f, to_raw raw) env 180 | 181 | let infer rtenv prog : env = 182 | counter := 0; 183 | Debug.printf "prog: %s@." @@ Program.to_string prog; 184 | let constrs,env = generate rtenv prog in 185 | Debug.printf "@.@.TEMPLATES:@."; 186 | List.iter (fun (x,raw) -> Debug.printf "%s: %a@." x print_raw raw) env; 187 | Debug.printf "@.@.CONSTRS:@."; 188 | List.iter (Debug.printf " %a@." print_constr) constrs; 189 | let constrs = List.flatten @@ List.map flatten constrs in 190 | Debug.printf "@.@.FLATTEN:@."; 191 | List.iter (fun (ef1,ef2) -> Debug.printf " %a <: %a@." print_effect ef1 print_effect ef2) constrs; 192 | let sol = solve constrs in 193 | let env' = apply_sol sol env in 194 | Debug.printf "@.@.INFERRED:@."; 195 | List.iter (fun (x,raw) -> Debug.printf "%s: %a@." x print_raw raw) env'; 196 | Debug.printf "@.@.RTENV: %s@." (Type.Env.to_string rtenv); 197 | env' 198 | 199 | 200 | let assumed_as_true rtenv prog = 201 | let module RT = Type.RefType in 202 | let env = infer rtenv prog in 203 | let rec aux raw ty = 204 | match raw, ty with 205 | | Base, _ -> [] 206 | | Fun(raw1,tmp2), RT.Func(_,ty1,ty2) -> 207 | let ps1 = aux raw1 ty1 in 208 | let ps2 = aux (fst tmp2) ty2 in 209 | let ps3 = 210 | match ty1 with 211 | | RT.Int_(_, Cond.UApp(p,_)) -> 212 | let rec next_effect tmp2 = 213 | match tmp2 with 214 | | _, MayFail -> MayFail 215 | | Fun(Fun _,tmp22), _ -> next_effect tmp22 216 | | _, ef -> ef 217 | in 218 | if next_effect tmp2 = Safe then 219 | let x = UnknownPredicate.id_of p in 220 | let () = Debug.printf "P: %s@." x in 221 | [x] 222 | else 223 | [] 224 | | _ -> [] 225 | in 226 | ps3 @ ps1 @ ps2 227 | | Fun _, _ -> assert false 228 | | Bot, _ -> assert false 229 | in 230 | List.flatten @@ List.map (fun (f,raw) -> aux raw @@ Type.Env.find_exn rtenv f) env 231 | -------------------------------------------------------------------------------- /src/data/vcControl.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Cond 3 | 4 | type t = Cond.t 5 | 6 | let rev_assign (cond : Cond.t) (un : Cond.UnknownApp.t) = 7 | let substs = Cond.UnknownApp.substs_of un in 8 | List.fold substs ~init:cond ~f:(fun acc (k, v) -> 9 | if Cond.is_var v then Cond.subst acc (Cond.vid_exn v) k 10 | else failwith "unexpected" 11 | ) 12 | 13 | let wrap_exists_free_vars (cond : Cond.t) (bindvars : Identity.Set.t) = 14 | (* 15 | let cond = Cond.ElimFreeVar.run cond ~bind_vars:bindvars in 16 | *) 17 | let freevars = Identity.Set.diff (Cond.get_vids cond |> Identity.Set.of_list) bindvars in 18 | Identity.Set.fold freevars ~init:cond ~f:(fun cond vid -> 19 | Cond.op1 (Op.exists vid) cond 20 | ) 21 | 22 | module AlphaConvUnParams = struct 23 | module L = Label.Make(struct let label = "elim-dup-var" end) 24 | 25 | let run (cond : Cond.t) : Cond.t = 26 | let assume_eqs = ref [] in 27 | let new_cond = Cond.UApp_plus.map cond ~f:(fun un -> 28 | let uapp_conds = 29 | List.fold_right (Cond.UnknownApp.substs_of un) ~init:[] ~f:(fun (_kvid, vcond) uapp_conds -> 30 | let alpha_id = L.gen () in 31 | let () = assume_eqs := Cond.DSL.(var alpha_id == vcond) :: !assume_eqs in 32 | Cond.DSL.var alpha_id :: uapp_conds 33 | ) in 34 | Cond.uapp (Cond.UnknownApp.predicate_of un) uapp_conds 35 | ) in 36 | let new_cond' = Cond.DSL.(Cond.forall !assume_eqs (fun x -> x) ==> new_cond) in 37 | List.fold (Cond.get_vids new_cond' |> Identity.Set.of_list |> Identity.Set.to_list) ~init:new_cond' ~f:(fun cond vid -> 38 | Cond.subst cond vid (L.gen ()) 39 | ) |> Horn.hornize 40 | end 41 | 42 | module DetectConsequentUnknown = struct 43 | module Report = struct 44 | type t = UnknownPredicate.t * Cond.t 45 | end 46 | 47 | let run (cond : Cond.t) : Report.t option = 48 | match cond with 49 | | Op2 (c1, Op.Impl, c2) -> 50 | Option.map (Cond.uapp_of c2) ~f:(fun un -> 51 | let cond = rev_assign c1 un in 52 | (Cond.UnknownApp.predicate_of un, cond) 53 | ) 54 | | _ -> None 55 | end 56 | 57 | module DetectNonRecursiveUnknown = struct 58 | module Report = struct 59 | type t = UnknownPredicate.t * Cond.t list 60 | 61 | let is_not_recursive (un : UnknownPredicate.t) (cond : Cond.t) : bool = 62 | List.for_all (Cond.uapps_of cond) ~f:(fun (up, _) -> not (UnknownPredicate.equal un up)) 63 | 64 | let can_be_single_horn (report : t) : bool = 65 | let (_, conds) = report in 66 | if List.length conds = 1 then true 67 | else 68 | if List.length conds > 1 then 69 | List.for_all conds ~f:(fun cond -> List.is_empty (Cond.uapps_of cond)) 70 | else 71 | false 72 | 73 | let of_conseq_reports (creports : DetectConsequentUnknown.Report.t list) (allow_multi_impl : bool) : t list = 74 | let up_report_dict = UnknownPredicate.Map.of_alist_multi creports in 75 | let filtered_reports = 76 | UnknownPredicate.Map.to_alist up_report_dict |> List.filter ~f:(fun (un, conds) -> 77 | List.for_all conds ~f:(fun cond -> is_not_recursive un cond) 78 | ) |> (fun reports -> 79 | if allow_multi_impl 80 | then reports 81 | else List.filter reports ~f:can_be_single_horn 82 | ) 83 | in 84 | List.map filtered_reports ~f:(fun ((un, conds) as report) -> 85 | let conds = 86 | if can_be_single_horn report 87 | then [Cond.exists conds (fun x -> x)] 88 | else conds 89 | in 90 | let (report : t) = (un, conds) in report 91 | ) 92 | 93 | let has_specified_unknown (cond : Cond.t) (specified_un : UnknownPredicate.t) : bool = 94 | List.exists (Cond.uapps_of cond) ~f:(fun (up, _) -> UnknownPredicate.equal specified_un up) 95 | 96 | let apply_to_cond ((orig_un, u_conds) : t) (cond : Cond.t) : Cond.t list = 97 | let orig_un_arg_vids = UnknownPredicate.var_set_of orig_un in 98 | match cond with 99 | | Op2 (_c1, Op.Impl, c2) when Option.map (uapp_of c2) ~f:(fun un -> UnknownPredicate.equal (Cond.UnknownApp.predicate_of un) orig_un ) |> Option.value ~default:false 100 | -> [] 101 | | _ -> 102 | if has_specified_unknown cond orig_un then 103 | Cond.UApp_plus.map_multi cond ~f:(fun uapp -> 104 | if UnknownPredicate.equal (Cond.UnknownApp.predicate_of uapp) orig_un then 105 | List.map u_conds ~f:(fun u_cond -> 106 | (* let _ = Cond.inspect ~tag:"cond before rename" u_cond in 107 | let _ = Logger.debug ~tag:"vids not to rename" (List.to_string (Identity.Set.to_list orig_un_arg_vids) ~f:(fun x -> x) ) in *) 108 | let u_cond_alpha_renamed = Cond.AlphaConv.run u_cond ~vids_not_to_rename:orig_un_arg_vids in 109 | (* let _ = Cond.inspect ~tag:"cond after rename" u_cond_alpha_renamed in *) 110 | Cond.UnknownApp.subst uapp u_cond_alpha_renamed 111 | ) 112 | else 113 | [Cond.UnknownApp.to_cond uapp] 114 | ) |> List.map ~f:Horn.hornize 115 | else 116 | [cond] 117 | 118 | let apply_to_report (self : t) (target : t) : t = 119 | let (orig_un, u_conds) = self in 120 | let orig_un_arg_vids = UnknownPredicate.var_set_of orig_un in 121 | let (target_un, target_conds) = target in 122 | let target_conds = 123 | let do_subst cond sbst_cond = 124 | Cond.UApp_plus.map cond ~f:(fun uapp -> 125 | if UnknownPredicate.equal (Cond.UnknownApp.predicate_of uapp) orig_un then 126 | let sbst_cond_alpha_renamed = Cond.AlphaConv.run sbst_cond ~vids_not_to_rename:orig_un_arg_vids in 127 | Cond.UnknownApp.subst uapp sbst_cond_alpha_renamed 128 | else 129 | Cond.UnknownApp.to_cond uapp 130 | ) 131 | in 132 | List.map target_conds ~f:(fun x -> 133 | if has_specified_unknown x orig_un then 134 | List.map u_conds ~f:(do_subst x) 135 | else 136 | [x] 137 | ) |> List.concat 138 | in 139 | (target_un, target_conds) 140 | 141 | let sort_by_count (reports : t list) : t list = 142 | let reports_with_count = List.map reports ~f:(fun (un, conds) -> 143 | (List.length conds, (un, conds)) 144 | ) in 145 | let reports_with_count = List.sort reports_with_count ~compare:(fun a b -> Int.compare (Tuple.T2.get1 a) (Tuple.T2.get1 b)) in 146 | List.map reports_with_count ~f:Tuple.T2.get2 147 | 148 | let select_effective_one (reports : t list) : t option = 149 | let reports_with_count = List.map reports ~f:(fun (un, conds) -> 150 | (List.fold conds ~init:[] ~f:(fun acc x -> acc @ Cond.uapps_of x) |> List.length, (un, conds)) 151 | ) in 152 | let reports_with_count = List.sort reports_with_count ~compare:(fun a b -> Int.compare (Tuple.T2.get1 a) (Tuple.T2.get1 b)) in 153 | List.hd reports_with_count |> Option.map ~f:Tuple.T2.get2 154 | end 155 | 156 | let run (clauses : Horn.t) (allow_multi_impl : bool) : Report.t list = 157 | let conseq_reports = Cond.Horn.map clauses ~f:DetectConsequentUnknown.run |> List.filter_opt in 158 | (* let () = List.iter conseq_reports ~f:DetectConsequentUnknown.Report.log in *) 159 | Report.of_conseq_reports conseq_reports allow_multi_impl 160 | end 161 | 162 | module DetectTruthyUnknown = struct 163 | module Report = struct 164 | type t = UnknownPredicate.t 165 | 166 | let apply_to_cond (self : t) (cond : Cond.t) : Cond.t = 167 | Cond.UApp_plus.map cond ~f:(fun uapp -> 168 | if UnknownPredicate.equal (Cond.UnknownApp.predicate_of uapp) self then 169 | Cond.true_ 170 | else 171 | Cond.UnknownApp.to_cond uapp 172 | ) 173 | end 174 | end 175 | 176 | module ReducedUnknownReport = struct 177 | type t = (UnknownPredicate.t * Cond.t) list 178 | 179 | let build (treports: DetectTruthyUnknown.Report.t list) (creports: DetectNonRecursiveUnknown.Report.t list) : t = 180 | List.map treports ~f:(fun x -> (x, Cond.true_)) @ 181 | List.map creports ~f:(fun (un, conds) -> (un, List.map conds ~f:(fun cond -> wrap_exists_free_vars cond (UnknownPredicate.var_set_of un)) |> (fun conds -> Cond.exists conds (fun x -> x)))) 182 | 183 | let remove_reduced_unknowns_from_tyenv (self : t) (tyenv : Type.Env.t) : Type.Env.t = 184 | let subst = UnknownPredicate.Map.of_alist_reduce self ~f:(fun x _ -> x) in 185 | Type.Env.ty_map tyenv ~f:(fun reftype -> Type.RefType.assign_unknown reftype subst) 186 | end 187 | -------------------------------------------------------------------------------- /src/data/program.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Sexplib.Std 3 | module I = Formatable 4 | 5 | let (=) = Poly.(=) 6 | 7 | module Exp = struct 8 | type t = 9 | Let_ of Identity.t * t * t 10 | | Branch of (Cond.t * t) list 11 | | App of Identity.t * Identity.t 12 | | Term of Cond.t 13 | | Fail 14 | [@@deriving sexp, variants, eq, ord, hash] 15 | 16 | let var x = Term (Cond.var x) 17 | let value x = Term (Cond.value x) 18 | 19 | include Diggable.Make(struct 20 | type nonrec t = t 21 | let dig e f = 22 | match e with 23 | Let_ (fid, exp, lexp) -> Let_ (fid, f exp, f lexp) 24 | | Branch cs -> Branch (List.map cs ~f:(fun (cond, exp) -> cond, f exp)) 25 | | _ as e -> e 26 | end) 27 | 28 | include Formatable.Make(struct 29 | type nonrec t = t 30 | let rec to_format = function 31 | | Let_ (vid, exp1, exp2) -> I.block [ 32 | I.block [ 33 | I.text ("let " ^ vid ^ " = "); 34 | to_format exp1; 35 | I.text " in"; 36 | ]; 37 | I.block [to_format exp2] 38 | ] 39 | | Branch (cs) -> 40 | I.block [ 41 | I.line "case"; 42 | I.indent (I.block 43 | (List.map cs ~f:(fun (cond, exp) -> 44 | I.block [ 45 | I.block [ 46 | I.text "when "; 47 | Cond.to_format cond; 48 | I.text " ==> " 49 | ]; 50 | I.indent (to_format exp) 51 | ] 52 | )) 53 | ) 54 | ] 55 | | App (fid, aid) -> 56 | I.text ("(" ^ fid ^ " " ^ aid ^ ")") 57 | | Term term -> 58 | Cond.to_format term 59 | | Fail -> 60 | I.text "fail" 61 | end) 62 | end 63 | 64 | module Func = struct 65 | module Annotation = struct 66 | module TypeSize = struct 67 | type t = Func of t * t | Value of int * int (* or, and *) 68 | [@@deriving variants, sexp, eq, ord, hash] 69 | end 70 | 71 | type t = { type_size: TypeSize.t option; reftype: Type.RefType.t option; } 72 | [@@deriving sexp, eq, ord, hash, fields] 73 | 74 | let make ?type_size ?reftype () : t = { type_size; reftype; } 75 | let empty = { type_size = None; reftype = None; } 76 | 77 | module Element = struct 78 | type t = RType of Type.RefType.t 79 | [@@deriving variants] 80 | 81 | end 82 | 83 | let from_elements (els : Element.t list) : t = 84 | List.fold els ~init:empty ~f:(fun an el -> 85 | let open Element in 86 | match el with 87 | | RType rt -> { an with reftype = Some rt } 88 | ) 89 | end 90 | 91 | type t = { name: Identity.t; args: args; exp: Exp.t; annotation: Annotation.t } 92 | [@@deriving sexp, eq, ord, hash, fields] 93 | and args = Identity.t list 94 | [@@deriving sexp, eq, ord, hash] 95 | 96 | let is_main (self : t) = self.name = "main" 97 | 98 | let make ?annotation ~name ~args ~exp : t = 99 | let annotation = Option.value ~default:(Annotation.make ()) annotation in 100 | Fields.create ~name ~args ~exp ~annotation 101 | 102 | include Formatable.Make(struct 103 | type nonrec t = t 104 | let to_format { name; args; exp; _ } = 105 | I.block [ 106 | I.block [ 107 | I.inline (List.map (I.joint (name :: args) " ") ~f:(fun tx -> I.text tx)); 108 | I.text " =" 109 | ]; 110 | I.indent (I.block [Exp.to_format exp]) 111 | ] 112 | end) 113 | end 114 | 115 | module Typedef = struct 116 | type t = Program of Func.t list 117 | [@@deriving sexp, eq, ord, hash] 118 | 119 | let to_format (Program recfuns) = 120 | I.block (List.map recfuns ~f:Func.to_format) 121 | 122 | let recfuns (Program recfuns) = recfuns 123 | end 124 | include Typedef 125 | include Showsexp.Make(Typedef) 126 | include Formatable.Make(Typedef) 127 | (* 128 | let type_env (Program fs) = 129 | let f acc (Func.RecFunc (fid, args, exp)) = 130 | let rec g = (function 131 | | v :: [] -> Type.RefType.bottom 132 | | v :: vs -> Type.RefType.func fid Type.RefType.bottom (g vs) 133 | ) in 134 | Type.Env.T.(acc @<< from_map (fid, g args)) in 135 | List.fold fs ~init:Type.Env.empty ~f 136 | *) 137 | 138 | let to_func_map (program : Typedef.t) : Func.t Identity.Map.t = 139 | let funcs = recfuns program in 140 | List.fold funcs ~init:Identity.Map.empty ~f:(fun mp func -> 141 | match Identity.Map.add mp ~key:func.Func.name ~data:func with 142 | | `Ok mp -> mp 143 | | `Duplicate -> assert false 144 | ) 145 | 146 | module Info = struct 147 | type t = (Identity.t * Identity.t list) list 148 | [@@deriving sexp, eq, ord, hash] 149 | 150 | include Assocable.Make (struct 151 | type nonrec t = t 152 | type key_t = Identity.t 153 | type value_t = Identity.t list 154 | 155 | let mapping obj = obj 156 | end) 157 | 158 | let from_program program = 159 | let from_recfun ({ Func.name ; Func.args ; _ } : Func.t) = (name, args) in 160 | match program with 161 | | Program (recfuns) -> List.map recfuns ~f:from_recfun 162 | 163 | let fids_of pinfo = 164 | List.map pinfo ~f:(fun (fid, _) -> fid) 165 | 166 | let fid_of_var pinfo vid = 167 | let (fid, _) = 168 | List.find_exn pinfo ~f:(fun (_, vids) -> List.exists vids ~f:(fun v -> v = vid)) in 169 | fid 170 | end 171 | 172 | module SimpleTypeInfer = struct 173 | open SimpleType 174 | 175 | let main (Program fs) = 176 | let rec (infer : Env.tt -> Relation.t -> Exp.t -> Env.tt * Relation.t * Essential.t) = fun tyenv tyrel exp -> 177 | let bind id ty = Relation.T.(Env.find_exn tyenv id == ty) in 178 | let bind_condition_variables tyrel cond = 179 | List.fold (Cond.get_vids cond) ~init:tyrel ~f:(fun tyrel vid -> Relation.T.(tyrel %<< bind vid int_)) in 180 | match exp with 181 | | Exp.Let_ (vid, exp1, exp2) -> 182 | let (tyenv, tyrel, ty) = infer tyenv tyrel exp1 in 183 | infer Env.T.(tyenv %<< (vid, ty)) tyrel exp2 184 | | Exp.Branch (cs) -> 185 | let rtn_ty = gen_var ~suffix:"-branch" () in 186 | let (tyenv, tyrel, types) = 187 | List.fold cs ~init:(tyenv, tyrel, [rtn_ty]) ~f:(fun (tyenv, tyrel, types) (cond, exp) -> 188 | let (tyenv, tyrel, ty) = infer tyenv tyrel exp in 189 | let tyrel = bind_condition_variables tyrel cond in 190 | (tyenv, tyrel, ty :: types) 191 | ) in 192 | (tyenv, Relation.T.(tyrel %<< types), rtn_ty) 193 | | Exp.App (fid, aid) -> 194 | let arg_type = gen_var ~suffix:("-app-arg-" ^ fid ^ "-" ^ aid) () in 195 | let rtn_type = gen_var ~suffix:("-app-rtn-" ^ fid ^ "-" ^ aid) () in 196 | let tyrel = Relation.T.(tyrel %<< bind aid arg_type %<< bind fid (func arg_type rtn_type)) in 197 | (tyenv, tyrel, rtn_type) 198 | | Exp.Term fml when Cond.is_var fml -> 199 | (tyenv, tyrel, Env.find_exn tyenv (Cond.vid_exn fml)) 200 | | Exp.Term fml -> 201 | (tyenv, bind_condition_variables tyrel fml, int_) 202 | | Exp.Fail -> (tyenv, tyrel, Top) in 203 | let init_tyenv = 204 | List.fold fs ~init:Env.empty ~f:( 205 | fun tyenv ({ Func.name; Func.args; _ } : Func.t) -> 206 | let arg_types = List.map args ~f:(fun aid -> gen_var ~suffix:("-fun-arg-" ^ name ^ "-" ^ aid) ()) in 207 | let rtn_type = gen_var ~suffix:("-fun-rtn-" ^ name) () in 208 | let fun_type = multiple_func arg_types rtn_type in 209 | Env.T.(List.fold (List.zip_exn args arg_types) ~f:Env.cons ~init:tyenv %<< (name, fun_type)) 210 | ) 211 | in 212 | let infer_each_func (tyenv, tyrel) ( 213 | { Func.name ; Func.args ; Func.exp ; _ } : Func.t 214 | ) = 215 | let arg_types = List.map args ~f:(fun aid -> Env.find_exn tyenv aid) in 216 | let (tyenv, tyrel, rtn_type) = infer tyenv tyrel exp in 217 | let fun_type = multiple_func arg_types rtn_type in 218 | let tyrel = Relation.T.(tyrel %<< (Env.find_exn tyenv name == fun_type)) in 219 | (tyenv, tyrel) in 220 | let (tyenv, tyrel) = List.fold fs ~f:infer_each_func ~init:(init_tyenv, Relation.empty) in 221 | let tyenv = Relation.unify (tyenv (* |> Env.inspect *) ) (tyrel (* |> Relation.inspect *) ) in 222 | let fids = List.map fs ~f:(fun ({ Func.name ; _ } : Func.t) -> name) in 223 | Env.filteri tyenv ~f:(fun ~key ~data:_ -> List.mem fids key ~equal:(=)) 224 | end 225 | 226 | let use_refinement_annotation = ref true 227 | 228 | let reftype_env_of (self : t) : Type.Env.t = 229 | let tyenv = SimpleTypeInfer.main self in 230 | let env = Type.Env.from_simple_type_env tyenv in 231 | if !use_refinement_annotation then 232 | List.fold (recfuns self) ~init:env ~f:(fun env func -> 233 | match func |> Func.annotation |> Func.Annotation.reftype with 234 | | None -> env 235 | | Some reftype -> 236 | let key = Func.(func.name) in 237 | Type.Env.T.(env @<< from_map (key, Type.RefType.fresh reftype)) 238 | ) 239 | else 240 | env 241 | -------------------------------------------------------------------------------- /src/mlLoader/sugarProgram.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Sexplib.Std 3 | 4 | type t = item list 5 | and item = BindFunc of recfun | BindValue of Identity.t * exp | Eval of exp 6 | and recfun = { name: Identity.t; args: args; exp: exp; annotation: Program.Func.Annotation.t } 7 | and args = Identity.t list 8 | and exp = 9 | | LetExp of Identity.t * exp * exp 10 | | LetRecExp of (Identity.t * exp) list * exp 11 | | IfExp of exp * exp * exp 12 | | BranchExp of (exp * exp) list 13 | | FailExp 14 | | AssertExp of exp 15 | | FuncCallExp of Identity.t * exp list 16 | | AbsExp of Identity.t list * exp 17 | | OpExp of exp * Op.t * exp 18 | | SingleOpExp of Op.t * exp 19 | | ObjExp of Objt.t 20 | [@@deriving sexp, hash, eq, ord] 21 | 22 | module Expr = struct 23 | type t = exp 24 | [@@deriving sexp, hash, eq, ord] 25 | 26 | include Formatable.Make(struct 27 | module I = Formatable 28 | type nonrec t = t 29 | let rec to_format (self : t) = 30 | match self with 31 | | LetExp (vid, exp1, exp2) -> I.block [ 32 | I.line ("let " ^ vid ^ " ="); 33 | I.indent (to_format exp1); 34 | I.line "in"; 35 | I.block [to_format exp2] 36 | ] 37 | | LetRecExp (binds, exp') -> I.block [ 38 | I.line "let rec "; 39 | List.map binds ~f:(fun (vid, exp) -> 40 | I.block [ 41 | I.line (vid ^ " ="); 42 | I.indent (to_format exp); 43 | ] 44 | ) |> I.block |> I.indent; 45 | I.line "in"; 46 | I.block [to_format exp'] 47 | ] 48 | | BranchExp (branches) -> I.block [ 49 | I.line "select"; 50 | I.block (List.map branches ~f:(fun (exp_cond, exp_then) -> 51 | I.block [ 52 | I.line "when"; 53 | I.indent (to_format exp_cond); 54 | I.indent (I.block [ 55 | I.line "->"; 56 | I.indent (to_format exp_then); 57 | ]) 58 | ] 59 | )) 60 | ] 61 | | IfExp (exp_cond, exp_then, exp_else) -> I.block [ 62 | I.line "if"; 63 | I.indent (to_format exp_cond); 64 | I.line "then"; 65 | I.indent (to_format exp_then); 66 | I.line "else"; 67 | I.indent (to_format exp_else) 68 | ] 69 | | FailExp -> 70 | I.text "fail" 71 | | AssertExp e -> I.inline [ 72 | I.text "assert ("; 73 | to_format e; 74 | I.text ")"; 75 | ] 76 | | AbsExp (ids, e) -> 77 | I.inline [ 78 | I.text ("\\" ^ List.to_string ids ~f:(fun x -> x)); 79 | to_format e; 80 | ] 81 | | ObjExp obj -> 82 | I.text (Objt.string_of obj) 83 | | OpExp (e1, op, e2) -> I.inline [ 84 | I.text "("; 85 | to_format e1; 86 | I.text (" " ^ Op.string_of op ^ " "); 87 | to_format e2; 88 | I.text ")" 89 | ] 90 | | SingleOpExp (op, e) -> I.inline [ 91 | I.text "("; 92 | I.text (Op.string_of op ^ " "); 93 | to_format e; 94 | I.text ")" 95 | ] 96 | | FuncCallExp (fid, exps) -> 97 | let args = List.map exps ~f:(fun exp -> to_format exp) in 98 | I.inline [ 99 | I.text "("; 100 | I.text fid; 101 | I.text " "; 102 | I.inline (I.joint args (I.text " ")); 103 | I.text ")" 104 | ] 105 | end) 106 | 107 | end 108 | 109 | module StructureItem = struct 110 | type t = item 111 | 112 | let bind_func (fp : recfun) : t = BindFunc fp 113 | let bind_value ((v : Identity.t), (exp : exp)) : t = BindValue (v, exp) 114 | let eval (exp : exp) : t = Eval exp 115 | 116 | let expr_map (self : t) ~f : t = 117 | match self with 118 | | BindFunc recfun -> BindFunc { recfun with exp = f recfun.exp } 119 | | BindValue (v, exp) -> BindValue (v, f exp) 120 | | Eval exp -> Eval (f exp) 121 | end 122 | 123 | module Func = struct 124 | type t = recfun 125 | 126 | let make ?(annotation = Program.Func.Annotation.empty) ~name ~args ~exp () = 127 | { name; args; exp; annotation } 128 | 129 | let name_of (self : t) = self.name 130 | end 131 | 132 | let make_recfun = Func.make 133 | 134 | include Formatable.Make(struct 135 | module I = Formatable 136 | type nonrec t = t 137 | let to_format (items : t) = 138 | let from_recfun item = 139 | match item with 140 | | Eval exp -> Expr.to_format exp 141 | | BindValue (name, exp) -> I.block [ 142 | I.block [ 143 | I.text (name ^ " =") 144 | ]; 145 | I.indent (Expr.to_format exp) 146 | ] 147 | | BindFunc { name; args; exp; _ } -> I.block [ 148 | I.block [ 149 | I.inline (List.map (I.joint (name :: args) " ") ~f:(fun tx -> I.text tx)); 150 | I.text " =" 151 | ]; 152 | I.indent (Expr.to_format exp) 153 | ] 154 | in 155 | let funfmts = List.map items ~f:from_recfun in 156 | I.block [ 157 | I.inline (I.joint funfmts (I.line "and")); 158 | ] 159 | end) 160 | 161 | let to_pfun { name; args; exp = _exp; annotation; } ~exp = 162 | Program.Func.Fields.create ~name ~args ~exp ~annotation 163 | 164 | let recfuns_of (items : t) : Func.t list = List.map items ~f:(function BindFunc f -> Some f | _ -> None) |> List.filter_opt 165 | (* let main_exp_of (SugarProgram (_, e)) = e *) 166 | 167 | type sexp_and_hole = Program.Exp.t * (Program.Exp.t -> Program.Exp.t) 168 | type obj_and_hole = Objt.t * (Program.Exp.t -> Program.Exp.t) 169 | 170 | let id x = x 171 | let mk_var vid = vid |> Objt.mk_var |> (fun v -> ObjExp v) 172 | let mk_int i = i |> Objt.mk_int |> (fun v -> ObjExp v) 173 | let mk_true = ObjExp Objt.true_ 174 | let mk_false = ObjExp Objt.false_ 175 | 176 | module L = Label.Make(struct let label = "$tmp:" end) 177 | let gen_id = L.gen 178 | 179 | let make_semicolon_exps exp1 exp2 = LetExp (gen_id (), exp1, exp2) 180 | 181 | let rec free_var_set_of (self : exp) : Identity.Set.t = 182 | match self with 183 | | LetExp (vid, e1, e2) -> Identity.Set.union (free_var_set_of e1) (free_var_set_of e2) |> (fun x -> Identity.Set.remove x vid) 184 | | LetRecExp (binds, e2) -> 185 | let vids = List.map binds ~f:Tuple2.get1 |> Identity.Set.of_list in 186 | let set = List.fold binds ~init:(free_var_set_of e2) ~f:(fun acc (_, exp) -> Identity.Set.union acc (free_var_set_of exp)) in 187 | Identity.Set.diff set vids 188 | | BranchExp (branches) -> List.map branches ~f:(fun (ce, e) -> Identity.Set.union (free_var_set_of ce) (free_var_set_of e)) |> Identity.Set.union_list 189 | | IfExp (e1, e2, e3) -> Identity.Set.union (free_var_set_of e1) (free_var_set_of e2) |> Identity.Set.union (free_var_set_of e3) 190 | | FailExp -> Identity.Set.empty 191 | | AssertExp e1 -> free_var_set_of e1 192 | | FuncCallExp (fid, es) -> Identity.Set.add (List.map es ~f:free_var_set_of |> Identity.Set.union_list) fid 193 | | AbsExp (ids, e) -> Identity.Set.diff (free_var_set_of e) (Identity.Set.of_list ids) 194 | | OpExp (e1, _op, e2) -> Identity.Set.union (free_var_set_of e1) (free_var_set_of e2) 195 | | SingleOpExp (_op, e) -> free_var_set_of e 196 | | ObjExp obj -> Objt.vids_of obj |> Identity.Set.of_list 197 | 198 | module Mapper = struct 199 | type t = { 200 | exp: t -> exp -> exp; 201 | let_: t -> (Identity.t * exp * exp) -> exp; 202 | letrec_: t -> ((Identity.t * exp) list * exp) -> exp; 203 | if_: t -> (exp * exp * exp) -> exp; 204 | branch: t -> (exp * exp) list -> exp; 205 | fail: t -> unit -> exp; 206 | assert_: t -> exp -> exp; 207 | funccall: t -> (Identity.t * exp list) -> exp; 208 | abs: t -> (Identity.t list * exp) -> exp; 209 | op2: t -> (exp * Op.t * exp) -> exp; 210 | op1: t -> (Op.t * exp) -> exp; 211 | obj: t -> Objt.t -> exp; 212 | } 213 | 214 | 215 | let default_mapper : t = { 216 | exp = (fun (self : t) (exp : exp) -> 217 | match exp with 218 | | LetExp (vid, e1, e2) -> self.let_ self (vid, e1, e2) 219 | | LetRecExp (binds, e) -> self.letrec_ self (binds, e) 220 | | BranchExp (branches) -> self.branch self branches 221 | | IfExp (e1, e2, e3) -> self.if_ self (e1, e2, e3) 222 | | FailExp -> self.fail self () 223 | | AssertExp e1 -> self.assert_ self e1 224 | | FuncCallExp (fid, es) -> self.funccall self (fid, es) 225 | | AbsExp (ids, e) -> self.abs self (ids, e) 226 | | OpExp (e1, op, e2) -> self.op2 self (e1, op, e2) 227 | | SingleOpExp (op, e) -> self.op1 self (op, e) 228 | | ObjExp obj -> self.obj self obj 229 | ); 230 | let_ = (fun self (vid, e1, e2) -> LetExp (vid, self.exp self e1, self.exp self e2)); 231 | letrec_ = (fun self (binds, e2) -> LetRecExp (List.map binds ~f:(fun (vid, e) -> (vid, self.exp self e)), self.exp self e2)); 232 | if_ = (fun self (e1, e2, e3) -> IfExp (self.exp self e1, self.exp self e2, self.exp self e3)); 233 | branch = (fun self cs -> BranchExp (List.map cs ~f:(fun (c, e) -> (self.exp self c, self.exp self e)))); 234 | fail = (fun _self () -> FailExp); 235 | assert_ = (fun self e -> AssertExp (self.exp self e)); 236 | funccall = (fun self (fid, aes) -> FuncCallExp (fid, List.map aes ~f:(self.exp self))); 237 | abs = (fun self (fids, fe) -> AbsExp (fids, self.exp self fe)); 238 | op2 = (fun self (e1, op, e2) -> OpExp (self.exp self e1, op, self.exp self e2)); 239 | op1 = (fun self (op, e) -> SingleOpExp (op, self.exp self e)); 240 | obj = (fun _self obj -> ObjExp obj); 241 | } 242 | 243 | let apply_expr (self : t) (exp : exp) : exp = self.exp self exp 244 | end 245 | 246 | let expr_map (items : t) ~f : t = List.map items ~f:(StructureItem.expr_map ~f) 247 | 248 | let map (self : t) ~f : t = List.map self ~f 249 | -------------------------------------------------------------------------------- /src/data/type.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | let (=) = Poly.(=) 4 | 5 | module RefType = struct 6 | type t = 7 | Func of Identity.t * t * t 8 | | Int_ of Identity.t * Cond.t 9 | | Bottom 10 | | Top 11 | [@@deriving sexp, variants, eq, ord, hash] 12 | 13 | module T = struct 14 | let int_ x y = Int_ (x, y) 15 | end 16 | 17 | module L = Label.Make(struct let label = "V-reftype" end) 18 | 19 | let is_base = function Int_ (_, _) -> true | _ -> false 20 | let rec subst self orig_var new_var = 21 | match self with 22 | | Int_ (v, cond) -> 23 | if v = orig_var 24 | then Int_ (new_var, Cond.subst cond orig_var new_var) 25 | else Int_ (v, Cond.subst cond orig_var new_var) 26 | | Func (v, t1, t2) -> 27 | if v = orig_var 28 | then Func (new_var, subst t1 orig_var new_var, subst t2 orig_var new_var) 29 | else Func (v, subst t1 orig_var new_var, subst t2 orig_var new_var) 30 | | _ -> self 31 | 32 | let subst_nu self new_var = 33 | match self with 34 | | Int_ (nu, _) -> subst self nu new_var 35 | | Func (nu, _, _) -> subst self nu new_var 36 | | _ -> self 37 | 38 | let rec fresh self = 39 | match self with 40 | | Int_ (v, cond) -> 41 | let fresh_id = L.gen () in 42 | subst (Int_ (v, cond)) v fresh_id 43 | | Func (v, t1, t2) -> 44 | let fresh_id = L.gen () in 45 | subst (Func (v, fresh t1, fresh t2)) v fresh_id 46 | | _ -> self 47 | 48 | let rec assign_unknown (self : t) (tsubst : Cond.UnknownSubst.t) : t = 49 | match self with 50 | | Int_ (v, cond) -> 51 | Int_ (v, Cond.UnknownSubst.assign tsubst cond) 52 | | Func (v, t1, t2) -> 53 | Func (v, assign_unknown t1 tsubst, assign_unknown t2 tsubst) 54 | | _ -> failwith "unexpected" 55 | 56 | let rec assign_obj (self : t) (var : Identity.t) (obj : Objt.t) : t = 57 | match self with 58 | | Int_ (v, cond') -> 59 | Int_ (v, Cond.assign_obj cond' var obj) 60 | | Func (v, ty1, ty2) -> 61 | Func (v, assign_obj ty1 var obj, assign_obj ty2 var obj) 62 | | x -> x 63 | 64 | let assign_nu (self : t) (obj : Objt.t) : t = 65 | match self with 66 | | Int_ (v, _) -> 67 | assign_obj self v obj 68 | | Func (v, _, _) -> 69 | assign_obj self v obj 70 | | x -> x 71 | 72 | let uapp_of (self : t) : Cond.UnknownApp.t option = 73 | match self with 74 | | Int_ (_v, cond) -> Cond.uapp_of cond 75 | | _ -> None 76 | 77 | let rec uapps_of (self : t) : Cond.UnknownApp.t list = 78 | match self with 79 | | Int_ (_v, cond) -> Cond.uapps_of cond 80 | | Func (_v, ty1, ty2) -> uapps_of ty1 @ uapps_of ty2 81 | | _ -> failwith "unexpected" 82 | 83 | let name_of (self : t) = 84 | match self with 85 | | Int_ (nu, _) -> nu 86 | | Func (nu, _, _) -> nu 87 | | _ -> failwith "unexpected" 88 | 89 | let arg = function 90 | | Func (_vid, t1, _t2) -> t1 91 | | _ -> failwith "unexpected" 92 | let rtn = function 93 | | Func (_vid, _t1, t2) -> t2 94 | | _ -> failwith "unexpected" 95 | let vid = function 96 | | Func (vid, _t1, _t2) -> vid 97 | | _ -> failwith "unexpected" 98 | 99 | let rec argument_types (self : t) = 100 | match self with 101 | | Func (_, t1, t2) -> t1 :: argument_types t2 102 | | _ -> [] 103 | 104 | let rec id_types_for_func (self : t) len = 105 | if len = 0 then 106 | [] 107 | else 108 | match self with 109 | | Func (id, t1, t2) -> (id, t1) :: id_types_for_func t2 (len - 1) 110 | | Int_ (id, _) -> [(id, self)] 111 | | _ -> [] 112 | 113 | module D = struct 114 | let denote x t = 115 | match t with 116 | | Int_ (v, cond') -> 117 | Cond.subst cond' v x 118 | | Func _ -> 119 | Cond.true_ 120 | | _ -> failwith "unexpected" 121 | end 122 | include D 123 | 124 | let from_condition ~f = 125 | let new_vid = L.gen () in int_ new_vid (f new_vid) 126 | 127 | include Formatable.Make(struct 128 | module I = Formatable 129 | 130 | type nonrec t = t 131 | let rec to_format self = 132 | match self with 133 | | Func (vid, t1, t2) -> 134 | I.inline [ 135 | I.text ("( " ^ Identity.Short.show vid ^ " : "); 136 | to_format t1; 137 | I.text " -> "; 138 | to_format t2; 139 | I.text ")"; 140 | ] 141 | | Int_ (vid, c1) -> 142 | I.inline [ 143 | I.text "{ "; 144 | I.text (Identity.Short.show vid); 145 | I.text " : int | "; 146 | Cond.Simplifier.to_format c1; 147 | I.text " }"; 148 | ] 149 | | Bottom -> 150 | I.noline "bottom"; 151 | | Top -> 152 | I.noline "top"; 153 | end) 154 | 155 | module Ord = struct 156 | type nonrec t = t * t 157 | 158 | let rec denote = function 159 | | (Top, _) -> Cond.true_ 160 | | (_, Top) -> Cond.false_ 161 | | (Int_ (v, cond1), Int_ (w, cond2)) -> 162 | Cond.T.(cond1 ==> Cond.subst cond2 w v) 163 | | (Func (v, t1, t2), Func (w, t1', t2')) -> 164 | Cond.T.(denote (subst t1' w v, t1) && (D.denote v t1' ==> denote (t2, subst t2' w v))) 165 | | (_e1, _e2) -> failwith "illigal pattern" 166 | end 167 | 168 | module FromSimpleType = struct 169 | let refine ?(prefix = "") ?(main = false) stype = 170 | let rec f ~truthy variables = function 171 | | SimpleType.Func (t1, t2) -> 172 | let rt1 = f ~truthy variables t1 in 173 | let new_id = L.gen () in 174 | let new_variables = if SimpleType.is_simple t1 then (new_id :: variables) else variables in 175 | let rt2 = f ~truthy:(truthy (* && not (SimpleType.is_simple t2) *) ) new_variables t2 in 176 | Func (new_id, rt1, rt2) 177 | | SimpleType.Int_ -> 178 | let new_id = L.gen () in 179 | let cond = 180 | if truthy then Cond.true_ 181 | else Cond.UnknownApp.from_predicate (UnknownPredicate.init ~prefix (new_id :: variables)) |> Cond.UnknownApp.to_cond in 182 | Int_ (new_id, cond) 183 | | _ -> failwith "unexpected" 184 | in f ~truthy:main [] stype 185 | end 186 | 187 | let rec conds_of = function 188 | | Int_ (_, cond) -> [cond] 189 | | Func (_, t1, t2) -> conds_of t1 @ conds_of t2 190 | | _ -> [] 191 | 192 | let cond_of = function 193 | | Int_ (_, cond) -> Some cond 194 | | _ -> None 195 | end 196 | 197 | module Env = struct 198 | module Map = Identity.Map 199 | module Element = struct 200 | type t = Condition of Cond.t | Mapping of Identity.t * RefType.t 201 | [@@deriving sexp] 202 | end 203 | 204 | type t = RefType.t Map.t * (Cond.t list) 205 | 206 | let empty = (Map.empty, []) 207 | let denote ((maps, cs) : t) : Cond.t = 208 | let var_types = Map.to_alist maps in 209 | Cond.T.(List.fold var_types ~init:Cond.true_ ~f:(fun acc (x, t) -> Cond.T.(acc && RefType.denote x t)) && Cond.forall cs ident) 210 | 211 | let find_exn (maps, _) key = 212 | Map.find_exn maps key 213 | 214 | let ty_map (mp, cs) ~f = 215 | (Map.map mp ~f, cs) 216 | 217 | let types_of (mp, _) = Map.data mp 218 | 219 | module T = struct 220 | let (@<<) (map, cs) = function 221 | | Element.Condition cond -> (map, cond :: cs) 222 | | Element.Mapping (key, data) -> 223 | match Map.add map ~key ~data with 224 | | `Ok map -> map, cs 225 | | `Duplicate -> assert false 226 | 227 | let from_condition cond = Element.Condition cond 228 | let from_map (k, v) = Element.Mapping (k, v) 229 | end 230 | 231 | let assign_unknown (mp, conds) tsubst = 232 | (Map.map mp ~f:(fun ty -> RefType.assign_unknown ty tsubst), conds) 233 | 234 | let from_simple_type_env simptyenv = 235 | SimpleType.Env.fold simptyenv ~init:empty ~f:(fun ~key ~data tyenv -> 236 | T.(tyenv @<< from_map (key, (RefType.FromSimpleType.refine ~prefix:key ~main:(key = "main") data))) 237 | ) 238 | 239 | let to_string (mp, conds) = 240 | List.fold (Map.to_alist mp) ~init:"" ~f:( 241 | fun str (key, data) -> 242 | key ^ ": " ^ RefType.to_string data ^ "\n\n" ^ str 243 | ) ^ "\n\n" ^ List.fold conds ~init:"" ~f:( 244 | fun str cond -> Cond.to_string cond ^ str 245 | ) 246 | end 247 | 248 | module Extended = struct 249 | type t = 250 | And_ of t * t 251 | | Impl of Cond.t * RefType.t 252 | [@@deriving sexp, variants] 253 | 254 | 255 | module Ord = struct 256 | type nonrec t = t * RefType.t 257 | 258 | let rec denote tyenv = function 259 | | (And_ (ut1, ut2), t) -> 260 | Cond.T.(denote tyenv (ut1, t) && denote tyenv (ut2, t)) 261 | | (Impl (cond, t1), t2) -> 262 | Cond.T.(Env.denote tyenv ==> (cond ==> RefType.Ord.denote (t1, t2))) 263 | end 264 | 265 | module And_Plus = struct 266 | let rec fold ~init ~impl t = 267 | let (%%) acc t' = fold t' ~init:acc ~impl in 268 | let and_ _v t1 t2 = init %% t1 %% t2 in 269 | let impl _v cond reftype = impl init cond reftype in 270 | Variants.map t ~and_ ~impl 271 | 272 | let map_to_cond ~f t = 273 | let impl acc cond reftype = Cond.T.(acc && f cond reftype) in 274 | fold ~init:Cond.true_ ~impl t 275 | 276 | let rec map ~f t = 277 | let dig t = map ~f t in 278 | let and_ _v t1 t2 = and_ (dig t1) (dig t2) in 279 | let impl _v cond reftype = f cond reftype in 280 | Variants.map t ~and_ ~impl 281 | end 282 | 283 | let to_ref = function 284 | | Impl (_, ext) -> ext 285 | | _ -> failwith "unexpected" 286 | let rec denote x = function 287 | | And_ (ut1, ut2) -> 288 | Cond.T.(denote x ut1 || denote x ut2) 289 | | Impl (cond, t) -> 290 | Cond.T.(cond ==> RefType.denote x t) 291 | 292 | let lift reftype = 293 | Impl (Cond.true_, reftype) 294 | let fall = function 295 | | Impl (_, reftype) -> reftype 296 | | _ -> failwith "unexpected" 297 | 298 | let multiple_impl cond t = 299 | let f cond' reftype = impl Cond.T.(cond && cond') reftype in 300 | And_Plus.map t ~f 301 | 302 | let rec subst self orig_var new_var = 303 | match self with 304 | | And_ (ut1, ut2) -> 305 | And_ (subst ut1 orig_var new_var, subst ut2 orig_var new_var) 306 | | Impl (cond, t) -> 307 | Impl (Cond.subst cond orig_var new_var, RefType.subst t orig_var new_var) 308 | 309 | let rec subst_nu self new_var = 310 | match self with 311 | | And_ (ut1, ut2) -> 312 | And_ (subst_nu ut1 new_var, subst_nu ut2 new_var) 313 | | Impl (cond, t) -> 314 | Impl (cond, RefType.subst_nu t new_var) 315 | 316 | module T = struct 317 | let (&&) x y = And_ (x, y) 318 | let (==>) x y = Impl (x, y) 319 | let (==>&) x y = multiple_impl x y 320 | end 321 | 322 | let rec assign_unknown (self : t) tsubst = 323 | match self with 324 | | And_ (ut1, ut2) -> 325 | And_ (assign_unknown ut1 tsubst, assign_unknown ut2 tsubst) 326 | | Impl (cond, t1) -> 327 | Impl (Cond.UnknownSubst.assign tsubst cond, RefType.assign_unknown t1 tsubst) 328 | 329 | include Formatable.Make(struct 330 | module I = Formatable 331 | 332 | type nonrec t = t 333 | let rec to_format self = 334 | match self with 335 | | And_ (t1, t2) -> 336 | I.inline [ 337 | I.text "("; 338 | to_format t1; 339 | I.text " & "; 340 | to_format t2; 341 | I.text ")"; 342 | ] 343 | | Impl (c1, t1) -> 344 | I.inline [ 345 | I.text "("; 346 | Cond.Simplifier.to_format c1; 347 | I.text " ==> "; 348 | RefType.to_format t1; 349 | I.text ")"; 350 | ] 351 | end) 352 | end 353 | include Extended 354 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "{}" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright {yyyy} {name of copyright owner} 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | --------------------------------------------------------------------------------