From 546bd3e14957199cc1efc0810fb4a2c58ba23fde Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 29 Oct 2018 15:52:20 +0000 Subject: Pretty printer tweaks for ASL parser No longer remove braces around singleton expressions, as this can produce unreadably long lines in ASL parser output when assignments are converted to lets. Add brackets around as-patterns for type-variables --- src/pretty_print_sail.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'src') diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index 0b0a8305..37c48220 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -237,7 +237,7 @@ let rec doc_pat (P_aux (p_aux, _) as pat) = (* P_var short form sugar *) | P_var (P_aux (P_id id, _), TP_aux (TP_var kid, _)) when Id.compare (id_of_kid kid) id == 0 -> doc_kid kid - | P_var (pat, tpat) -> separate space [doc_pat pat; string "as"; doc_typ_pat tpat] + | P_var (pat, tpat) -> parens (separate space [doc_pat pat; string "as"; doc_typ_pat tpat]) | P_vector pats -> brackets (separate_map (comma ^^ space) doc_pat pats) | P_vector_concat pats -> separate_map (space ^^ string "@" ^^ space) doc_pat pats | P_wild -> string "_" @@ -286,7 +286,6 @@ let fixities = let rec doc_exp (E_aux (e_aux, _) as exp) = match e_aux with | E_block [] -> string "()" - | E_block [exp] -> doc_exp exp | E_block exps -> surround 2 0 lbrace (doc_block exps) rbrace | E_nondet exps -> assert false (* This is mostly for the -convert option *) -- cgit v1.2.3 From 5298e209f0ae12e51f3050888e18ad9be09543e4 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 31 Oct 2018 14:56:19 +0000 Subject: Improve error messages for unsolved function quantifiers For example, for a function like ``` val aget_X : forall 'n, 0 <= 'n <= 31. int('n) -> bits(64) function test(n : int) -> unit = { let y = aget_X(n); () } ``` we get the message > Could not resolve quantifiers for aget_X (0 <= 'ex7# & 'ex7# <= 31) > > Try adding named type variables for n : atom('ex7#) > > The property (0 <= n & n <= 31) must hold which suggests adding a name for the type variable 'ex7#, and gives the property in terms of the variable n. If we give n a type variable name: ``` val test : int -> unit function test(n as 'N) = { let y = aget_X(n); () } ``` It will suggest a constraint involving the type variable name > Could not resolve quantifiers for aget_X (0 <= 'ex6# & 'ex6# <= 31) > > Try adding the constraint (0 <= 'N & 'N <= 31) --- src/anf.ml | 14 ++-- src/ast_util.ml | 133 +++++++++++++++++++++++++++++++++-- src/ast_util.mli | 29 +++++++- src/c_backend.ml | 2 +- src/interpreter.ml | 4 +- src/monomorphise.ml | 8 +-- src/ocaml_backend.ml | 2 +- src/pretty_print_coq.ml | 2 +- src/rewriter.ml | 2 +- src/rewrites.ml | 46 ++++++------- src/type_check.ml | 180 ++++++++---------------------------------------- src/type_check.mli | 14 ++-- src/type_error.ml | 120 +++++++++++++++++++++++--------- 13 files changed, 318 insertions(+), 238 deletions(-) (limited to 'src') diff --git a/src/anf.ml b/src/anf.ml index 0f98caff..2e7b6b65 100644 --- a/src/anf.ml +++ b/src/anf.ml @@ -458,17 +458,17 @@ let rec split_block l = function let rec anf_pat ?global:(global=false) (P_aux (p_aux, annot) as pat) = let mk_apat aux = AP_aux (aux, env_of_annot annot, fst annot) in match p_aux with - | P_id id when global -> mk_apat (AP_global (id, pat_typ_of pat)) - | P_id id -> mk_apat (AP_id (id, pat_typ_of pat)) - | P_wild -> mk_apat (AP_wild (pat_typ_of pat)) + | P_id id when global -> mk_apat (AP_global (id, typ_of_pat pat)) + | P_id id -> mk_apat (AP_id (id, typ_of_pat pat)) + | P_wild -> mk_apat (AP_wild (typ_of_pat pat)) | P_tup pats -> mk_apat (AP_tup (List.map (fun pat -> anf_pat ~global:global pat) pats)) - | P_app (id, [subpat]) -> mk_apat (AP_app (id, anf_pat ~global:global subpat, pat_typ_of pat)) - | P_app (id, pats) -> mk_apat (AP_app (id, mk_apat (AP_tup (List.map (fun pat -> anf_pat ~global:global pat) pats)), pat_typ_of pat)) + | P_app (id, [subpat]) -> mk_apat (AP_app (id, anf_pat ~global:global subpat, typ_of_pat pat)) + | P_app (id, pats) -> mk_apat (AP_app (id, mk_apat (AP_tup (List.map (fun pat -> anf_pat ~global:global pat) pats)), typ_of_pat pat)) | P_typ (_, pat) -> anf_pat ~global:global pat | P_var (pat, _) -> anf_pat ~global:global pat | P_cons (hd_pat, tl_pat) -> mk_apat (AP_cons (anf_pat ~global:global hd_pat, anf_pat ~global:global tl_pat)) - | P_list pats -> List.fold_right (fun pat apat -> mk_apat (AP_cons (anf_pat ~global:global pat, apat))) pats (mk_apat (AP_nil (pat_typ_of pat))) - | P_lit (L_aux (L_unit, _)) -> mk_apat (AP_wild (pat_typ_of pat)) + | P_list pats -> List.fold_right (fun pat apat -> mk_apat (AP_cons (anf_pat ~global:global pat, apat))) pats (mk_apat (AP_nil (typ_of_pat pat))) + | P_lit (L_aux (L_unit, _)) -> mk_apat (AP_wild (typ_of_pat pat)) | _ -> anf_error ~loc:(fst annot) ("Could not convert pattern to ANF: " ^ string_of_pat pat) let rec apat_globals (AP_aux (aux, _, _)) = diff --git a/src/ast_util.ml b/src/ast_util.ml index 9966742e..9490366f 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -1082,7 +1082,7 @@ let rec tyvars_of_nexp (Nexp_aux (nexp,_)) = | Nexp_neg n -> tyvars_of_nexp n | Nexp_app (_, nexps) -> List.fold_left KidSet.union KidSet.empty (List.map tyvars_of_nexp nexps) -let rec tyvars_of_nc (NC_aux (nc, _)) = +let rec tyvars_of_constraint (NC_aux (nc, _)) = match nc with | NC_equal (nexp1, nexp2) | NC_bounded_ge (nexp1, nexp2) @@ -1092,7 +1092,7 @@ let rec tyvars_of_nc (NC_aux (nc, _)) = | NC_set (kid, _) -> KidSet.singleton kid | NC_or (nc1, nc2) | NC_and (nc1, nc2) -> - KidSet.union (tyvars_of_nc nc1) (tyvars_of_nc nc2) + KidSet.union (tyvars_of_constraint nc1) (tyvars_of_constraint nc2) | NC_app (id, nexps) -> List.fold_left KidSet.union KidSet.empty (List.map tyvars_of_nexp nexps) | NC_true @@ -1112,7 +1112,7 @@ let rec tyvars_of_typ (Typ_aux (t,_)) = List.fold_left (fun s ta -> KidSet.union s (tyvars_of_typ_arg ta)) KidSet.empty tas | Typ_exist (kids, nc, t) -> - let s = KidSet.union (tyvars_of_typ t) (tyvars_of_nc nc) in + let s = KidSet.union (tyvars_of_typ t) (tyvars_of_constraint nc) in List.fold_left (fun s k -> KidSet.remove k s) s kids and tyvars_of_typ_arg (Typ_arg_aux (ta,_)) = match ta with @@ -1123,7 +1123,7 @@ and tyvars_of_typ_arg (Typ_arg_aux (ta,_)) = let tyvars_of_quant_item (QI_aux (qi, _)) = match qi with | QI_id (KOpt_aux ((KOpt_none kid | KOpt_kind (_, kid)), _)) -> KidSet.singleton kid - | QI_const nc -> tyvars_of_nc nc + | QI_const nc -> tyvars_of_constraint nc let is_kid_generated kid = String.contains (string_of_kid kid) '#' @@ -1488,3 +1488,128 @@ and locate_fexps : 'a. l -> 'a fexps -> 'a fexps = fun l (FES_aux (FES_Fexps (fe and locate_fexp : 'a. l -> 'a fexp -> 'a fexp = fun l (FE_aux (FE_Fexp (id, exp), (_, annot))) -> FE_aux (FE_Fexp (locate_id l id, locate l exp), (l, annot)) + +(**************************************************************************) +(* 1. Substitutions *) +(**************************************************************************) + +let rec nexp_subst sv subst (Nexp_aux (nexp, l)) = Nexp_aux (nexp_subst_aux sv subst nexp, l) +and nexp_subst_aux sv subst = function + | Nexp_id v -> Nexp_id v + | Nexp_var kid -> if Kid.compare kid sv = 0 then subst else Nexp_var kid + | Nexp_constant c -> Nexp_constant c + | Nexp_times (nexp1, nexp2) -> Nexp_times (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2) + | Nexp_sum (nexp1, nexp2) -> Nexp_sum (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2) + | Nexp_minus (nexp1, nexp2) -> Nexp_minus (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2) + | Nexp_app (id, nexps) -> Nexp_app (id, List.map (nexp_subst sv subst) nexps) + | Nexp_exp nexp -> Nexp_exp (nexp_subst sv subst nexp) + | Nexp_neg nexp -> Nexp_neg (nexp_subst sv subst nexp) + +let rec nexp_set_to_or l subst = function + | [] -> raise (Reporting_basic.err_unreachable l __POS__ "Empty set in constraint") + | [int] -> NC_equal (subst, nconstant int) + | (int :: ints) -> NC_or (mk_nc (NC_equal (subst, nconstant int)), mk_nc (nexp_set_to_or l subst ints)) + +let rec nc_subst_nexp sv subst (NC_aux (nc, l)) = NC_aux (nc_subst_nexp_aux l sv subst nc, l) +and nc_subst_nexp_aux l sv subst = function + | NC_equal (n1, n2) -> NC_equal (nexp_subst sv subst n1, nexp_subst sv subst n2) + | NC_bounded_ge (n1, n2) -> NC_bounded_ge (nexp_subst sv subst n1, nexp_subst sv subst n2) + | NC_bounded_le (n1, n2) -> NC_bounded_le (nexp_subst sv subst n1, nexp_subst sv subst n2) + | NC_not_equal (n1, n2) -> NC_not_equal (nexp_subst sv subst n1, nexp_subst sv subst n2) + | NC_set (kid, ints) as set_nc -> + if Kid.compare kid sv = 0 + then nexp_set_to_or l (mk_nexp subst) ints + else set_nc + | NC_or (nc1, nc2) -> NC_or (nc_subst_nexp sv subst nc1, nc_subst_nexp sv subst nc2) + | NC_and (nc1, nc2) -> NC_and (nc_subst_nexp sv subst nc1, nc_subst_nexp sv subst nc2) + | NC_app (id, nexps) -> NC_app (id, List.map (nexp_subst sv subst) nexps) + | NC_false -> NC_false + | NC_true -> NC_true + +let rec typ_subst_nexp sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_nexp_aux sv subst typ, l) +and typ_subst_nexp_aux sv subst = function + | Typ_internal_unknown -> Typ_internal_unknown + | Typ_id v -> Typ_id v + | Typ_var kid -> Typ_var kid + | Typ_fn (arg_typs, ret_typ, effs) -> Typ_fn (List.map (typ_subst_nexp sv subst) arg_typs, typ_subst_nexp sv subst ret_typ, effs) + | Typ_bidir (typ1, typ2) -> Typ_bidir (typ_subst_nexp sv subst typ1, typ_subst_nexp sv subst typ2) + | Typ_tup typs -> Typ_tup (List.map (typ_subst_nexp sv subst) typs) + | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_nexp sv subst) args) + | Typ_exist (kids, nc, typ) when KidSet.mem sv (KidSet.of_list kids) -> Typ_exist (kids, nc, typ) + | Typ_exist (kids, nc, typ) -> Typ_exist (kids, nc_subst_nexp sv subst nc, typ_subst_nexp sv subst typ) +and typ_subst_arg_nexp sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_nexp_aux sv subst arg, l) +and typ_subst_arg_nexp_aux sv subst = function + | Typ_arg_nexp nexp -> Typ_arg_nexp (nexp_subst sv subst nexp) + | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_nexp sv subst typ) + | Typ_arg_order ord -> Typ_arg_order ord + +let rec typ_subst_typ sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_typ_aux sv subst typ, l) +and typ_subst_typ_aux sv subst = function + | Typ_internal_unknown -> Typ_internal_unknown + | Typ_id v -> Typ_id v + | Typ_var kid -> if Kid.compare kid sv = 0 then subst else Typ_var kid + | Typ_fn (arg_typs, ret_typ, effs) -> Typ_fn (List.map (typ_subst_typ sv subst) arg_typs, typ_subst_typ sv subst ret_typ, effs) + | Typ_bidir (typ1, typ2) -> Typ_bidir (typ_subst_typ sv subst typ1, typ_subst_typ sv subst typ2) + | Typ_tup typs -> Typ_tup (List.map (typ_subst_typ sv subst) typs) + | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_typ sv subst) args) + | Typ_exist (kids, nc, typ) -> Typ_exist (kids, nc, typ_subst_typ sv subst typ) +and typ_subst_arg_typ sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_typ_aux sv subst arg, l) +and typ_subst_arg_typ_aux sv subst = function + | Typ_arg_nexp nexp -> Typ_arg_nexp nexp + | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_typ sv subst typ) + | Typ_arg_order ord -> Typ_arg_order ord + +let order_subst_aux sv subst = function + | Ord_var kid -> if Kid.compare kid sv = 0 then subst else Ord_var kid + | Ord_inc -> Ord_inc + | Ord_dec -> Ord_dec + +let order_subst sv subst (Ord_aux (ord, l)) = Ord_aux (order_subst_aux sv subst ord, l) + +let rec typ_subst_order sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_order_aux sv subst typ, l) +and typ_subst_order_aux sv subst = function + | Typ_internal_unknown -> Typ_internal_unknown + | Typ_id v -> Typ_id v + | Typ_var kid -> Typ_var kid + | Typ_fn (arg_typs, ret_typ, effs) -> Typ_fn (List.map (typ_subst_order sv subst) arg_typs, typ_subst_order sv subst ret_typ, effs) + | Typ_bidir (typ1, typ2) -> Typ_bidir (typ_subst_order sv subst typ1, typ_subst_order sv subst typ2) + | Typ_tup typs -> Typ_tup (List.map (typ_subst_order sv subst) typs) + | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_order sv subst) args) + | Typ_exist (kids, nc, typ) -> Typ_exist (kids, nc, typ_subst_order sv subst typ) +and typ_subst_arg_order sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_order_aux sv subst arg, l) +and typ_subst_arg_order_aux sv subst = function + | Typ_arg_nexp nexp -> Typ_arg_nexp nexp + | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_order sv subst typ) + | Typ_arg_order ord -> Typ_arg_order (order_subst sv subst ord) + +let rec typ_subst_kid sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_kid_aux sv subst typ, l) +and typ_subst_kid_aux sv subst = function + | Typ_internal_unknown -> Typ_internal_unknown + | Typ_id v -> Typ_id v + | Typ_var kid -> if Kid.compare kid sv = 0 then Typ_var subst else Typ_var kid + | Typ_fn (arg_typs, ret_typ, effs) -> Typ_fn (List.map (typ_subst_kid sv subst) arg_typs, typ_subst_kid sv subst ret_typ, effs) + | Typ_bidir (typ1, typ2) -> Typ_bidir (typ_subst_kid sv subst typ1, typ_subst_kid sv subst typ2) + | Typ_tup typs -> Typ_tup (List.map (typ_subst_kid sv subst) typs) + | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_kid sv subst) args) + | Typ_exist (kids, nc, typ) when KidSet.mem sv (KidSet.of_list kids) -> Typ_exist (kids, nc, typ) + | Typ_exist (kids, nc, typ) -> Typ_exist (kids, nc_subst_nexp sv (Nexp_var subst) nc, typ_subst_kid sv subst typ) +and typ_subst_arg_kid sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_kid_aux sv subst arg, l) +and typ_subst_arg_kid_aux sv subst = function + | Typ_arg_nexp nexp -> Typ_arg_nexp (nexp_subst sv (Nexp_var subst) nexp) + | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_kid sv subst typ) + | Typ_arg_order ord -> Typ_arg_order (order_subst sv (Ord_var subst) ord) + +let quant_item_subst_kid_aux sv subst = function + | QI_id (KOpt_aux (KOpt_none kid, l)) as qid -> + if Kid.compare kid sv = 0 then QI_id (KOpt_aux (KOpt_none subst, l)) else qid + | QI_id (KOpt_aux (KOpt_kind (k, kid), l)) as qid -> + if Kid.compare kid sv = 0 then QI_id (KOpt_aux (KOpt_kind (k, subst), l)) else qid + | QI_const nc -> QI_const (nc_subst_nexp sv (Nexp_var subst) nc) + +let quant_item_subst_kid sv subst (QI_aux (quant, l)) = QI_aux (quant_item_subst_kid_aux sv subst quant, l) + +let typquant_subst_kid_aux sv subst = function + | TypQ_tq quants -> TypQ_tq (List.map (quant_item_subst_kid sv subst) quants) + | TypQ_no_forall -> TypQ_no_forall + +let typquant_subst_kid sv subst (TypQ_aux (typq, l)) = TypQ_aux (typquant_subst_kid_aux sv subst typq, l) diff --git a/src/ast_util.mli b/src/ast_util.mli index ea287190..fae7b81c 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -320,6 +320,7 @@ val union_effects : effect -> effect -> effect val tyvars_of_nexp : nexp -> KidSet.t val tyvars_of_typ : typ -> KidSet.t +val tyvars_of_constraint : n_constraint -> KidSet.t val tyvars_of_quant_item : quant_item -> KidSet.t val is_kid_generated : kid -> bool @@ -353,7 +354,6 @@ val subst : id -> 'a exp -> 'a exp -> 'a exp val hex_to_bin : string -> string - (** locate takes an expression and recursively sets the location in every subexpression to the provided location. Expressions build using mk_exp and similar do not have locations, so they can then be @@ -366,3 +366,30 @@ val locate_pat : l -> 'a pat -> 'a pat val locate_lexp : l -> 'a lexp -> 'a lexp val locate_typ : l -> typ -> typ + +(** Substitutions *) + +(* The function X_subst_Y substitutes a Y into something of type X, if + X = Y then the function is just X_subst. Substitutions are always + unwrapped from their aux constructors. *) +val nexp_subst : kid -> nexp_aux -> nexp -> nexp +val nc_subst_nexp : kid -> nexp_aux -> n_constraint -> n_constraint +val order_subst : kid -> order_aux -> order -> order + +(* kid must be Int-kinded *) +val typ_subst_nexp : kid -> nexp_aux -> typ -> typ +val typ_subst_arg_nexp : kid -> nexp_aux -> typ_arg -> typ_arg + +(* kid must be Type-kinded *) +val typ_subst_typ : kid -> typ_aux -> typ -> typ +val typ_subst_arg_typ : kid -> typ_aux -> typ_arg -> typ_arg + +(* kid must be Order-kinded *) +val typ_subst_order : kid -> order_aux -> typ -> typ +val typ_subst_arg_order : kid -> order_aux -> typ_arg -> typ_arg + +val typ_subst_kid : kid -> kid -> typ -> typ +val typ_subst_arg_kid : kid -> kid -> typ_arg -> typ_arg + +val quant_item_subst_kid : kid -> kid -> quant_item -> quant_item +val typquant_subst_kid : kid -> kid -> typquant -> typquant diff --git a/src/c_backend.ml b/src/c_backend.ml index d825bbae..392f2349 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -1617,7 +1617,7 @@ let rec compile_def ctx = function | DEF_val (LB_aux (LB_val (pat, exp), _)) -> c_debug (lazy ("Compiling letbind " ^ string_of_pat pat)); - let ctyp = ctyp_of_typ ctx (pat_typ_of pat) in + let ctyp = ctyp_of_typ ctx (typ_of_pat pat) in let aexp = analyze_functions ctx analyze_primop (c_literals ctx (no_shadow IdSet.empty (anf exp))) in let setup, call, cleanup = compile_aexp ctx aexp in let apat = anf_pat ~global:true pat in diff --git a/src/interpreter.ml b/src/interpreter.ml index 2ea8bb00..540e96a1 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -592,13 +592,13 @@ and pattern_match env (P_aux (p_aux, (l, _)) as pat) value = recursive call that has an empty_tannot we must not use the annotation in the whole vector_concat pattern. *) let open Type_check in - begin match destruct_vector (pat_env_of pat) (pat_typ_of pat) with + begin match destruct_vector (env_of_pat pat) (typ_of_pat pat) with | Some (Nexp_aux (Nexp_constant n, _), _, _) -> let init, rest = Util.take (Big_int.to_int n) (coerce_gv value), Util.drop (Big_int.to_int n) (coerce_gv value) in let init_match, init_bind = pattern_match env pat (V_vector init) in let rest_match, rest_bind = pattern_match env (P_aux (P_vector_concat pats, (l, empty_tannot))) (V_vector rest) in init_match && rest_match, Bindings.merge combine init_bind rest_bind - | _ -> failwith ("Bad vector annotation " ^ string_of_typ (Type_check.pat_typ_of pat)) + | _ -> failwith ("Bad vector annotation " ^ string_of_typ (Type_check.typ_of_pat pat)) end | P_tup [pat] -> pattern_match env pat value | P_tup pats | P_list pats -> diff --git a/src/monomorphise.ml b/src/monomorphise.ml index f7a481e6..258b4e1f 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -1811,7 +1811,7 @@ let split_defs all_errors splits defs = (match spl p' with | None -> None | Some ps -> - let kids = equal_kids (pat_env_of p') kid in + let kids = equal_kids (env_of_pat p') kid in Some (List.map (fun (p,sub,pchoices,ksub) -> P_aux (P_var (p,tp),(l,annot)), sub, pchoices, List.concat @@ -2325,7 +2325,7 @@ let rewrite_size_parameters env (Defs defs) = let (_,nexp_map) = List.fold_left add_parameter (0,NexpMap.empty) types in let nexp_list = NexpMap.bindings nexp_map in (* let () = - print_endline ("Type of pattern for " ^ string_of_id id ^": " ^string_of_typ (pat_typ_of pat)); + print_endline ("Type of pattern for " ^ string_of_id id ^": " ^string_of_typ (typ_of_pat pat)); print_endline ("Types : " ^ String.concat ", " (List.map string_of_typ types)); print_endline ("Nexp map for " ^ string_of_id id); List.iter (fun (nexp, i) -> print_endline (" " ^ string_of_nexp nexp ^ " -> " ^ string_of_int i)) nexp_list @@ -2871,7 +2871,7 @@ let mk_subrange_pattern vannot vstart vend = let end_len = Big_int.pred (Big_int.sub len vend) in (* Wrap pat in its type; in particular the type checker won't manage P_wild in the middle of a P_vector_concat *) - let pat = P_aux (P_typ (pat_typ_of pat, pat),(Generated (pat_loc pat),empty_tannot)) in + let pat = P_aux (P_typ (typ_of_pat pat, pat),(Generated (pat_loc pat),empty_tannot)) in let pats = if Big_int.greater end_len Big_int.zero then [pat;P_aux (P_typ (vector_typ (nconstant end_len) ord typ, P_aux (P_wild,(dummyl,empty_tannot))),(dummyl,empty_tannot))] @@ -3373,7 +3373,7 @@ let initial_env fn_id fn_l (TypQ_aux (tq,_)) pat body set_assertions = else (* When there's no argument to case split on for a kid, we'll add a case expression instead *) - let env = pat_env_of pat in + let env = env_of_pat pat in let split = default_split (mk_tannot env int_typ no_effect) (KidSet.singleton kid) in let extra_splits = ExtraSplits.singleton (fn_id, fn_l) (KBindings.singleton kid split) in diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index 62a56c3d..77e3072b 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -187,7 +187,7 @@ let rec ocaml_pat ctx (P_aux (pat_aux, _) as pat) = match pat_aux with | P_id id -> begin - match Env.lookup_id id (pat_env_of pat) with + match Env.lookup_id id (env_of_pat pat) with | Local (_, _) | Unbound -> zencode ctx id | Enum _ -> zencode_upper ctx id | _ -> failwith ("Ocaml: Cannot pattern match on register: " ^ string_of_pat pat) diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index f1726ce4..2810d0ee 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -1817,7 +1817,7 @@ let demote_as_pattern i (P_aux (_,p_annot) as pat,typ) = that they've been merged. *) let rec atom_constraint ctxt (pat, typ) = - let typ = Env.base_typ_of (pat_env_of pat) typ in + let typ = Env.base_typ_of (env_of_pat pat) typ in match pat, typ with | P_aux (P_id id, _), Typ_aux (Typ_app (Id_aux (Id "atom",_), diff --git a/src/rewriter.ml b/src/rewriter.ml index a7505ca7..3eb0ffe6 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -103,7 +103,7 @@ let rec remove_p_typ = function | pat -> pat let add_p_typ typ (P_aux (paux, annot) as pat) = - let typ' = resolve_generated_kids (pat_env_of pat) typ in + let typ' = resolve_generated_kids (env_of_pat pat) typ in if KidSet.is_empty (generated_kids typ') then P_aux (P_typ (typ', remove_p_typ pat), annot) else pat diff --git a/src/rewrites.ml b/src/rewrites.ml index c470d906..313d30e5 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -592,7 +592,7 @@ let rewrite_sizeof (Defs defs) = let penv = env_of_annot pannot in let peff = effect_of_annot (snd pannot) in if KidSet.is_empty nvars then paux else - match pat_typ_of paux with + match typ_of_pat paux with | Typ_aux (Typ_tup typs, _) -> let ptyp' = Typ_aux (Typ_tup (kid_typs @ typs), l) in (match pat with @@ -1156,8 +1156,8 @@ let subst_id_exp exp (id1,id2) = let rec pat_to_exp ((P_aux (pat,(l,annot))) as p_aux) = let rewrap e = E_aux (e,(l,annot)) in - let env = pat_env_of p_aux in - let typ = pat_typ_of p_aux in + let env = env_of_pat p_aux in + let typ = typ_of_pat p_aux in match pat with | P_lit lit -> rewrap (E_lit lit) | P_wild -> raise (Reporting_basic.err_unreachable l __POS__ @@ -1322,7 +1322,7 @@ let contains_bitvector_pexp = function let remove_bitvector_pat (P_aux (_, (l, _)) as pat) = - let env = try pat_env_of pat with _ -> Env.empty in + let env = try env_of_pat pat with _ -> Env.empty in (* first introduce names for bitvector patterns *) let name_bitvector_roots = @@ -1360,7 +1360,7 @@ let remove_bitvector_pat (P_aux (_, (l, _)) as pat) = } in let pat, env = bind_pat_no_guard env (strip_pat ((fold_pat name_bitvector_roots pat) false)) - (pat_typ_of pat) in + (typ_of_pat pat) in (* Then collect guard expressions testing whether the literal bits of a bitvector pattern match those of a given bitvector, and collect let @@ -1607,7 +1607,7 @@ let rewrite_defs_remove_numeral_pats = fold_pat { (compute_pat_alg None compose_guard_opt) with p_lit = p_lit outer_env } in let pat_aux (pexp_aux, a) = let pat,guard,exp,a = destruct_pexp (Pat_aux (pexp_aux, a)) in - let guard',pat = guard_pat (pat_env_of pat) pat in + let guard',pat = guard_pat (env_of_pat pat) pat in match compose_guard_opt guard guard' with | Some g -> Pat_aux (Pat_when (pat, g, exp), a) | None -> Pat_aux (Pat_exp (pat, exp), a) in @@ -2131,7 +2131,7 @@ let rewrite_split_fun_constr_pats fun_name (Defs defs) = let pat, guard, exp, annot = destruct_pexp pexp in match pat with | P_aux (P_app (constr_id, args), pannot) -> - let argstup_typ = tuple_typ (List.map pat_typ_of args) in + let argstup_typ = tuple_typ (List.map typ_of_pat args) in let pannot' = swaptyp argstup_typ pannot in let pat' = match args with @@ -2172,7 +2172,7 @@ let rewrite_split_fun_constr_pats fun_name (Defs defs) = let env, args_typ, ret_typ = match funcls with | FCL_aux (FCL_Funcl (_, pexp), _) :: _ -> let pat, _, exp, _ = destruct_pexp pexp in - env_of exp, pat_typ_of pat, typ_of exp + env_of exp, typ_of_pat pat, typ_of exp | _ -> raise (Reporting_basic.err_unreachable l __POS__ "rewrite_split_fun_constr_pats: empty auxiliary function") @@ -3032,13 +3032,13 @@ let rewrite_pexp_with_guards rewrite_pat (Pat_aux (pexp_aux, (annot: tannot anno | [] -> pexp | gs -> let unchecked_pexp = mk_pexp (Pat_when (strip_pat pat, List.map strip_exp gs |> fold_guards, strip_exp exp)) in - check_case (pat_env_of pat) (pat_typ_of pat) unchecked_pexp (typ_of exp) + check_case (env_of_pat pat) (typ_of_pat pat) unchecked_pexp (typ_of exp) end | Pat_when (pat, guard, exp) -> begin let pat = fold_pat { id_pat_alg with p_aux = rewrite_pat guards } pat in let unchecked_pexp = mk_pexp (Pat_when (strip_pat pat, List.map strip_exp !guards |> fold_guards, strip_exp exp)) in - check_case (pat_env_of pat) (pat_typ_of pat) unchecked_pexp (typ_of exp) + check_case (env_of_pat pat) (typ_of_pat pat) unchecked_pexp (typ_of exp) end @@ -3077,7 +3077,7 @@ let rec bindings_of_pat (P_aux (p_aux, p_annot) as pat) = | P_record _ -> failwith "record patterns not yet implemented" (* we assume the type-checker has already checked the two sides have the same bindings *) | P_or (left, right) -> bindings_of_pat left - | P_as (p, id) -> [annot_pat (P_id id) unk (pat_env_of p) (pat_typ_of p)] + | P_as (p, id) -> [annot_pat (P_id id) unk (env_of_pat p) (typ_of_pat p)] | P_cons (left, right) -> bindings_of_pat left @ bindings_of_pat right (* todo: is this right for negated patterns? *) | P_not p @@ -3093,11 +3093,11 @@ let rec bindings_of_pat (P_aux (p_aux, p_annot) as pat) = let rec binding_typs_of_pat (P_aux (p_aux, p_annot) as pat) = match p_aux with | P_lit _ | P_wild -> [] - | P_id id -> [pat_typ_of pat] + | P_id id -> [typ_of_pat pat] | P_record _ -> failwith "record patterns not yet implemented" (* we assume the type-checker has already checked the two sides have the same bindings *) | P_or (left, right) -> binding_typs_of_pat left - | P_as (p, id) -> [pat_typ_of p] + | P_as (p, id) -> [typ_of_pat p] | P_cons (left, right) -> binding_typs_of_pat left @ binding_typs_of_pat right (* todo: is this right for negated patterns? *) | P_not p @@ -3226,7 +3226,7 @@ let construct_toplevel_string_append_func env f_id pat = let tup_arg_pat = match arg_pats with | [] -> assert false | [arg_pat] -> arg_pat - | arg_pats -> annot_pat (P_tup arg_pats) unk env (tuple_typ (List.map pat_typ_of arg_pats)) + | arg_pats -> annot_pat (P_tup arg_pats) unk env (tuple_typ (List.map typ_of_pat arg_pats)) in let some_pat = annot_pat (P_app (mk_id "Some", @@ -3402,7 +3402,7 @@ let rec rewrite_defs_pat_string_append = let tup_arg_pat = match arg_pats with | [] -> assert false | [arg_pat] -> arg_pat - | arg_pats -> annot_pat (P_tup arg_pats) unk env (tuple_typ (List.map pat_typ_of arg_pats)) + | arg_pats -> annot_pat (P_tup arg_pats) unk env (tuple_typ (List.map typ_of_pat arg_pats)) in let some_pat = annot_pat (P_app (mk_id "Some", @@ -3450,13 +3450,13 @@ let rec rewrite_defs_pat_string_append = | [] -> assert false | [arg_pat] -> annot_letbind (P_tup [arg_pat; annot_pat (P_id len_id) unk env nat_typ], new_binding) - unk env (tuple_typ [pat_typ_of arg_pat; nat_typ]) + unk env (tuple_typ [typ_of_pat arg_pat; nat_typ]) | arg_pats -> annot_letbind (P_tup - [annot_pat (P_tup arg_pats) unk env (tuple_typ (List.map pat_typ_of arg_pats)); + [annot_pat (P_tup arg_pats) unk env (tuple_typ (List.map typ_of_pat arg_pats)); annot_pat (P_id len_id) unk env nat_typ], new_binding) - unk env (tuple_typ [tuple_typ (List.map pat_typ_of arg_pats); nat_typ]) + unk env (tuple_typ [tuple_typ (List.map typ_of_pat arg_pats); nat_typ]) in let new_let = annot_exp (E_let (new_letbind, new_match)) unk env (typ_of expr) in @@ -3562,7 +3562,7 @@ let rewrite_defs_mapping_patterns = expr_ref := e; p in - let env = pat_env_of pat in + let env = env_of_pat pat in match pat with (* mapping(args) if g => expr ----> s# if mapping_matches(s#) @@ -3769,10 +3769,10 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = let tuple_pat = function | [] -> annot_pat P_wild l env unit_typ | [pat] -> - let typ = pat_typ_of pat in + let typ = typ_of_pat pat in add_p_typ typ pat | pats -> - let typ = tuple_typ (List.map pat_typ_of pats) in + let typ = tuple_typ (List.map typ_of_pat pats) in add_p_typ typ (annot_pat (P_tup pats) l env typ) in let rec add_vars overwrite ((E_aux (expaux,annot)) as exp) vars = @@ -5029,8 +5029,8 @@ let rewrite_check_annot = Type_error (l, err) -> raise (Reporting_basic.err_typ l (Type_error.string_of_type_error err)) in let check_pat pat = - prerr_endline ("CHECKING PAT: " ^ string_of_pat pat ^ " : " ^ string_of_typ (pat_typ_of pat)); - let _, _ = bind_pat_no_guard (pat_env_of pat) (strip_pat pat) (pat_typ_of pat) in + prerr_endline ("CHECKING PAT: " ^ string_of_pat pat ^ " : " ^ string_of_typ (typ_of_pat pat)); + let _, _ = bind_pat_no_guard (env_of_pat pat) (strip_pat pat) (typ_of_pat pat) in pat in diff --git a/src/type_check.ml b/src/type_check.ml index cf1d8ef9..3e6ec2a3 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -92,7 +92,7 @@ type type_error = coercions *) | Err_no_casts of unit exp * typ * typ * type_error * type_error list | Err_no_overloading of id * (id * type_error) list - | Err_unresolved_quants of id * quant_item list + | Err_unresolved_quants of id * quant_item list * (mut * typ) Bindings.t * n_constraint list | Err_subtype of typ * typ * n_constraint list * Ast.l KBindings.t | Err_no_num_ident of id | Err_other of string @@ -216,136 +216,10 @@ and strip_kind_aux = function and strip_base_kind = function | BK_aux (bk_aux, _) -> BK_aux (bk_aux, Parse_ast.Unknown) - -(**************************************************************************) -(* 1. Substitutions *) -(**************************************************************************) - -let rec nexp_subst sv subst (Nexp_aux (nexp, l)) = Nexp_aux (nexp_subst_aux sv subst nexp, l) -and nexp_subst_aux sv subst = function - | Nexp_id v -> Nexp_id v - | Nexp_var kid -> if Kid.compare kid sv = 0 then subst else Nexp_var kid - | Nexp_constant c -> Nexp_constant c - | Nexp_times (nexp1, nexp2) -> Nexp_times (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2) - | Nexp_sum (nexp1, nexp2) -> Nexp_sum (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2) - | Nexp_minus (nexp1, nexp2) -> Nexp_minus (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2) - | Nexp_app (id, nexps) -> Nexp_app (id, List.map (nexp_subst sv subst) nexps) - | Nexp_exp nexp -> Nexp_exp (nexp_subst sv subst nexp) - | Nexp_neg nexp -> Nexp_neg (nexp_subst sv subst nexp) - -let rec nexp_set_to_or l subst = function - | [] -> typ_error l "Cannot substitute into empty nexp set" - | [int] -> NC_equal (subst, nconstant int) - | (int :: ints) -> NC_or (mk_nc (NC_equal (subst, nconstant int)), mk_nc (nexp_set_to_or l subst ints)) - -let rec nc_subst_nexp sv subst (NC_aux (nc, l)) = NC_aux (nc_subst_nexp_aux l sv subst nc, l) -and nc_subst_nexp_aux l sv subst = function - | NC_equal (n1, n2) -> NC_equal (nexp_subst sv subst n1, nexp_subst sv subst n2) - | NC_bounded_ge (n1, n2) -> NC_bounded_ge (nexp_subst sv subst n1, nexp_subst sv subst n2) - | NC_bounded_le (n1, n2) -> NC_bounded_le (nexp_subst sv subst n1, nexp_subst sv subst n2) - | NC_not_equal (n1, n2) -> NC_not_equal (nexp_subst sv subst n1, nexp_subst sv subst n2) - | NC_set (kid, ints) as set_nc -> - if Kid.compare kid sv = 0 - then nexp_set_to_or l (mk_nexp subst) ints - else set_nc - | NC_or (nc1, nc2) -> NC_or (nc_subst_nexp sv subst nc1, nc_subst_nexp sv subst nc2) - | NC_and (nc1, nc2) -> NC_and (nc_subst_nexp sv subst nc1, nc_subst_nexp sv subst nc2) - | NC_app (id, nexps) -> NC_app (id, List.map (nexp_subst sv subst) nexps) - | NC_false -> NC_false - | NC_true -> NC_true - -let rec typ_subst_nexp sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_nexp_aux sv subst typ, l) -and typ_subst_nexp_aux sv subst = function - | Typ_internal_unknown -> Typ_internal_unknown - | Typ_id v -> Typ_id v - | Typ_var kid -> Typ_var kid - | Typ_fn (arg_typs, ret_typ, effs) -> Typ_fn (List.map (typ_subst_nexp sv subst) arg_typs, typ_subst_nexp sv subst ret_typ, effs) - | Typ_bidir (typ1, typ2) -> Typ_bidir (typ_subst_nexp sv subst typ1, typ_subst_nexp sv subst typ2) - | Typ_tup typs -> Typ_tup (List.map (typ_subst_nexp sv subst) typs) - | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_nexp sv subst) args) - | Typ_exist (kids, nc, typ) when KidSet.mem sv (KidSet.of_list kids) -> Typ_exist (kids, nc, typ) - | Typ_exist (kids, nc, typ) -> Typ_exist (kids, nc_subst_nexp sv subst nc, typ_subst_nexp sv subst typ) -and typ_subst_arg_nexp sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_nexp_aux sv subst arg, l) -and typ_subst_arg_nexp_aux sv subst = function - | Typ_arg_nexp nexp -> Typ_arg_nexp (nexp_subst sv subst nexp) - | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_nexp sv subst typ) - | Typ_arg_order ord -> Typ_arg_order ord - -let rec typ_subst_typ sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_typ_aux sv subst typ, l) -and typ_subst_typ_aux sv subst = function - | Typ_internal_unknown -> Typ_internal_unknown - | Typ_id v -> Typ_id v - | Typ_var kid -> if Kid.compare kid sv = 0 then subst else Typ_var kid - | Typ_fn (arg_typs, ret_typ, effs) -> Typ_fn (List.map (typ_subst_typ sv subst) arg_typs, typ_subst_typ sv subst ret_typ, effs) - | Typ_bidir (typ1, typ2) -> Typ_bidir (typ_subst_typ sv subst typ1, typ_subst_typ sv subst typ2) - | Typ_tup typs -> Typ_tup (List.map (typ_subst_typ sv subst) typs) - | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_typ sv subst) args) - | Typ_exist (kids, nc, typ) -> Typ_exist (kids, nc, typ_subst_typ sv subst typ) -and typ_subst_arg_typ sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_typ_aux sv subst arg, l) -and typ_subst_arg_typ_aux sv subst = function - | Typ_arg_nexp nexp -> Typ_arg_nexp nexp - | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_typ sv subst typ) - | Typ_arg_order ord -> Typ_arg_order ord - -let order_subst_aux sv subst = function - | Ord_var kid -> if Kid.compare kid sv = 0 then subst else Ord_var kid - | Ord_inc -> Ord_inc - | Ord_dec -> Ord_dec - -let order_subst sv subst (Ord_aux (ord, l)) = Ord_aux (order_subst_aux sv subst ord, l) - -let rec typ_subst_order sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_order_aux sv subst typ, l) -and typ_subst_order_aux sv subst = function - | Typ_internal_unknown -> Typ_internal_unknown - | Typ_id v -> Typ_id v - | Typ_var kid -> Typ_var kid - | Typ_fn (arg_typs, ret_typ, effs) -> Typ_fn (List.map (typ_subst_order sv subst) arg_typs, typ_subst_order sv subst ret_typ, effs) - | Typ_bidir (typ1, typ2) -> Typ_bidir (typ_subst_order sv subst typ1, typ_subst_order sv subst typ2) - | Typ_tup typs -> Typ_tup (List.map (typ_subst_order sv subst) typs) - | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_order sv subst) args) - | Typ_exist (kids, nc, typ) -> Typ_exist (kids, nc, typ_subst_order sv subst typ) -and typ_subst_arg_order sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_order_aux sv subst arg, l) -and typ_subst_arg_order_aux sv subst = function - | Typ_arg_nexp nexp -> Typ_arg_nexp nexp - | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_order sv subst typ) - | Typ_arg_order ord -> Typ_arg_order (order_subst sv subst ord) - -let rec typ_subst_kid sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_kid_aux sv subst typ, l) -and typ_subst_kid_aux sv subst = function - | Typ_internal_unknown -> Typ_internal_unknown - | Typ_id v -> Typ_id v - | Typ_var kid -> if Kid.compare kid sv = 0 then Typ_var subst else Typ_var kid - | Typ_fn (arg_typs, ret_typ, effs) -> Typ_fn (List.map (typ_subst_kid sv subst) arg_typs, typ_subst_kid sv subst ret_typ, effs) - | Typ_bidir (typ1, typ2) -> Typ_bidir (typ_subst_kid sv subst typ1, typ_subst_kid sv subst typ2) - | Typ_tup typs -> Typ_tup (List.map (typ_subst_kid sv subst) typs) - | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_kid sv subst) args) - | Typ_exist (kids, nc, typ) when KidSet.mem sv (KidSet.of_list kids) -> Typ_exist (kids, nc, typ) - | Typ_exist (kids, nc, typ) -> Typ_exist (kids, nc_subst_nexp sv (Nexp_var subst) nc, typ_subst_kid sv subst typ) -and typ_subst_arg_kid sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_kid_aux sv subst arg, l) -and typ_subst_arg_kid_aux sv subst = function - | Typ_arg_nexp nexp -> Typ_arg_nexp (nexp_subst sv (Nexp_var subst) nexp) - | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_kid sv subst typ) - | Typ_arg_order ord -> Typ_arg_order (order_subst sv (Ord_var subst) ord) - -let quant_item_subst_kid_aux sv subst = function - | QI_id (KOpt_aux (KOpt_none kid, l)) as qid -> - if Kid.compare kid sv = 0 then QI_id (KOpt_aux (KOpt_none subst, l)) else qid - | QI_id (KOpt_aux (KOpt_kind (k, kid), l)) as qid -> - if Kid.compare kid sv = 0 then QI_id (KOpt_aux (KOpt_kind (k, subst), l)) else qid - | QI_const nc -> QI_const (nc_subst_nexp sv (Nexp_var subst) nc) - -let quant_item_subst_kid sv subst (QI_aux (quant, l)) = QI_aux (quant_item_subst_kid_aux sv subst quant, l) - -let typquant_subst_kid_aux sv subst = function - | TypQ_tq quants -> TypQ_tq (List.map (quant_item_subst_kid sv subst) quants) - | TypQ_no_forall -> TypQ_no_forall - -let typquant_subst_kid sv subst (TypQ_aux (typq, l)) = TypQ_aux (typquant_subst_kid_aux sv subst typq, l) - let adding = Util.("Adding " |> darkgray |> clear) (**************************************************************************) -(* 2. Environment *) +(* 1. Environment *) (**************************************************************************) module Env : sig @@ -1366,7 +1240,7 @@ and is_typ_arg_monomorphic (Typ_arg_aux (arg, _)) = | Typ_arg_order (Ord_aux (Ord_var _, _)) -> false (**************************************************************************) -(* 3. Subtyping and constraint solving *) +(* 2. Subtyping and constraint solving *) (**************************************************************************) let rec simp_typ (Typ_aux (typ_aux, l)) = Typ_aux (simp_typ_aux typ_aux, l) @@ -1489,7 +1363,7 @@ let prove env (NC_aux (nc_aux, _) as nc) = | _ -> prove_z3 env nc (**************************************************************************) -(* 4. Unification *) +(* 3. Unification *) (**************************************************************************) let rec nexp_frees ?exs:(exs=KidSet.empty) (Nexp_aux (nexp, l)) = @@ -1759,7 +1633,7 @@ let merge_unifiers l kid uvar1 uvar2 = | None, None -> None let rec unify l env typ1 typ2 = - typ_print (lazy ("Unify " ^ string_of_typ typ1 ^ " with " ^ string_of_typ typ2)); + typ_print (lazy (Util.("Unify " |> magenta |> clear) ^ string_of_typ typ1 ^ " with " ^ string_of_typ typ2)); let goals = KidSet.inter (KidSet.diff (typ_frees typ1) (typ_frees typ2)) (typ_frees typ1) in let rec unify_typ l (Typ_aux (typ1_aux, _) as typ1) (Typ_aux (typ2_aux, _) as typ2) = @@ -1845,7 +1719,7 @@ let merge_uvars l unifiers1 unifiers2 = | Unification_error (_, m) -> typ_error l ("Could not merge unification variables: " ^ m) (**************************************************************************) -(* 4.5. Subtyping with existentials *) +(* 3.5. Subtyping with existentials *) (**************************************************************************) let destruct_atom_nexp env typ = @@ -2012,7 +1886,7 @@ let subtype_check env typ1 typ2 = | Type_error _ -> false (**************************************************************************) -(* 5. Type checking expressions *) +(* 4. Type checking expressions *) (**************************************************************************) (* The type checker produces a fully annoted AST - tannot is the type @@ -2168,9 +2042,9 @@ let typ_of (E_aux (_, (l, tannot))) = typ_of_annot (l, tannot) let env_of (E_aux (_, (l, tannot))) = env_of_annot (l, tannot) -let pat_typ_of (P_aux (_, (l, tannot))) = typ_of_annot (l, tannot) +let typ_of_pat (P_aux (_, (l, tannot))) = typ_of_annot (l, tannot) -let pat_env_of (P_aux (_, (l, tannot))) = env_of_annot (l, tannot) +let env_of_pat (P_aux (_, (l, tannot))) = env_of_annot (l, tannot) let typ_of_pexp (Pat_aux (_, (l, tannot))) = typ_of_annot (l, tannot) @@ -2701,7 +2575,7 @@ and bind_pat_no_guard env (P_aux (_,(l,_)) as pat) typ = and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) = let (Typ_aux (typ_aux, _) as typ), env = bind_existential l typ env in - typ_print (lazy ("Binding " ^ string_of_pat pat ^ " to " ^ string_of_typ typ)); + typ_print (lazy (Util.("Binding " |> yellow |> clear) ^ string_of_pat pat ^ " to " ^ string_of_typ typ)); let annot_pat pat typ' = P_aux (pat, (l, Some ((env, typ', no_effect), Some typ))) in let switch_typ pat typ = match pat with | P_aux (pat_aux, (l, Some ((env, _, eff), exp_typ))) -> P_aux (pat_aux, (l, Some ((env, typ, eff), exp_typ))) @@ -2887,15 +2761,15 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) typ_error l (string_of_id f ^ " is not a union constructor or mapping in pattern " ^ string_of_pat pat) | P_as (pat, id) -> let (typed_pat, env, guards) = bind_pat env pat typ in - annot_pat (P_as (typed_pat, id)) (pat_typ_of typed_pat), Env.add_local id (Immutable, pat_typ_of typed_pat) env, guards + annot_pat (P_as (typed_pat, id)) (typ_of_pat typed_pat), Env.add_local id (Immutable, typ_of_pat typed_pat) env, guards (* This is a special case for flow typing when we match a constant numeric literal. *) | P_lit (L_aux (L_num n, _) as lit) when is_atom typ -> let nexp = match destruct_atom_nexp env typ with Some n -> n | None -> assert false in annot_pat (P_lit lit) (atom_typ (nconstant n)), Env.add_constraint (nc_eq nexp (nconstant n)) env, [] | _ -> let (inferred_pat, env, guards) = infer_pat env pat in - match subtyp l env typ (pat_typ_of inferred_pat) with - | () -> switch_typ inferred_pat (pat_typ_of inferred_pat), env, guards + match subtyp l env typ (typ_of_pat inferred_pat) with + | () -> switch_typ inferred_pat (typ_of_pat inferred_pat), env, guards | exception (Type_error _ as typ_exn) -> match pat_aux with | P_lit lit -> @@ -2952,8 +2826,8 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as pat) = in let pats, env, guards = List.fold_left fold_pats ([], env, []) (pat :: pats) in let len = nexp_simp (nint (List.length pats)) in - let etyp = pat_typ_of (List.hd pats) in - List.iter (fun pat -> typ_equality l env etyp (pat_typ_of pat)) pats; + let etyp = typ_of_pat (List.hd pats) in + List.iter (fun pat -> typ_equality l env etyp (typ_of_pat pat)) pats; annot_pat (P_vector pats) (dvector_typ env len etyp), env, guards | P_vector_concat (pat :: pats) -> let fold_pats (pats, env, guards) pat = @@ -2962,9 +2836,9 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as pat) = in let inferred_pats, env, guards = List.fold_left fold_pats ([], env, []) (pat :: pats) in - let (len, _, vtyp) = destruct_vec_typ l env (pat_typ_of (List.hd inferred_pats)) in + let (len, _, vtyp) = destruct_vec_typ l env (typ_of_pat (List.hd inferred_pats)) in let fold_len len pat = - let (len', _, vtyp') = destruct_vec_typ l env (pat_typ_of pat) in + let (len', _, vtyp') = destruct_vec_typ l env (typ_of_pat pat) in typ_equality l env vtyp vtyp'; nsum len len' in @@ -2973,7 +2847,7 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as pat) = | P_string_append pats -> let fold_pats (pats, env, guards) pat = let inferred_pat, env, guards' = infer_pat env pat in - typ_equality l env (pat_typ_of inferred_pat) string_typ; + typ_equality l env (typ_of_pat inferred_pat) string_typ; pats @ [inferred_pat], env, guards' @ guards in let typed_pats, env, guards = @@ -2982,8 +2856,8 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as pat) = annot_pat (P_string_append typed_pats) string_typ, env, guards | P_as (pat, id) -> let (typed_pat, env, guards) = infer_pat env pat in - annot_pat (P_as (typed_pat, id)) (pat_typ_of typed_pat), - Env.add_local id (Immutable, pat_typ_of typed_pat) env, + annot_pat (P_as (typed_pat, id)) (typ_of_pat typed_pat), + Env.add_local id (Immutable, typ_of_pat typed_pat) env, guards | _ -> typ_error l ("Couldn't infer type of pattern " ^ string_of_pat pat) @@ -3462,8 +3336,14 @@ and infer_funapp' l env f (typq, f_typ) xs ret_ctx_typ = then let iuargs = List.map2 (fun utyp (n, uarg) -> (n, crule check_exp env uarg utyp)) utyps uargs in (iuargs, ret_typ, env) - else typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants - ^ " not resolved during application of " ^ string_of_id f ^ " unresolved args: " ^ string_of_list ", " (fun (_, exp) -> string_of_exp exp) uargs) + else typ_raise l (Err_unresolved_quants (f, quants, Env.get_locals env, Env.get_constraints env)) +(* + typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants + ^ " not resolved during application of " ^ string_of_id f + ^ " unresolved args: " ^ string_of_list ", " (fun (_, exp) -> string_of_exp exp) uargs + ^ "\nAll constraints: " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) + ^ "\nLocals: " ^ string_of_list ", " (fun (id, (mut, typ)) -> string_of_id id ^ " : " ^ string_of_typ typ) (Bindings.bindings (Env.get_locals env))) + *) end | (utyps, (typ :: typs)), (uargs, ((n, arg) :: args)) when List.for_all (fun kid -> is_bound kid env) (KidSet.elements (typ_frees typ)) -> @@ -3862,7 +3742,7 @@ and infer_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) typ_error l ("Couldn't infer type of mapping-pattern " ^ string_of_mpat mpat) (**************************************************************************) -(* 6. Effect system *) +(* 5. Effect system *) (**************************************************************************) let effect_of_annot = function @@ -4375,7 +4255,7 @@ let check_fundef env (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls) | Some id -> id | None -> typ_error l "funcl list is empty" in - typ_print (lazy ("\nChecking function " ^ string_of_id id)); + typ_print (lazy ("\n" ^ Util.("Check function " |> cyan |> clear) ^ string_of_id id)); let have_val_spec, (quant, typ), env = try true, Env.get_val_spec id env, env with | Type_error (l, _) -> diff --git a/src/type_check.mli b/src/type_check.mli index 8d2b02a9..ae46d956 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -76,7 +76,7 @@ val opt_constraint_synonyms : bool ref type type_error = | Err_no_casts of unit exp * typ * typ * type_error * type_error list | Err_no_overloading of id * (id * type_error) list - | Err_unresolved_quants of id * quant_item list + | Err_unresolved_quants of id * quant_item list * (mut * typ) Bindings.t * n_constraint list | Err_subtype of typ * typ * n_constraint list * Ast.l KBindings.t | Err_no_num_ident of id | Err_other of string @@ -95,7 +95,7 @@ module Env : sig type t (** Note: Most get_ functions assume the identifiers exist, and throw - type errors if it doesn't. *) + type errors if they don't. *) (** Get the quantifier and type for a function identifier, freshening type variables. *) @@ -321,9 +321,8 @@ val env_of_annot : Ast.l * tannot -> Env.t val typ_of : tannot exp -> typ val typ_of_annot : Ast.l * tannot -> typ - -val pat_typ_of : tannot pat -> typ -val pat_env_of : tannot pat -> Env.t +val typ_of_pat : tannot pat -> typ +val env_of_pat : tannot pat -> Env.t val typ_of_pexp : tannot pexp -> typ val env_of_pexp : tannot pexp -> Env.t @@ -367,11 +366,6 @@ val string_of_uvar : uvar -> string val subst_unifiers : uvar KBindings.t -> typ -> typ -val typ_subst_nexp : kid -> nexp_aux -> typ -> typ -val typ_subst_typ : kid -> typ_aux -> typ -> typ -val typ_subst_order : kid -> order_aux -> typ -> typ -val typ_subst_kid : kid -> kid -> typ -> typ - val unify : l -> Env.t -> typ -> typ -> uvar KBindings.t * kid list * n_constraint option val alpha_equivalent : Env.t -> typ -> typ -> bool diff --git a/src/type_error.ml b/src/type_error.ml index 78db65bc..5e2ce628 100644 --- a/src/type_error.ml +++ b/src/type_error.ml @@ -58,35 +58,6 @@ let bullet f xs = group (separate_map hardline (fun x -> string "* " ^^ nest 2 (f x)) xs) let pp_nexp, pp_n_constraint = - let rec string_of_nexp = function - | Nexp_aux (nexp, _) -> string_of_nexp_aux nexp - and string_of_nexp_aux = function - | Nexp_id id -> string_of_id id - | Nexp_var kid -> string_of_kid kid - | Nexp_constant c -> Big_int.to_string c - | Nexp_times (n1, n2) -> "(" ^ string_of_nexp n1 ^ " * " ^ string_of_nexp n2 ^ ")" - | Nexp_sum (n1, n2) -> "(" ^ string_of_nexp n1 ^ " + " ^ string_of_nexp n2 ^ ")" - | Nexp_minus (n1, n2) -> "(" ^ string_of_nexp n1 ^ " - " ^ string_of_nexp n2 ^ ")" - | Nexp_app (id, nexps) -> string_of_id id ^ "(" ^ string_of_list ", " string_of_nexp nexps ^ ")" - | Nexp_exp n -> "2 ^ " ^ string_of_nexp n - | Nexp_neg n -> "- " ^ string_of_nexp n - in - - let string_of_n_constraint = function - | NC_aux (NC_equal (n1, n2), _) -> string_of_nexp n1 ^ " = " ^ string_of_nexp n2 - | NC_aux (NC_not_equal (n1, n2), _) -> string_of_nexp n1 ^ " != " ^ string_of_nexp n2 - | NC_aux (NC_bounded_ge (n1, n2), _) -> string_of_nexp n1 ^ " >= " ^ string_of_nexp n2 - | NC_aux (NC_bounded_le (n1, n2), _) -> string_of_nexp n1 ^ " <= " ^ string_of_nexp n2 - | NC_aux (NC_or (nc1, nc2), _) -> - "(" ^ string_of_n_constraint nc1 ^ " | " ^ string_of_n_constraint nc2 ^ ")" - | NC_aux (NC_and (nc1, nc2), _) -> - "(" ^ string_of_n_constraint nc1 ^ " & " ^ string_of_n_constraint nc2 ^ ")" - | NC_aux (NC_set (kid, ns), _) -> - string_of_kid kid ^ " in {" ^ string_of_list ", " Big_int.to_string ns ^ "}" - | NC_aux (NC_true, _) -> "true" - | NC_aux (NC_false, _) -> "false" - in - let pp_nexp' nexp = string (string_of_nexp nexp) in @@ -94,9 +65,90 @@ let pp_nexp, pp_n_constraint = let pp_n_constraint' nc = string (string_of_n_constraint nc) in - pp_nexp', pp_n_constraint' +let rec nexp_subst sv subst (Nexp_aux (nexp, l)) = Nexp_aux (nexp_subst_aux sv subst nexp, l) +and nexp_subst_aux sv subst = function + | Nexp_id v -> Nexp_id v + | Nexp_var kid -> if Kid.compare kid sv = 0 then subst else Nexp_var kid + | Nexp_constant c -> Nexp_constant c + | Nexp_times (nexp1, nexp2) -> Nexp_times (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2) + | Nexp_sum (nexp1, nexp2) -> Nexp_sum (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2) + | Nexp_minus (nexp1, nexp2) -> Nexp_minus (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2) + | Nexp_app (id, nexps) -> Nexp_app (id, List.map (nexp_subst sv subst) nexps) + | Nexp_exp nexp -> Nexp_exp (nexp_subst sv subst nexp) + | Nexp_neg nexp -> Nexp_neg (nexp_subst sv subst nexp) + +let rec nexp_set_to_or l subst = function + | [] -> typ_error l "Cannot substitute into empty nexp set" + | [int] -> NC_equal (subst, nconstant int) + | (int :: ints) -> NC_or (mk_nc (NC_equal (subst, nconstant int)), mk_nc (nexp_set_to_or l subst ints)) + +let rec nc_subst_nexp sv subst (NC_aux (nc, l)) = NC_aux (nc_subst_nexp_aux l sv subst nc, l) +and nc_subst_nexp_aux l sv subst = function + | NC_equal (n1, n2) -> NC_equal (nexp_subst sv subst n1, nexp_subst sv subst n2) + | NC_bounded_ge (n1, n2) -> NC_bounded_ge (nexp_subst sv subst n1, nexp_subst sv subst n2) + | NC_bounded_le (n1, n2) -> NC_bounded_le (nexp_subst sv subst n1, nexp_subst sv subst n2) + | NC_not_equal (n1, n2) -> NC_not_equal (nexp_subst sv subst n1, nexp_subst sv subst n2) + | NC_set (kid, ints) as set_nc -> + if Kid.compare kid sv = 0 + then nexp_set_to_or l (mk_nexp subst) ints + else set_nc + | NC_or (nc1, nc2) -> NC_or (nc_subst_nexp sv subst nc1, nc_subst_nexp sv subst nc2) + | NC_and (nc1, nc2) -> NC_and (nc_subst_nexp sv subst nc1, nc_subst_nexp sv subst nc2) + | NC_app (id, nexps) -> NC_app (id, List.map (nexp_subst sv subst) nexps) + | NC_false -> NC_false + | NC_true -> NC_true + +let rec analyze_unresolved_quant locals ncs = function + | QI_aux (QI_const nc, _) -> + let gen_kids = List.filter is_kid_generated (KidSet.elements (tyvars_of_constraint nc)) in + if gen_kids = [] then + string ("Try adding the constraint: " ^ string_of_n_constraint nc) + else + (* If there are generated kind-identifiers in the constraint, + we don't want to make a suggestion based on them, so try to + look for generated kid free nexps in the set of constraints + that are equal to the generated identifier. This often + occurs due to how the type-checker introduces new type + variables. *) + let is_subst v = function + | NC_aux (NC_equal (Nexp_aux (Nexp_var v', _), nexp), _) + when Kid.compare v v' = 0 && not (KidSet.exists is_kid_generated (tyvars_of_nexp nexp)) -> + [(v, nexp)] + | NC_aux (NC_equal (nexp, Nexp_aux (Nexp_var v', _)), _) + when Kid.compare v v' = 0 && not (KidSet.exists is_kid_generated (tyvars_of_nexp nexp)) -> + [(v, nexp)] + | _ -> [] + in + let substs = List.concat (List.map (fun v -> List.concat (List.map (fun nc -> is_subst v nc) ncs)) gen_kids) in + let nc = List.fold_left (fun nc (v, nexp) -> nc_subst_nexp v (unaux_nexp nexp) nc) nc substs in + if not (KidSet.exists is_kid_generated (tyvars_of_constraint nc)) then + string ("Try adding the constraint " ^ string_of_n_constraint nc) + else + (* If we have a really anonymous type-variable, try to find a + regular variable that corresponds to it. *) + let is_linked v = function + | (id, (Immutable, (Typ_aux (Typ_app (ty_id, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var v', _)), _)]), _) as typ))) + when Id.compare ty_id (mk_id "atom") = 0 && Kid.compare v v' = 0 -> + [(v, nid id, typ)] + | (id, (mut, typ)) -> + prerr_endline (string_of_id id ^ " : " ^ string_of_typ typ); + [] + in + let substs = List.concat (List.map (fun v -> List.concat (List.map (fun nc -> is_linked v nc) (Bindings.bindings locals))) gen_kids) in + (string "Try adding named type variables for" + ^//^ string (Util.string_of_list ", " (fun (_, nexp, typ) -> string_of_nexp nexp ^ " : " ^ string_of_typ typ) substs)) + ^^ twice hardline ^^ + let nc = List.fold_left (fun nc (v, nexp, _) -> nc_subst_nexp v (unaux_nexp nexp) nc) nc substs in + if not (KidSet.exists is_kid_generated (tyvars_of_constraint nc)) then + string ("The property " ^ string_of_n_constraint nc ^ " must hold") + else + empty + + | QI_aux (QI_id kopt, _) -> + empty + let rec pp_type_error = function | Err_no_casts (exp, typ_from, typ_to, trigger, _) -> let coercion = @@ -123,9 +175,11 @@ let rec pp_type_error = function | Err_no_num_ident id -> string "No num identifier" ^^ space ^^ string (string_of_id id) - | Err_unresolved_quants (id, quants) -> - string "Could not resolve quantifiers for" ^^ space ^^ string (string_of_id id) - ^//^ group (separate_map hardline (fun quant -> string (string_of_quant_item quant)) quants) + | Err_unresolved_quants (id, quants, locals, ncs) -> + (string "Could not resolve quantifiers for" ^^ space ^^ string (string_of_id id) + ^//^ group (separate_map hardline (fun quant -> string (string_of_quant_item quant)) quants)) + ^^ twice hardline + ^^ group (separate_map hardline (analyze_unresolved_quant locals ncs) quants) | Err_other str -> string str -- cgit v1.2.3 From 001e28b487c8a4cb2a25519a3acc8ac8c1aaabf5 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 31 Oct 2018 15:43:56 +0000 Subject: Rename Reporting_basic to Reporting There is no Reporting_complex, so it's not clear what the basic is intended to signify anyway. Add a GitHub issue link to any err_unreachable errors (as they are all bugs) --- src/anf.ml | 4 +- src/ast_util.ml | 20 +-- src/c_backend.ml | 2 +- src/extra_pervasives.ml | 2 +- src/initial_check.ml | 26 ++-- src/interpreter.ml | 2 +- src/isail.ml | 6 +- src/latex.ml | 2 +- src/lexer.mll | 7 +- src/monomorphise.ml | 98 +++++++-------- src/ocaml_backend.ml | 22 ++-- src/parser.mly | 2 +- src/pattern_completeness.ml | 6 +- src/pretty_print_common.ml | 1 + src/pretty_print_coq.ml | 84 ++++++------- src/pretty_print_lem.ml | 64 +++++----- src/pretty_print_sail.ml | 2 +- src/process_file.ml | 42 ++++--- src/reporting.ml | 296 ++++++++++++++++++++++++++++++++++++++++++++ src/reporting.mli | 115 +++++++++++++++++ src/reporting_basic.ml | 293 ------------------------------------------- src/reporting_basic.mli | 115 ----------------- src/rewriter.ml | 6 +- src/rewrites.ml | 84 ++++++------- src/sail.ml | 4 +- src/spec_analysis.ml | 2 +- src/state.ml | 4 +- src/type_check.ml | 24 ++-- src/type_check.mli | 2 +- src/type_error.ml | 4 +- 30 files changed, 674 insertions(+), 667 deletions(-) create mode 100644 src/reporting.ml create mode 100644 src/reporting.mli delete mode 100644 src/reporting_basic.ml delete mode 100644 src/reporting_basic.mli (limited to 'src') diff --git a/src/anf.ml b/src/anf.ml index 2e7b6b65..4b22b9ad 100644 --- a/src/anf.ml +++ b/src/anf.ml @@ -58,7 +58,7 @@ open PPrint module Big_int = Nat_big_num let anf_error ?loc:(l=Parse_ast.Unknown) message = - raise (Reporting_basic.err_general l ("\nANF translation: " ^ message)) + raise (Reporting.err_general l ("\nANF translation: " ^ message)) (**************************************************************************) (* 1. Conversion to A-normal form (ANF) *) @@ -510,7 +510,7 @@ let rec anf (E_aux (e_aux, ((l, _) as exp_annot)) as exp) = | E_lit lit -> mk_aexp (ae_lit lit (typ_of exp)) | E_block [] -> - Util.warn (Reporting_basic.loc_to_string l + Util.warn (Reporting.loc_to_string l ^ "\n\nTranslating empty block (possibly assigning to an uninitialized variable at the end of a block?)"); mk_aexp (ae_lit (L_aux (L_unit, l)) (typ_of exp)) | E_block exps -> diff --git a/src/ast_util.ml b/src/ast_util.ml index 9490366f..a0b75fc2 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -344,7 +344,7 @@ let rec nc_negate (NC_aux (nc, l)) = | NC_set (kid, int :: ints) -> mk_nc (NC_and (nc_neq (nvar kid) (nconstant int), nc_negate (mk_nc (NC_set (kid, ints))))) | NC_app _ -> - raise (Reporting_basic.err_unreachable l __POS__ "tried to negate constraint with unexpanded synonym") + raise (Reporting.err_unreachable l __POS__ "tried to negate constraint with unexpanded synonym") let mk_typschm typq typ = TypSchm_aux (TypSchm_ts (typq, typ), Parse_ast.Unknown) @@ -828,13 +828,13 @@ let id_of_fundef (FD_aux (FD_function (_, _, _, funcls), (l, _))) = (fun (FCL_aux (FCL_Funcl (id, _), _)) id' -> match id' with | Some id' -> if string_of_id id' = string_of_id id then Some id' - else raise (Reporting_basic.err_typ l + else raise (Reporting.err_typ l ("Function declaration expects all definitions to have the same name, " ^ string_of_id id ^ " differs from other definitions of " ^ string_of_id id')) | None -> Some id) funcls None) with | Some id -> id - | None -> raise (Reporting_basic.err_typ l "funcl list is empty") + | None -> raise (Reporting.err_typ l "funcl list is empty") let id_of_type_def_aux = function | TD_abbrev (id, _, _) @@ -959,7 +959,7 @@ module TypMap = Map.Make(Typ) let rec nexp_frees (Nexp_aux (nexp, l)) = match nexp with - | Nexp_id _ -> raise (Reporting_basic.err_typ l "Unimplemented Nexp_id in nexp_frees") + | Nexp_id _ -> raise (Reporting.err_typ l "Unimplemented Nexp_id in nexp_frees") | Nexp_var kid -> KidSet.singleton kid | Nexp_constant _ -> KidSet.empty | Nexp_times (n1, n2) -> KidSet.union (nexp_frees n1) (nexp_frees n2) @@ -977,7 +977,7 @@ let rec lexp_to_exp (LEXP_aux (lexp_aux, annot) as le) = let get_id (LEXP_aux(lexp,((l,_) as annot)) as le) = match lexp with | LEXP_id id | LEXP_cast (_, id) -> E_aux (E_id id, annot) | _ -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ ("Unsupported sub-lexp " ^ string_of_lexp le ^ " in tuple")) in rewrap (E_tuple (List.map get_id les)) | LEXP_vector (lexp, e) -> rewrap (E_vector_access (lexp_to_exp lexp, e)) @@ -1016,7 +1016,7 @@ let typ_app_args_of = function | Typ_aux (Typ_app (Id_aux (Id c,_), targs), l) -> (c, List.map (fun (Typ_arg_aux (a,_)) -> a) targs, l) | Typ_aux (_, l) as typ -> - raise (Reporting_basic.err_typ l + raise (Reporting.err_typ l ("typ_app_args_of called on non-app type " ^ string_of_typ typ)) let rec vector_typ_args_of typ = match typ_app_args_of typ with @@ -1024,7 +1024,7 @@ let rec vector_typ_args_of typ = match typ_app_args_of typ with (nexp_simp len, ord, etyp) | ("register", [Typ_arg_typ rtyp], _) -> vector_typ_args_of rtyp | (_, _, l) -> - raise (Reporting_basic.err_typ l + raise (Reporting.err_typ l ("vector_typ_args_of called on non-vector type " ^ string_of_typ typ)) let vector_start_index typ = @@ -1032,13 +1032,13 @@ let vector_start_index typ = match ord with | Ord_aux (Ord_inc, _) -> nint 0 | Ord_aux (Ord_dec, _) -> nexp_simp (nminus len (nint 1)) - | _ -> raise (Reporting_basic.err_typ (typ_loc typ) "Can't calculate start index without order") + | _ -> raise (Reporting.err_typ (typ_loc typ) "Can't calculate start index without order") let is_order_inc = function | Ord_aux (Ord_inc, _) -> true | Ord_aux (Ord_dec, _) -> false | Ord_aux (Ord_var _, l) -> - raise (Reporting_basic.err_unreachable l __POS__ "is_order_inc called on vector with variable ordering") + raise (Reporting.err_unreachable l __POS__ "is_order_inc called on vector with variable ordering") let is_bit_typ = function | Typ_aux (Typ_id (Id_aux (Id "bit", _)), _) -> true @@ -1506,7 +1506,7 @@ and nexp_subst_aux sv subst = function | Nexp_neg nexp -> Nexp_neg (nexp_subst sv subst nexp) let rec nexp_set_to_or l subst = function - | [] -> raise (Reporting_basic.err_unreachable l __POS__ "Empty set in constraint") + | [] -> raise (Reporting.err_unreachable l __POS__ "Empty set in constraint") | [int] -> NC_equal (subst, nconstant int) | (int :: ints) -> NC_or (mk_nc (NC_equal (subst, nconstant int)), mk_nc (nexp_set_to_or l subst ints)) diff --git a/src/c_backend.ml b/src/c_backend.ml index 392f2349..6dca1f8a 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -75,7 +75,7 @@ let c_debug str = if !c_verbosity > 0 then prerr_endline (Lazy.force str) else () let c_error ?loc:(l=Parse_ast.Unknown) message = - raise (Reporting_basic.err_general l ("\nC backend: " ^ message)) + raise (Reporting.err_general l ("\nC backend: " ^ message)) let zencode_id = function | Id_aux (Id str, l) -> Id_aux (Id (Util.zencode_string str), l) diff --git a/src/extra_pervasives.ml b/src/extra_pervasives.ml index a7808a95..8001c647 100644 --- a/src/extra_pervasives.ml +++ b/src/extra_pervasives.ml @@ -49,4 +49,4 @@ (**************************************************************************) let unreachable l pos msg = - raise (Reporting_basic.err_unreachable l pos msg) + raise (Reporting.err_unreachable l pos msg) diff --git a/src/initial_check.ml b/src/initial_check.ml index 36513ba1..f98b11d8 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -112,13 +112,13 @@ let typquant_to_quantkinds k_env typquant = | KOpt_aux(KOpt_none(v),l) | KOpt_aux(KOpt_kind(_,v),l) -> (match Envmap.apply k_env (var_to_string v) with | Some(typ) -> typ::rst - | None -> raise (Reporting_basic.err_unreachable l __POS__ "Envmap didn't get an entry during typschm processing")) + | None -> raise (Reporting.err_unreachable l __POS__ "Envmap didn't get an entry during typschm processing")) end) qlist []) let typ_error l msg opt_id opt_var opt_kind = - raise (Reporting_basic.err_typ + raise (Reporting.err_typ l (msg ^ (match opt_id, opt_var, opt_kind with @@ -157,7 +157,7 @@ let to_ast_base_kind (Parse_ast.BK_aux(k,l')) = let to_ast_kind (k_env : kind Envmap.t) (Parse_ast.K_aux(Parse_ast.K_kind(klst),l)) : (Ast.kind * kind) = match klst with - | [] -> raise (Reporting_basic.err_unreachable l __POS__ "Kind with empty kindlist encountered") + | [] -> raise (Reporting.err_unreachable l __POS__ "Kind with empty kindlist encountered") | [k] -> let k_ast,k_typ = to_ast_base_kind k in K_aux(K_kind([k_ast]),l), k_typ | ks -> let k_pairs = List.map to_ast_base_kind ks in @@ -211,7 +211,7 @@ let rec to_ast_typ (k_env : kind Envmap.t) (def_ord : order) (t: Parse_ast.atyp) let rise = match def_ord with | Ord_aux(Ord_inc,dl) -> to_ast_nexp k_env (make_r b r) | Ord_aux(Ord_dec,dl) -> to_ast_nexp k_env (make_r r b) - | _ -> raise (Reporting_basic.err_unreachable l __POS__ "Default order not inc or dec") in + | _ -> raise (Reporting.err_unreachable l __POS__ "Default order not inc or dec") in Typ_app(Id_aux(Id "vector",il), [Typ_arg_aux (Typ_arg_nexp base,Parse_ast.Unknown); Typ_arg_aux (Typ_arg_nexp rise,Parse_ast.Unknown); @@ -227,7 +227,7 @@ let rec to_ast_typ (k_env : kind Envmap.t) (def_ord : order) (t: Parse_ast.atyp) let (base,rise) = match def_ord with | Ord_aux(Ord_inc,dl) -> (to_ast_nexp k_env b), (to_ast_nexp k_env r) | Ord_aux(Ord_dec,dl) -> (to_ast_nexp k_env (make_sub_one r)), (to_ast_nexp k_env r) - | _ -> raise (Reporting_basic.err_unreachable l __POS__ "Default order not inc or dec") in + | _ -> raise (Reporting.err_unreachable l __POS__ "Default order not inc or dec") in Typ_app(Id_aux(Id "vector",il), [Typ_arg_aux (Typ_arg_nexp base,Parse_ast.Unknown); Typ_arg_aux (Typ_arg_nexp rise,Parse_ast.Unknown); @@ -341,7 +341,7 @@ and to_ast_typ_arg (k_env : kind Envmap.t) (def_ord : order) (kind : kind) (arg | K_Typ -> Typ_arg_typ (to_ast_typ k_env def_ord arg) | K_Nat -> Typ_arg_nexp (to_ast_nexp k_env arg) | K_Ord -> Typ_arg_order (to_ast_order k_env def_ord arg) - | _ -> raise (Reporting_basic.err_unreachable l __POS__ ("To_ast_typ_arg received Lam kind or infer kind: " ^ kind_to_string kind))), + | _ -> raise (Reporting.err_unreachable l __POS__ ("To_ast_typ_arg received Lam kind or infer kind: " ^ kind_to_string kind))), l) and to_ast_nexp_constraint (k_env : kind Envmap.t) (c : Parse_ast.n_constraint) : n_constraint = @@ -400,7 +400,7 @@ let to_ast_typquant (k_env: kind Envmap.t) (tq : Parse_ast.typquant) : typquant let kopt,k_env,k_env_local = (match kind,ktyp with | Some(k),Some(kt) -> KOpt_kind(k,v), (Envmap.insert k_env (key,kt)), (Envmap.insert local_env (key,kt)) | None, Some(kt) -> KOpt_none(v), (Envmap.insert k_env (key,kt)), (Envmap.insert local_env (key,kt)) - | _ -> raise (Reporting_basic.err_unreachable l __POS__ "Envmap in dom is true but apply gives None")) in + | _ -> raise (Reporting.err_unreachable l __POS__ "Envmap in dom is true but apply gives None")) in KOpt_aux(kopt,l),k_env,local_names,k_env_local in match tq with @@ -538,11 +538,11 @@ and to_ast_exp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) | Parse_ast.E_record fexps -> (match to_ast_fexps true k_env def_ord fexps with | Some fexps -> E_record fexps - | None -> raise (Reporting_basic.err_unreachable l __POS__ "to_ast_fexps with true returned none")) + | None -> raise (Reporting.err_unreachable l __POS__ "to_ast_fexps with true returned none")) | Parse_ast.E_record_update(exp,fexps) -> (match to_ast_fexps true k_env def_ord fexps with | Some(fexps) -> E_record_update(to_ast_exp k_env def_ord exp, fexps) - | _ -> raise (Reporting_basic.err_unreachable l __POS__ "to_ast_fexps with true returned none")) + | _ -> raise (Reporting.err_unreachable l __POS__ "to_ast_fexps with true returned none")) | Parse_ast.E_field(exp,id) -> E_field(to_ast_exp k_env def_ord exp, to_ast_id id) | Parse_ast.E_case(exp,pexps) -> E_case(to_ast_exp k_env def_ord exp, List.map (to_ast_case k_env def_ord) pexps) | Parse_ast.E_try (exp, pexps) -> E_try (to_ast_exp k_env def_ord exp, List.map (to_ast_case k_env def_ord) pexps) @@ -555,7 +555,7 @@ and to_ast_exp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) | Parse_ast.E_throw exp -> E_throw (to_ast_exp k_env def_ord exp) | Parse_ast.E_return exp -> E_return(to_ast_exp k_env def_ord exp) | Parse_ast.E_assert(cond,msg) -> E_assert(to_ast_exp k_env def_ord cond, to_ast_exp k_env def_ord msg) - | _ -> raise (Reporting_basic.err_unreachable l __POS__ "Unparsable construct in to_ast_exp") + | _ -> raise (Reporting.err_unreachable l __POS__ "Unparsable construct in to_ast_exp") ), (l,())) and to_ast_lexp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) : Parse_ast.exp) : unit lexp = @@ -858,7 +858,7 @@ let to_ast_alias_spec k_env def_ord (Parse_ast.E_aux(e,le)) = Parse_ast.E_aux(Parse_ast.E_id second,ls)) -> AL_concat(RI_aux(RI_id (to_ast_id first),(lf,())), RI_aux(RI_id (to_ast_id second),(ls,()))) - | _ -> raise (Reporting_basic.err_unreachable le __POS__ "Found an expression not supported by parser in to_ast_alias_spec") + | _ -> raise (Reporting.err_unreachable le __POS__ "Found an expression not supported by parser in to_ast_alias_spec") ), (le,())) let to_ast_dec (names,k_env,def_ord) (Parse_ast.DEC_aux(regdec,l)) = @@ -1008,7 +1008,7 @@ let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out ((Finished def), envs),partial_defs | _, true -> typ_error l "Scattered definition ended multiple times" (Some id) None None - | _ -> raise (Reporting_basic.err_unreachable l __POS__ "Something in partial_defs other than fundef and type")))) + | _ -> raise (Reporting.err_unreachable l __POS__ "Something in partial_defs other than fundef and type")))) let rec to_ast_defs_helper envs partial_defs = function | [] -> ([],envs,partial_defs) @@ -1021,7 +1021,7 @@ let rec to_ast_defs_helper envs partial_defs = function (match (def_in_progress id partial_defs) with | None -> raise - (Reporting_basic.err_unreachable l __POS__ "Id stored in place holder not retrievable from partial defs") + (Reporting.err_unreachable l __POS__ "Id stored in place holder not retrievable from partial defs") | Some(d,k) -> if (snd !d) then (fst !d) :: defs, envs, partial_defs diff --git a/src/interpreter.ml b/src/interpreter.ml index 540e96a1..07a4b4ae 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -672,7 +672,7 @@ let rec eval_frame' = function let eval_frame frame = try eval_frame' frame with | Type_check.Type_error (l, err) -> - raise (Reporting_basic.err_typ l (Type_error.string_of_type_error err)) + raise (Reporting.err_typ l (Type_error.string_of_type_error err)) let rec run_frame frame = match frame with diff --git a/src/isail.ml b/src/isail.ml index c3f869a3..7ec0848d 100644 --- a/src/isail.ml +++ b/src/isail.ml @@ -80,7 +80,7 @@ let rec user_input callback = mode_clear (); begin try callback v with - | Reporting_basic.Fatal_error e -> Reporting_basic.report_error e + | Reporting.Fatal_error e -> Reporting.report_error e end; user_input callback @@ -390,8 +390,8 @@ let handle_input input = try handle_input' input with | Type_check.Type_error (l, err) -> print_endline (Type_error.string_of_type_error err) - | Reporting_basic.Fatal_error err -> - Reporting_basic.print_error err + | Reporting.Fatal_error err -> + Reporting.print_error err | exn -> print_endline (Printexc.to_string exn) diff --git a/src/latex.ml b/src/latex.ml index 39db43db..4944c5e9 100644 --- a/src/latex.ml +++ b/src/latex.ml @@ -105,7 +105,7 @@ let latex_loc no_loc l = begin let using_color = !Util.opt_colors in Util.opt_colors := false; - let code = Util.split_on_char '\n' (Reporting_basic.loc_to_string l) in + let code = Util.split_on_char '\n' (Reporting.loc_to_string l) in let doc = match code with | _ :: _ :: code -> string (add_links (String.concat "\n" code)) | _ -> empty diff --git a/src/lexer.mll b/src/lexer.mll index cbefa601..8b229772 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -163,7 +163,6 @@ let kw_table = ("do", (fun _ -> Do)); ("mutual", (fun _ -> Mutual)); ("bitfield", (fun _ -> Bitfield)); - ("tuple", (fun _ -> Tuple)); ("where", (fun _ -> Where)); ("barr", (fun x -> Barr)); @@ -329,12 +328,12 @@ and string pos b = parse | ([^'"''\n''\\']* as i) { Buffer.add_string b i; string pos b lexbuf } | escape_sequence as i { Buffer.add_string b i; string pos b lexbuf } | '\\' '\n' ws { Lexing.new_line lexbuf; string pos b lexbuf } - | '\\' { assert false (*raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, + | '\\' { assert false (*raise (Reporting.Fatal_error (Reporting.Err_syntax (pos, "illegal backslash escape in string"*) } | '"' { let s = unescaped(Buffer.contents b) in (*try Ulib.UTF8.validate s; s with Ulib.UTF8.Malformed_code -> - raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, + raise (Reporting.Fatal_error (Reporting.Err_syntax (pos, "String literal is not valid utf8"))) *) s } - | eof { assert false (*raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, + | eof { assert false (*raise (Reporting.Fatal_error (Reporting.Err_syntax (pos, "String literal not terminated")))*) } diff --git a/src/monomorphise.ml b/src/monomorphise.ml index 258b4e1f..c43b4a56 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -115,7 +115,7 @@ let rec subst_nc substs (NC_aux (nc,l) as n_constraint) = | Nexp_aux (Nexp_constant i,_) -> if List.exists (fun j -> Big_int.equal i j) is then re NC_true else re NC_false | nexp -> - raise (Reporting_basic.err_general l + raise (Reporting.err_general l ("Unable to substitute " ^ string_of_nexp nexp ^ " into set constraint " ^ string_of_n_constraint n_constraint)) | exception Not_found -> n_constraint @@ -180,7 +180,7 @@ let rec is_value (E_aux (e,(l,annot))) = let is_constructor id = match destruct_tannot annot with | None -> - (Reporting_basic.print_err false true l "Monomorphisation" + (Reporting.print_err false true l "Monomorphisation" ("Missing type information for identifier " ^ string_of_id id); false) (* Be conservative if we have no info *) | Some (env,_,_) -> @@ -281,7 +281,7 @@ let extract_set_nc l var nc = | None, Some (is,nc2') -> Some (is, re (NC_and (nc1,nc2'))) | Some (is,nc1'), None -> Some (is, re (NC_and (nc1',nc2))) | Some _, Some _ -> - raise (Reporting_basic.err_general l ("Multiple set constraints for " ^ string_of_kid var))) + raise (Reporting.err_general l ("Multiple set constraints for " ^ string_of_kid var))) | NC_or _ -> (match aux_or nc_full with | Some is -> Some (is, re NC_true) @@ -290,7 +290,7 @@ let extract_set_nc l var nc = in match aux nc with | Some is -> is | None -> - raise (Reporting_basic.err_general l ("No set constraint for " ^ string_of_kid var ^ + raise (Reporting.err_general l ("No set constraint for " ^ string_of_kid var ^ " in " ^ string_of_n_constraint nc)) let rec peel = function @@ -315,9 +315,9 @@ let rec inst_src_type insts (Typ_aux (ty,l) as typ) = | Typ_var _ -> insts,typ | Typ_fn _ -> - raise (Reporting_basic.err_general l "Function type in constructor") + raise (Reporting.err_general l "Function type in constructor") | Typ_bidir _ -> - raise (Reporting_basic.err_general l "Mapping type in constructor") + raise (Reporting.err_general l "Mapping type in constructor") | Typ_tup ts -> let insts,ts = List.fold_right @@ -393,9 +393,9 @@ let split_src_type id ty (TypQ_aux (q,ql)) = | Typ_var _ -> (KidSet.empty,[[],typ]) | Typ_fn _ -> - raise (Reporting_basic.err_general l ("Function type in constructor " ^ i)) + raise (Reporting.err_general l ("Function type in constructor " ^ i)) | Typ_bidir _ -> - raise (Reporting_basic.err_general l ("Mapping type in constructor " ^ i)) + raise (Reporting.err_general l ("Mapping type in constructor " ^ i)) | Typ_tup ts -> let (vars,tys) = List.split (List.map size_nvars_ty ts) in let insttys = List.map (fun x -> let (insts,tys) = List.split x in @@ -450,10 +450,10 @@ let split_src_type id ty (TypQ_aux (q,ql)) = | Typ_aux (Typ_tup _,_) -> Typ_aux (Typ_tup [ty],Unknown) | _ -> ty) tys in if contains_exist t then - raise (Reporting_basic.err_general l + raise (Reporting.err_general l "Only prenex types in unions are supported by monomorphisation") else if List.length kids > 1 then - raise (Reporting_basic.err_general l + raise (Reporting.err_general l "Only single-variable existential types in unions are currently supported by monomorphisation") else tys end @@ -465,7 +465,7 @@ let split_src_type id ty (TypQ_aux (q,ql)) = | [] -> None | sample::__ -> let () = if List.length variants > size_set_limit then - raise (Reporting_basic.err_general ql + raise (Reporting.err_general ql (string_of_int (List.length variants) ^ "variants for constructor " ^ i ^ "bigger than limit " ^ string_of_int size_set_limit)) else () in @@ -490,7 +490,7 @@ let reduce_nexp subst ne = | Nexp_exp n -> Big_int.shift_left (eval n) 1 | Nexp_neg n -> Big_int.negate (eval n) | _ -> - raise (Reporting_basic.err_general Unknown ("Couldn't turn nexp " ^ + raise (Reporting.err_general Unknown ("Couldn't turn nexp " ^ string_of_nexp nexp ^ " into concrete value")) in eval ne @@ -539,7 +539,7 @@ let refine_constructor refinements l env id args = match List.find matches_refinement irefinements with | (_,new_id,_) -> Some (E_app (new_id,args)) | exception Not_found -> - (Reporting_basic.print_err false true l "Monomorphisation" + (Reporting.print_err false true l "Monomorphisation" ("Unable to refine constructor " ^ string_of_id id); None) end @@ -723,7 +723,7 @@ let fabricate_nexp_exist env l typ kids nc typ' = when Kid.compare kid kid'' = 0 && Kid.compare kid kid''' = 0 -> nint 32 - | _ -> raise (Reporting_basic.err_general l + | _ -> raise (Reporting.err_general l ("Undefined value at unsupported type " ^ string_of_typ typ)) let fabricate_nexp l tannot = @@ -753,7 +753,7 @@ let reduce_cast typ exp l annot = let nc_env = Env.add_constraint (nc_eq (nvar kid) (nconstant n)) nc_env in if prove nc_env nc then exp - else raise (Reporting_basic.err_unreachable l __POS__ + else raise (Reporting.err_unreachable l __POS__ ("Constant propagation error: literal " ^ Big_int.to_string n ^ " does not satisfy constraint " ^ string_of_n_constraint nc)) | E_aux (E_lit (L_aux (L_undef,_)),_), Some ([kid],nc,typ'') when atom_typ_kid kid typ'' -> @@ -1154,10 +1154,10 @@ let apply_pat_choices choices = List.fold_left (fun e (id,e') -> E_let (LB_aux (LB_val (P_aux (P_id id, dummyannot),e'),dummyannot),E_aux (e,dummyannot))) e subst | Pat_aux (Pat_when _,(l,_)) -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "Pattern acquired a guard after analysis!") | exception Not_found -> - raise (Reporting_basic.err_unreachable (exp_loc e) __POS__ + raise (Reporting.err_unreachable (exp_loc e) __POS__ "Unable to find case I found earlier!")) | exception Not_found -> E_case (e,cases) in @@ -1458,7 +1458,7 @@ let split_defs all_errors splits defs = | E_internal_plet _ | E_internal_return _ | E_internal_value _ - -> raise (Reporting_basic.err_unreachable l __POS__ + -> raise (Reporting.err_unreachable l __POS__ ("Unexpected expression encountered in monomorphisation: " ^ string_of_exp exp)) and const_prop_fexps ref_vars substs assigns (FES_aux (FES_Fexps (fes,flag), annot)) = FES_aux (FES_Fexps (List.map (const_prop_fexp ref_vars substs assigns) fes, flag), annot) @@ -1528,7 +1528,7 @@ let split_defs all_errors splits defs = and can_match_with_env ref_vars env (E_aux (e,(l,annot)) as exp0) cases (substs,ksubsts) assigns = let rec findpat_generic check_pat description assigns = function - | [] -> (Reporting_basic.print_err false true l "Monomorphisation" + | [] -> (Reporting.print_err false true l "Monomorphisation" ("Failed to find a case for " ^ description); None) | [Pat_aux (Pat_exp (P_aux (P_wild,_),exp),_)] -> Some (exp,[],[]) | (Pat_aux (Pat_exp (P_aux (P_typ (_,p),_),exp),ann))::tl -> @@ -1575,7 +1575,7 @@ let split_defs all_errors splits defs = | P_aux (P_app (id',[]),_) -> if Id.compare id id' = 0 then DoesMatch ([],[]) else DoesNotMatch | P_aux (_,(l',_)) -> - (Reporting_basic.print_err false true l' "Monomorphisation" + (Reporting.print_err false true l' "Monomorphisation" "Unexpected kind of pattern for enumeration"; GiveUp) in findpat_generic checkpat (string_of_id id) assigns cases | _ -> None) @@ -1598,11 +1598,11 @@ let split_defs all_errors splits defs = DoesMatch ([id, E_aux (E_cast (typ,E_aux (e,(l,empty_tannot))),(l,empty_tannot))], [kid,nexp]) | _ -> - (Reporting_basic.print_err false true lit_l "Monomorphisation" + (Reporting.print_err false true lit_l "Monomorphisation" "Unexpected kind of literal for var match"; GiveUp) end | P_aux (_,(l',_)) -> - (Reporting_basic.print_err false true l' "Monomorphisation" + (Reporting.print_err false true l' "Monomorphisation" "Unexpected kind of pattern for literal"; GiveUp) in findpat_generic checkpat "literal" assigns cases | E_vector es when List.for_all (function (E_aux (E_lit _,_)) -> true | _ -> false) es -> @@ -1622,11 +1622,11 @@ let split_defs all_errors splits defs = | _ -> DoesNotMatch) (DoesMatch ([],[])) matches in (match final with | GiveUp -> - (Reporting_basic.print_err false true l "Monomorphisation" + (Reporting.print_err false true l "Monomorphisation" "Unexpected kind of pattern for vector literal"; GiveUp) | _ -> final) | _ -> - (Reporting_basic.print_err false true l "Monomorphisation" + (Reporting.print_err false true l "Monomorphisation" "Unexpected kind of pattern for vector literal"; GiveUp) in findpat_generic checkpat "vector literal" assigns cases @@ -1644,7 +1644,7 @@ let split_defs all_errors splits defs = DoesMatch ([id, E_aux (E_cast (typ,e_undef),(l,empty_tannot))], KBindings.bindings ksubst) | P_aux (_,(l',_)) -> - (Reporting_basic.print_err false true l' "Monomorphisation" + (Reporting.print_err false true l' "Monomorphisation" "Unexpected kind of pattern for literal"; GiveUp) in findpat_generic checkpat "literal" assigns cases | _ -> None @@ -1670,7 +1670,7 @@ let split_defs all_errors splits defs = let new_l = Generated l in let renew_id (Id_aux (id,l)) = Id_aux (id,new_l) in let cannot msg = - let open Reporting_basic in + let open Reporting in let error = Err_general (pat_l, ("Cannot split type " ^ string_of_typ typ ^ " for variable " ^ v ^ ": " ^ msg)) @@ -1726,7 +1726,7 @@ let split_defs all_errors splits defs = let nc = List.fold_left nc_and nc_true ncs in (match extract_set_nc l kvar nc with | (is,_) -> List.map (mk_lit (Some kvar)) is - | exception Reporting_basic.Fatal_error (Reporting_basic.Err_general (_,msg)) -> cannot msg) + | exception Reporting.Fatal_error (Reporting.Err_general (_,msg)) -> cannot msg) | _ -> cannot ("unsupport atom nexp " ^ string_of_nexp nexp) end | _ -> cannot ("unsupported type " ^ string_of_typ typ) @@ -1799,10 +1799,10 @@ let split_defs all_errors splits defs = | P_not p -> (* todo: not sure that I can't split - but can't figure out how at * the moment *) - raise (Reporting_basic.err_general l + raise (Reporting.err_general l ("Cannot split on 'not' pattern")) | P_as (p',id) when id_match id <> None -> - raise (Reporting_basic.err_general l + raise (Reporting.err_general l ("Cannot split " ^ string_of_id id ^ " on 'as' pattern")) | P_as (p',id) -> re (fun p -> P_as (p,id)) p' @@ -1907,7 +1907,7 @@ let split_defs all_errors splits defs = match args with | [P_aux (P_var (_, TP_aux (TP_var kid, _)),ann)] -> kid,ann | _ -> - raise (Reporting_basic.err_general l + raise (Reporting.err_general l "Pattern match not currently supported by monomorphisation") in let map_inst (insts,id',_) = @@ -1941,7 +1941,7 @@ let split_defs all_errors splits defs = let overlap = List.exists (fun (v,_) -> List.mem v pvs) lvs in let () = if overlap then - Reporting_basic.print_err false true l "Monomorphisation" + Reporting.print_err false true l "Monomorphisation" "Splitting a singleton pattern is not possible" in p in @@ -1949,7 +1949,7 @@ let split_defs all_errors splits defs = let check_split_size lst l = let size = List.length lst in if size > size_set_limit then - let open Reporting_basic in + let open Reporting in let error = Err_general (l, "Case split is too large (" ^ string_of_int size ^ " > limit " ^ string_of_int size_set_limit ^ ")") @@ -2184,9 +2184,9 @@ let rec sizes_of_typ (Typ_aux (t,l)) = | Typ_id _ | Typ_var _ -> KidSet.empty - | Typ_fn _ -> raise (Reporting_basic.err_general l + | Typ_fn _ -> raise (Reporting.err_general l "Function type on expression") - | Typ_bidir _ -> raise (Reporting_basic.err_general l "Mapping type on expression") + | Typ_bidir _ -> raise (Reporting.err_general l "Mapping type on expression") | Typ_tup typs -> kidset_bigunion (List.map sizes_of_typ typs) | Typ_exist (kids,_,typ) -> List.fold_left (fun s k -> KidSet.remove k s) (sizes_of_typ typ) kids @@ -2221,7 +2221,7 @@ let change_parameter_pat i = function mk_id "==", E_aux (E_lit lit,annot)), annot) in P_aux (P_id var, (l,empty_tannot)), ([],[test]) - | P_aux (_,(l,_)) -> raise (Reporting_basic.err_unreachable l __POS__ + | P_aux (_,(l,_)) -> raise (Reporting.err_unreachable l __POS__ "Expected variable pattern") (* TODO: make more precise, preferably with a proper free variables function @@ -2277,7 +2277,7 @@ let replace_with_the_value bound_nexps (E_aux (_,(l,_)) as exp) = | Typ_aux (Typ_app (Id_aux (Id "atom",_), [Typ_arg_aux (Typ_arg_nexp nexp,l')]),_) -> mk_exp nexp l l' - | _ -> raise (Reporting_basic.err_unreachable l __POS__ + | _ -> raise (Reporting.err_unreachable l __POS__ "atom stopped being an atom?") let replace_type env typ = @@ -2291,7 +2291,7 @@ let replace_type env typ = [Typ_arg_aux (Typ_arg_nexp nexp,l')]) -> Typ_aux (Typ_app (Id_aux (Id "itself",Generated Unknown), [Typ_arg_aux (Typ_arg_nexp nexp,l')]),Generated l) - | _ -> raise (Reporting_basic.err_unreachable l __POS__ + | _ -> raise (Reporting.err_unreachable l __POS__ "atom stopped being an atom?") @@ -2305,7 +2305,7 @@ let rewrite_size_parameters env (Defs defs) = let _, typ = Env.get_val_spec_orig id env in let types = match typ with | Typ_aux (Typ_fn (arg_typs,_,_),_) -> List.map (Env.expand_synonyms env) arg_typs - | _ -> raise (Reporting_basic.err_unreachable l __POS__ "Function clause does not have a function type") + | _ -> raise (Reporting.err_unreachable l __POS__ "Function clause does not have a function type") in let add_parameter (i,nmap) typ = let nmap = @@ -2628,7 +2628,7 @@ let string_of_callerkidset s = let string_of_dep = function | Have (args,extras) -> "Have (" ^ string_of_argsplits args ^ ";" ^ string_of_extra_splits extras ^ ")" - | Unknown (l,msg) -> "Unknown " ^ msg ^ " at " ^ Reporting_basic.loc_to_string l + | Unknown (l,msg) -> "Unknown " ^ msg ^ " at " ^ Reporting.loc_to_string l (* If a callee uses a type variable as a size, does it need to be split in the current function, or is it also a parameter? (Note that there may be multiple @@ -2902,8 +2902,8 @@ let refine_dependency env (E_aux (e,(l,annot)) as exp) pexps = with | Some pats -> if l = Parse_ast.Unknown then - (Reporting_basic.print_error - (Reporting_basic.Err_general + (Reporting.print_error + (Reporting.Err_general (l, "No location for pattern match: " ^ string_of_exp exp)); None) else @@ -3165,7 +3165,7 @@ let rec analyse_exp fn_id env assigns (E_aux (e,(l,annot)) as exp) = | E_internal_plet _ | E_internal_return _ | E_internal_value _ - -> raise (Reporting_basic.err_unreachable l __POS__ + -> raise (Reporting.err_unreachable l __POS__ ("Unexpected expression encountered in monomorphisation: " ^ string_of_exp exp)) | E_var (lexp,e1,e2) -> @@ -3500,7 +3500,7 @@ let print_result r = let _ = print_endline (" kid_in_caller: " ^ string_of_callerkidset r.kid_in_caller) in let _ = print_endline (" failures: \n " ^ (String.concat "\n " - (List.map (fun (l,s) -> Reporting_basic.loc_to_string l ^ ":\n " ^ + (List.map (fun (l,s) -> Reporting.loc_to_string l ^ ":\n " ^ String.concat "\n " (StringSet.elements s)) (Failures.bindings r.failures)))) in () @@ -3585,7 +3585,7 @@ let analyse_defs debug env (Defs defs) = then (true,splits,extras) else begin Failures.iter (fun l msgs -> - Reporting_basic.print_err false false l "Monomorphisation" (String.concat "\n" (StringSet.elements msgs))) + Reporting.print_err false false l "Monomorphisation" (String.concat "\n" (StringSet.elements msgs))) fails; (false, splits,extras) end @@ -3610,7 +3610,7 @@ let add_extra_splits extras (Defs defs) = let loc = match Analysis.translate_loc l with | Some l -> l | None -> - (Reporting_basic.print_err false false l "Monomorphisation" + (Reporting.print_err false false l "Monomorphisation" "Internal error: bad location for added case"; ("",0)) in @@ -4134,7 +4134,7 @@ let add_bitvector_casts (Defs defs) = match typ with | Typ_aux (Typ_fn (_,ret,_),_) -> ret | Typ_aux (_,l) as typ -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ ("Function clause must have function type: " ^ string_of_typ typ ^ " is not a function type")) in @@ -4356,19 +4356,19 @@ let monomorphise opts splits defs = let f,r,ex = Analysis.analyse_defs opts.debug_analysis env defs in if f || opts.all_split_errors || opts.continue_anyway then f, r, ex - else raise (Reporting_basic.err_general Unknown "Unable to monomorphise program") + else raise (Reporting.err_general Unknown "Unable to monomorphise program") else true, [], Analysis.ExtraSplits.empty in let splits = new_splits @ (List.map (fun (loc,id) -> (loc,id,None)) splits) in let ok_extras, defs, extra_splits = add_extra_splits extra_splits defs in let splits = splits @ extra_splits in let () = if ok_extras || opts.all_split_errors || opts.continue_anyway then () - else raise (Reporting_basic.err_general Unknown "Unable to monomorphise program") + else raise (Reporting.err_general Unknown "Unable to monomorphise program") in let ok_split, defs = split_defs opts.all_split_errors splits defs in let () = if (ok_analysis && ok_extras && ok_split) || opts.continue_anyway then () - else raise (Reporting_basic.err_general Unknown "Unable to monomorphise program") + else raise (Reporting.err_general Unknown "Unable to monomorphise program") in defs let add_bitvector_casts = BitvectorSizeCasts.add_bitvector_casts diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index 77e3072b..3ad4c07f 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -121,7 +121,7 @@ let rec ocaml_string_typ (Typ_aux (typ_aux, l)) arg = | Typ_bidir (t1, t2) -> string "\"BIDIR\"" | Typ_var kid -> string "\"VAR\"" | Typ_exist _ -> assert false - | Typ_internal_unknown -> raise (Reporting_basic.err_unreachable l __POS__ "escaped Typ_internal_unknown") + | Typ_internal_unknown -> raise (Reporting.err_unreachable l __POS__ "escaped Typ_internal_unknown") let ocaml_typ_id ctx = function | id when Id.compare id (mk_id "string") = 0 -> string "string" @@ -143,10 +143,10 @@ let rec ocaml_typ ctx (Typ_aux (typ_aux, l)) = | Typ_app (id, typs) -> parens (separate_map (string ", ") (ocaml_typ_arg ctx) typs) ^^ space ^^ ocaml_typ_id ctx id | Typ_tup typs -> parens (separate_map (string " * ") (ocaml_typ ctx) typs) | Typ_fn (typs, typ, _) -> separate space [ocaml_typ ctx (Typ_aux (Typ_tup typs, l)); string "->"; ocaml_typ ctx typ] - | Typ_bidir (t1, t2) -> raise (Reporting_basic.err_general l "Ocaml doesn't support bidir types") + | Typ_bidir (t1, t2) -> raise (Reporting.err_general l "Ocaml doesn't support bidir types") | Typ_var kid -> zencode_kid kid | Typ_exist _ -> assert false - | Typ_internal_unknown -> raise (Reporting_basic.err_unreachable l __POS__ "escaped Typ_internal_unknown") + | Typ_internal_unknown -> raise (Reporting.err_unreachable l __POS__ "escaped Typ_internal_unknown") and ocaml_typ_arg ctx (Typ_arg_aux (typ_arg_aux, _) as typ_arg) = match typ_arg_aux with | Typ_arg_typ typ -> ocaml_typ ctx typ @@ -674,7 +674,7 @@ let ocaml_pp_generators ctx defs orig_types required = if Bindings.mem id Type_check.Env.builtin_typs then IdSet.add id required else - raise (Reporting_basic.err_unreachable (id_loc id) __POS__ + raise (Reporting.err_unreachable (id_loc id) __POS__ ("Required generator of unknown type " ^ string_of_id id)) and add_req_from_id required id = if IdSet.mem id required then required @@ -687,13 +687,13 @@ let ocaml_pp_generators ctx defs orig_types required = | Typ_internal_unknown | Typ_fn _ | Typ_bidir _ - -> raise (Reporting_basic.err_unreachable (typ_loc full_typ) __POS__ + -> raise (Reporting.err_unreachable (typ_loc full_typ) __POS__ ("Required generator for type that should not appear: " ^ string_of_typ full_typ)) | Typ_tup typs -> List.fold_left add_req_from_typ required typs | Typ_exist _ -> - raise (Reporting_basic.err_todo (typ_loc full_typ) + raise (Reporting.err_todo (typ_loc full_typ) ("Generators for existential types not yet supported: " ^ string_of_typ full_typ)) | Typ_app (id,args) -> @@ -714,7 +714,7 @@ let ocaml_pp_generators ctx defs orig_types required = List.fold_left (fun req (Tu_aux (Tu_ty_id (typ,_),_)) -> add_req_from_typ req typ) required variants | TD_enum _ -> required - | TD_bitfield _ -> raise (Reporting_basic.err_todo l "Generators for bitfields not yet supported") + | TD_bitfield _ -> raise (Reporting.err_todo l "Generators for bitfields not yet supported") in let required = IdSet.fold (fun id req -> always_add_req_from_id req id) required required in let type_name id = zencode_string (string_of_id id) in @@ -770,7 +770,7 @@ let ocaml_pp_generators ctx defs orig_types required = let typ_str, args_pp = match typ with | Typ_id id -> type_name id, [string "g"] | Typ_app (id,args) -> type_name id, string "g"::List.map typearg args - | _ -> raise (Reporting_basic.err_todo l + | _ -> raise (Reporting.err_todo l ("Unsupported type for generators: " ^ string_of_typ full_typ)) in let args_pp = match args_pp with [] -> empty @@ -783,7 +783,7 @@ let ocaml_pp_generators ctx defs orig_types required = (match nexp with | Nexp_constant c -> string (Big_int.to_string c) (* TODO: overflow *) | Nexp_var v -> mk_arg v - | _ -> raise (Reporting_basic.err_todo l + | _ -> raise (Reporting.err_todo l ("Unsupported nexp for generators: " ^ string_of_nexp full_nexp))) | Typ_arg_order (Ord_aux (ord,_)) -> (match ord with @@ -797,7 +797,7 @@ let ocaml_pp_generators ctx defs orig_types required = match typ with | Typ_id id -> type_name id, [] | Typ_app (id,args) -> type_name id, List.map typearg args - | _ -> raise (Reporting_basic.err_todo l + | _ -> raise (Reporting.err_todo l ("Unsupported type for generators: " ^ string_of_typ full_typ)) in let args_pp = match args_pp with [] -> empty @@ -860,7 +860,7 @@ let ocaml_pp_generators ctx defs orig_types required = Some (separate_map (string ";" ^^ break 1) enum_constructor variants), Some (separate_map (break 1) build_enum_constructor variants) | _ -> - raise (Reporting_basic.err_todo l "Generators for records and bitfields not yet supported") + raise (Reporting.err_todo l "Generators for records and bitfields not yet supported") in let name = type_name id in let constructors_pp = match constructors with diff --git a/src/parser.mly b/src/parser.mly index 070dee50..bd7c2f62 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -175,7 +175,7 @@ let rec desugar_rchain chain s e = /*Terminals with no content*/ -%token And As Assert Bitzero Bitone By Match Clause Dec Default Effect End Op Tuple Where +%token And As Assert Bitzero Bitone By Match Clause Dec Default Effect End Op Where %token Enum Else False Forall Foreach Overload Function_ Mapping If_ In Inc Let_ Int Order Cast %token Pure Register Return Scattered Sizeof Struct Then True TwoCaret TYPE Typedef %token Undefined Union Newtype With Val Constraint Throw Try Catch Exit Bitfield diff --git a/src/pattern_completeness.ml b/src/pattern_completeness.ml index d54bbd3f..514eb5c0 100644 --- a/src/pattern_completeness.ml +++ b/src/pattern_completeness.ml @@ -269,7 +269,7 @@ let combine ctx gpat (l, pat) = (* This warning liable to false positives as join returns a pattern that overapproximates what can match, so we only report when the second match is a constructor. *) - Util.warn (Printf.sprintf "Possible redundant pattern match at %s\n" (Reporting_basic.loc_to_string l)); + Util.warn (Printf.sprintf "Possible redundant pattern match at %s\n" (Reporting.loc_to_string l)); GP_wild | _, gpat' -> join ctx gpat gpat' @@ -287,7 +287,7 @@ let shrink_loc = function let check l ctx cases = match cases_to_pats cases with - | [] -> Util.warn (Printf.sprintf "No non-guarded patterns at %s\n" (Reporting_basic.loc_to_string (shrink_loc l))) + | [] -> Util.warn (Printf.sprintf "No non-guarded patterns at %s\n" (Reporting.loc_to_string (shrink_loc l))) | (_, pat) :: pats -> let top_pat = List.fold_left (combine ctx) (generalize ctx pat) pats in if is_wild top_pat then @@ -295,7 +295,7 @@ let check l ctx cases = else let message = Printf.sprintf "Possible incomplete pattern match at %s\n\nMost general matched pattern is %s\n" - (Reporting_basic.loc_to_string (shrink_loc l)) + (Reporting.loc_to_string (shrink_loc l)) (string_of_gpat top_pat |> Util.cyan |> Util.clear) in Util.warn message diff --git a/src/pretty_print_common.ml b/src/pretty_print_common.ml index 1fb35158..6825259c 100644 --- a/src/pretty_print_common.ml +++ b/src/pretty_print_common.ml @@ -207,6 +207,7 @@ let doc_typ, doc_atomic_typ, doc_nexp, doc_nexp_constraint = separate space [nexp_constraint nc1; string "&"; nexp_constraint nc2] | NC_true -> string "true" | NC_false -> string "false" + | NC_app (id, args) -> doc_id id ^^ parens (separate_map (comma ^^ space) nexp args) (* expose doc_typ, doc_atomic_typ, doc_nexp and doc_nexp_constraint *) in typ, atomic_typ, nexp, nexp_constraint diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 2810d0ee..66c13678 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -240,7 +240,7 @@ let doc_nexp ctx ?(skip_vars=KidSet.empty) nexp = | Nexp_app (Id_aux (Id "abs_atom",_), [_]) -> parens (plussub nexp) | _ -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ ("cannot pretty-print nexp \"" ^ string_of_nexp nexp ^ "\"")) in atomic nexp @@ -427,7 +427,7 @@ let doc_typ, doc_atomic_typ = | Typ_id (Id_aux (Id "nat", _)) -> (match maybe_expand_range_type ty with | Some typ -> atomic_typ atyp_needed typ - | None -> raise (Reporting_basic.err_unreachable l __POS__ "Bad range type")) + | None -> raise (Reporting.err_unreachable l __POS__ "Bad range type")) | Typ_app(Id_aux (Id "implicit", _),_) -> (string "Z") | Typ_app(Id_aux (Id "atom", _), [Typ_arg_aux(Typ_arg_nexp n,_)]) -> @@ -491,7 +491,7 @@ let doc_typ, doc_atomic_typ = ampersand; doc_arithfact ctx ~exists:kids ?extra:length_constraint_pp nc]) | _ -> - raise (Reporting_basic.err_todo l + raise (Reporting.err_todo l ("Non-atom existential type not yet supported in Coq: " ^ string_of_typ ty)) end @@ -584,8 +584,8 @@ let doc_lit (L_aux(lit,l)) = let denom = Big_int.pow_int_positive 10 (String.length f) in (Big_int.add (Big_int.mul (Big_int.of_string i) denom) (Big_int.of_string f), denom) | _ -> - raise (Reporting_basic.Fatal_error - (Reporting_basic.Err_syntax_locn (l, "could not parse real literal"))) in + raise (Reporting.Fatal_error + (Reporting.Err_syntax_locn (l, "could not parse real literal"))) in parens (separate space (List.map string [ "realFromFrac"; Big_int.to_string num; Big_int.to_string denom])) @@ -720,34 +720,34 @@ let rec doc_pat ctxt apat_needed exists_as_pairs (P_aux (p,(l,annot)) as pat, ty let el_typ = match destruct_vector env typ with | Some (_,_,t) -> t - | None -> raise (Reporting_basic.err_unreachable l __POS__ "vector pattern doesn't have vector type") + | None -> raise (Reporting.err_unreachable l __POS__ "vector pattern doesn't have vector type") in let ppp = brackets (separate_map semi (fun p -> doc_pat ctxt true exists_as_pairs (p,el_typ)) pats) in if apat_needed then parens ppp else ppp | P_vector_concat pats -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "vector concatenation patterns should have been removed before pretty-printing") | P_tup pats -> let typs = match typ with | Typ_aux (Typ_tup typs, _) -> typs - | _ -> raise (Reporting_basic.err_unreachable l __POS__ "tuple pattern doesn't have tuple type") + | _ -> raise (Reporting.err_unreachable l __POS__ "tuple pattern doesn't have tuple type") in (match pats, typs with | [p], [typ'] -> doc_pat ctxt apat_needed exists_as_pairs (p, typ') - | [_], _ -> raise (Reporting_basic.err_unreachable l __POS__ "tuple pattern length does not match tuple type length") + | [_], _ -> raise (Reporting.err_unreachable l __POS__ "tuple pattern length does not match tuple type length") | _ -> parens (separate_map comma_sp (doc_pat ctxt false exists_as_pairs) (List.combine pats typs))) | P_list pats -> let el_typ = match typ with | Typ_aux (Typ_app (f, [Typ_arg_aux (Typ_arg_typ el_typ,_)]),_) when Id.compare f (mk_id "list") = 0 -> el_typ - | _ -> raise (Reporting_basic.err_unreachable l __POS__ "list pattern not a list") + | _ -> raise (Reporting.err_unreachable l __POS__ "list pattern not a list") in brackets (separate_map semi (fun p -> doc_pat ctxt false true (p, el_typ)) pats) | P_cons (p,p') -> let el_typ = match typ with | Typ_aux (Typ_app (f, [Typ_arg_aux (Typ_arg_typ el_typ,_)]),_) when Id.compare f (mk_id "list") = 0 -> el_typ - | _ -> raise (Reporting_basic.err_unreachable l __POS__ "list pattern not a list") + | _ -> raise (Reporting.err_unreachable l __POS__ "list pattern not a list") in doc_op (string "::") (doc_pat ctxt true true (p, el_typ)) (doc_pat ctxt true true (p', typ)) | P_string_append _ -> unreachable l __POS__ @@ -775,7 +775,7 @@ let typ_id_of (Typ_aux (typ, l)) = match typ with | Typ_app (register, [Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id id, _)), _)]) when string_of_id register = "register" -> id | Typ_app (id, _) -> id - | _ -> raise (Reporting_basic.err_unreachable l __POS__ "failed to get type id") + | _ -> raise (Reporting.err_unreachable l __POS__ "failed to get type id") (* TODO: maybe Nexp_exp, division? *) (* Evaluation of constant nexp subexpressions, because Coq will be able to do those itself *) @@ -873,7 +873,7 @@ let general_typ_of_annot annot = let general_typ_of (E_aux (_,annot)) = general_typ_of_annot annot let prefix_recordtype = true -let report = Reporting_basic.err_unreachable +let report = Reporting.err_unreachable let doc_exp, doc_let = let rec top_exp (ctxt : context) (aexp_needed : bool) (E_aux (e, (l,annot)) as full_exp) = @@ -1002,7 +1002,7 @@ let doc_exp, doc_let = | _ -> liftR ((prefix 2 1) (string "write_reg") (doc_lexp_deref ctxt le ^/^ expY e))) | E_vector_append(le,re) -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "E_vector_append should have been rewritten before pretty-printing") | E_cons(le,re) -> doc_op (group (colon^^colon)) (expY le) (expY re) | E_if(c,t,e) -> @@ -1036,11 +1036,11 @@ let doc_exp, doc_let = | (P_aux (P_var (P_aux (P_id id, _), _), _)) | (P_aux (P_id id, _))), _), _), body), _), _), _)), _)), _) -> id, body - | _ -> raise (Reporting_basic.err_unreachable l __POS__ ("Unable to find loop variable in " ^ string_of_exp body)) in + | _ -> raise (Reporting.err_unreachable l __POS__ ("Unable to find loop variable in " ^ string_of_exp body)) in let dir = match ord_exp with | E_aux (E_lit (L_aux (L_false, _)), _) -> "_down" | E_aux (E_lit (L_aux (L_true, _)), _) -> "_up" - | _ -> raise (Reporting_basic.err_unreachable l __POS__ ("Unexpected loop direction " ^ string_of_exp ord_exp)) + | _ -> raise (Reporting.err_unreachable l __POS__ ("Unexpected loop direction " ^ string_of_exp ord_exp)) in let combinator = if effectful (effect_of body) then "foreach_ZM" else "foreach_Z" in let combinator = combinator ^ dir in @@ -1069,7 +1069,7 @@ let doc_exp, doc_let = (prefix 2 1 (group body_lambda) (expN body)) ) ) - | _ -> raise (Reporting_basic.err_unreachable l __POS__ + | _ -> raise (Reporting.err_unreachable l __POS__ "Unexpected number of arguments for loop combinator") end | Id_aux (Id (("while" | "until") as combinator), _) -> @@ -1106,7 +1106,7 @@ let doc_exp, doc_let = (parens (prefix 2 1 (group lambda) (expN cond))) (parens (prefix 2 1 (group lambda) (expN body)))) ) - | _ -> raise (Reporting_basic.err_unreachable l __POS__ + | _ -> raise (Reporting.err_unreachable l __POS__ "Unexpected number of arguments for loop combinator") end | Id_aux (Id "early_return", _) -> @@ -1129,7 +1129,7 @@ let doc_exp, doc_let = doc_atomic_typ ctxt false (typ_of exp)] in true, doc_op colon epp tannot in if aexp_needed then parens tepp else tepp - | _ -> raise (Reporting_basic.err_unreachable l __POS__ + | _ -> raise (Reporting.err_unreachable l __POS__ "Unexpected number of arguments for early_return builtin") end | _ -> @@ -1143,7 +1143,7 @@ let doc_exp, doc_let = let (tqs,fn_ty) = Env.get_val_spec_orig f env in let arg_typs, ret_typ, eff = match fn_ty with | Typ_aux (Typ_fn (arg_typs,ret_typ,eff),_) -> arg_typs, ret_typ, eff - | _ -> raise (Reporting_basic.err_unreachable l __POS__ "Function not a function type") + | _ -> raise (Reporting.err_unreachable l __POS__ "Function not a function type") in let inst = match instantiation_of_without_type full_exp with @@ -1244,10 +1244,10 @@ let doc_exp, doc_let = liftR (if aexp_needed then parens (align epp) else epp) end | E_vector_access (v,e) -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "E_vector_access should have been rewritten before pretty-printing") | E_vector_subrange (v,e1,e2) -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "E_vector_subrange should have been rewritten before pretty-printing") | E_field((E_aux(_,(l,fannot)) as fexp),id) -> (match destruct_tannot fannot with @@ -1402,7 +1402,7 @@ let doc_exp, doc_let = let t = Env.base_typ_of (env_of full_exp) (typ_of full_exp) in let start, (len, order, etyp) = if is_vector_typ t then vector_start_index t, vector_typ_args_of t - else raise (Reporting_basic.err_unreachable l __POS__ + else raise (Reporting.err_unreachable l __POS__ "E_vector of non-vector type") in let dir,dir_out = if is_order_inc order then (true,"true") else (false, "false") in let expspp = @@ -1427,10 +1427,10 @@ let doc_exp, doc_let = (vepp,aexp_needed) in if aexp_needed then parens (align epp) else epp | E_vector_update(v,e1,e2) -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "E_vector_update should have been rewritten before pretty-printing") | E_vector_update_subrange(v,e1,e2,e3) -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "E_vector_update should have been rewritten before pretty-printing") | E_list exps -> brackets (separate_map semi (expN) exps) @@ -1451,7 +1451,7 @@ let doc_exp, doc_let = (string "end)")) in if aexp_needed then parens (align epp) else align epp else - raise (Reporting_basic.err_todo l "Warning: try-block around pure expression") + raise (Reporting.err_todo l "Warning: try-block around pure expression") | E_throw e -> let epp = liftR (separate space [string "throw"; expY e]) in if aexp_needed then parens (align epp) else align epp @@ -1460,7 +1460,7 @@ let doc_exp, doc_let = let epp = liftR (separate space [string "assert_exp"; expY e1; expY e2]) in if aexp_needed then parens (align epp) else align epp | E_app_infix (e1,id,e2) -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "E_app_infix should have been rewritten before pretty-printing") | E_var(lexp, eq_exp, in_exp) -> raise (report l __POS__ "E_vars should have been removed before pretty-printing") @@ -1548,7 +1548,7 @@ let doc_exp, doc_let = (match nexp_simp nexp with | Nexp_aux (Nexp_constant i, _) -> doc_lit (L_aux (L_num i, l)) | _ -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "pretty-printing non-constant sizeof expressions to Lem not supported")) | E_return r -> let ret_monad = " : MR" in @@ -1567,7 +1567,7 @@ let doc_exp, doc_let = align (parens (string "early_return" ^//^ exp_pp ^//^ ta)) | E_constraint nc -> wrap_parens (doc_nc_exp ctxt nc) | E_internal_value _ -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "unsupported internal expression encountered while pretty-printing") and if_exp ctxt (elseif : bool) c t e = let if_pp = string (if elseif then "else if" else "if") in @@ -1620,7 +1620,7 @@ let doc_exp, doc_let = group (prefix 3 1 (separate space [pipe; doc_pat ctxt false false (pat,typ);bigarrow]) (group (top_exp ctxt false e))) | Pat_aux(Pat_when(_,_,_),(l,_)) -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "guarded pattern expression should have been rewritten before pretty-printing") and doc_lexp_deref ctxt ((LEXP_aux(lexp,(l,annot)))) = match lexp with @@ -1630,7 +1630,7 @@ let doc_exp, doc_let = | LEXP_cast (typ,id) -> doc_id (append_id id "_ref") | LEXP_tup lexps -> parens (separate_map comma_sp (doc_lexp_deref ctxt) lexps) | _ -> - raise (Reporting_basic.err_unreachable l __POS__ ("doc_lexp_deref: Unsupported lexp")) + raise (Reporting.err_unreachable l __POS__ ("doc_lexp_deref: Unsupported lexp")) (* expose doc_exp and doc_let *) in top_exp, let_exp @@ -1698,7 +1698,7 @@ let doc_typdef (TD_aux(td, (l, annot))) = match td with match nexp_simp start with | Nexp_aux (Nexp_constant i, _) -> (i, is_order_inc ord) | _ -> - raise (Reporting_basic.err_unreachable Parse_ast.Unknown __POS__ + raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ ("register " ^ string_of_id id ^ " has non-constant start index " ^ string_of_nexp start)) with | _ -> (Big_int.zero, true) in @@ -1759,7 +1759,7 @@ let doc_typdef (TD_aux(td, (l, annot))) = match td with string "forall (x y : " ^^ id_pp ^^ string "), Decidable (x = y) :=" ^/^ string "Decidable_eq_from_dec " ^^ id_pp ^^ string "_eq_dec." in typ_pp ^^ dot ^^ hardline ^^ eq1_pp ^^ hardline ^^ eq2_pp ^^ hardline) - | _ -> raise (Reporting_basic.err_unreachable l __POS__ "register with non-constant indices") + | _ -> raise (Reporting.err_unreachable l __POS__ "register with non-constant indices") let args_of_typ l env typs = let arg i typ = @@ -1888,7 +1888,7 @@ let merge_kids_atoms pats = | Some (Nexp_aux (Nexp_var kid,l)) -> if KidSet.mem kid seen then let () = - Reporting_basic.print_err false true l "merge_kids_atoms" + Reporting.print_err false true l "merge_kids_atoms" ("want to merge tyvar and argument for " ^ string_of_kid kid ^ " but rearranging arguments isn't supported yet") in gone,map,seen @@ -2021,7 +2021,7 @@ let doc_funcl (FCL_aux(FCL_Funcl(id, pexp), annot)) = let _ = match guard with | None -> () | _ -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "guarded pattern expression should have been rewritten before pretty-printing") in let bodypp = doc_fun_body ctxt exp in let bodypp = if effectful eff || not build_ex then bodypp else string "build_ex" ^^ parens bodypp in @@ -2076,8 +2076,8 @@ let doc_dec (DEC_aux (reg, ((l, _) as annot))) = string o; string "[]"])) ^/^ hardline - else raise (Reporting_basic.err_unreachable l __POS__ ("can't deal with register type " ^ string_of_typ typ)) - else raise (Reporting_basic.err_unreachable l __POS__ ("can't deal with register type " ^ string_of_typ typ)) *) + else raise (Reporting.err_unreachable l __POS__ ("can't deal with register type " ^ string_of_typ typ)) + else raise (Reporting.err_unreachable l __POS__ ("can't deal with register type " ^ string_of_typ typ)) *) | DEC_config _ -> empty | DEC_alias(id,alspec) -> empty | DEC_typ_alias(typ,id,alspec) -> empty @@ -2094,7 +2094,7 @@ let is_field_accessor regtypes fdef = let doc_regtype_fields (tname, (n1, n2, fields)) = let i1, i2 = match n1, n2 with | Nexp_aux(Nexp_constant i1,_),Nexp_aux(Nexp_constant i2,_) -> i1, i2 - | _ -> raise (Reporting_basic.err_typ Parse_ast.Unknown + | _ -> raise (Reporting.err_typ Parse_ast.Unknown ("Non-constant indices in register type " ^ tname)) in let dir_b = i1 < i2 in let dir = (if dir_b then "true" else "false") in @@ -2102,7 +2102,7 @@ let doc_regtype_fields (tname, (n1, n2, fields)) = let i, j = match fr with | BF_aux (BF_single i, _) -> (i, i) | BF_aux (BF_range (i, j), _) -> (i, j) - | _ -> raise (Reporting_basic.err_unreachable Parse_ast.Unknown __POS__ + | _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ ("Unsupported type in field " ^ string_of_id fid ^ " of " ^ tname)) in let fsize = Big_int.succ (Big_int.abs (Big_int.sub i j)) in (* TODO Assumes normalised, decreasing bitvector slices; however, since @@ -2184,7 +2184,7 @@ let doc_val pat exp = id, None | P_aux (P_typ (typ, P_aux (P_var (P_aux (P_id id, _), TP_aux (TP_var kid, _)),_)),_) when Id.compare id (id_of_kid kid) == 0 -> id, Some typ - | _ -> raise (Reporting_basic.err_todo (pat_loc pat) + | _ -> raise (Reporting.err_todo (pat_loc pat) "Top-level value definition with complex pattern not supported for Coq yet") in let typpp = match pat_typ with @@ -2272,7 +2272,7 @@ try let register_refs = State.register_refs_coq (State.find_registers defs) in let unimplemented = find_unimplemented defs in let () = if !opt_undef_axioms || IdSet.is_empty unimplemented then () else - Reporting_basic.print_err false false Parse_ast.Unknown "Warning" + Reporting.print_err false false Parse_ast.Unknown "Warning" ("The following functions were declared but are undefined:\n" ^ String.concat "\n" (List.map string_of_id (IdSet.elements unimplemented))) in @@ -2316,4 +2316,4 @@ with Type_check.Type_error (l,err) -> then "\n" ^ Printexc.get_backtrace () else "(backtracing unavailable)" in - raise (Reporting_basic.err_typ l (Type_error.string_of_type_error err ^ extra)) + raise (Reporting.err_typ l (Type_error.string_of_type_error err ^ extra)) diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index 68825c8f..15d945ac 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -194,7 +194,7 @@ let doc_nexp_lem nexp = | Nexp_exp n -> "exp_" ^ mangle_nexp n | Nexp_neg n -> "neg_" ^ mangle_nexp n | _ -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ ("cannot pretty-print nexp \"" ^ string_of_nexp full_nexp ^ "\"")) end in string ("'" ^ mangle_nexp full_nexp) @@ -240,8 +240,8 @@ let rec lem_nexps_of_typ (Typ_aux (t,l)) = List.fold_left (fun s ta -> NexpSet.union s (lem_nexps_of_typ_arg ta)) NexpSet.empty tas | Typ_exist (kids,_,t) -> trec t - | Typ_bidir _ -> raise (Reporting_basic.err_unreachable l __POS__ "Lem doesn't support bidir types") - | Typ_internal_unknown -> raise (Reporting_basic.err_unreachable l __POS__ "escaped Typ_internal_unknown") + | Typ_bidir _ -> raise (Reporting.err_unreachable l __POS__ "Lem doesn't support bidir types") + | Typ_internal_unknown -> raise (Reporting.err_unreachable l __POS__ "escaped Typ_internal_unknown") and lem_nexps_of_typ_arg (Typ_arg_aux (ta,_)) = match ta with | Typ_arg_nexp nexp -> NexpSet.singleton (nexp_simp (orig_nexp nexp)) @@ -283,7 +283,7 @@ let doc_typ_lem, doc_atomic_typ_lem = (* (match nexp_simp m with | (Nexp_aux(Nexp_constant i,_)) -> string "bitvector ty" ^^ doc_int i | (Nexp_aux(Nexp_var _, _)) -> separate space [string "bitvector"; doc_nexp m] - | _ -> raise (Reporting_basic.err_unreachable l __POS__ + | _ -> raise (Reporting.err_unreachable l __POS__ "cannot pretty-print bitvector type with non-constant length")) *) | _ -> string "list" ^^ space ^^ typ elem_typ in if atyp_needed then parens tpp else tpp @@ -318,7 +318,7 @@ let doc_typ_lem, doc_atomic_typ_lem = let visible_vars = lem_tyvars_of_typ ty in match List.filter (fun kid -> KidSet.mem kid visible_vars) kids with | [] -> if atyp_needed then parens tpp else tpp - | bad -> raise (Reporting_basic.err_general l + | bad -> raise (Reporting.err_general l ("Existential type variable(s) " ^ String.concat ", " (List.map string_of_kid bad) ^ " escape into Lem")) @@ -405,8 +405,8 @@ let doc_lit_lem (L_aux(lit,l)) = let denom = Big_int.pow_int_positive 10 (String.length f) in (Big_int.add (Big_int.mul (Big_int.of_string i) denom) (Big_int.of_string f), denom) | _ -> - raise (Reporting_basic.Fatal_error - (Reporting_basic.Err_syntax_locn (l, "could not parse real literal"))) in + raise (Reporting.Fatal_error + (Reporting.Err_syntax_locn (l, "could not parse real literal"))) in parens (separate space (List.map string [ "realFromFrac"; Big_int.to_string num; Big_int.to_string denom])) @@ -513,7 +513,7 @@ let rec doc_pat_lem ctxt apat_needed (P_aux (p,(l,annot)) as pa) = match p with let ppp = brackets (separate_map semi (doc_pat_lem ctxt true) pats) in if apat_needed then parens ppp else ppp | P_vector_concat pats -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "vector concatenation patterns should have been removed before pretty-printing") | P_tup pats -> (match pats with @@ -556,10 +556,10 @@ let typ_id_of (Typ_aux (typ, l)) = match typ with | Typ_app (register, [Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id id, _)), _)]) when string_of_id register = "register" -> id | Typ_app (id, _) -> id - | _ -> raise (Reporting_basic.err_unreachable l __POS__ "failed to get type id") + | _ -> raise (Reporting.err_unreachable l __POS__ "failed to get type id") let prefix_recordtype = true -let report = Reporting_basic.err_unreachable +let report = Reporting.err_unreachable let doc_exp_lem, doc_let_lem = let rec top_exp (ctxt : context) (aexp_needed : bool) (E_aux (e, (l,annot)) as full_exp) = @@ -632,7 +632,7 @@ let doc_exp_lem, doc_let_lem = | _ -> liftR ((prefix 2 1) (string "write_reg") (doc_lexp_deref_lem ctxt le ^/^ expY e))) | E_vector_append(le,re) -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "E_vector_append should have been rewritten before pretty-printing") | E_cons(le,re) -> doc_op (group (colon^^colon)) (expY le) (expY re) | E_if(c,t,e) -> wrap_parens (align (if_exp ctxt false c t e)) @@ -663,7 +663,7 @@ let doc_exp_lem, doc_let_lem = | (P_aux (P_var (P_aux (P_id id, _), _), _)) | (P_aux (P_id id, _))), _), _), body), _), _), _)), _)), _) -> id, body - | _ -> raise (Reporting_basic.err_unreachable l __POS__ ("Unable to find loop variable in " ^ string_of_exp body)) in + | _ -> raise (Reporting.err_unreachable l __POS__ ("Unable to find loop variable in " ^ string_of_exp body)) in let step = match ord_exp with | E_aux (E_lit (L_aux (L_false, _)), _) -> parens (separate space [string "integerNegate"; expY exp3]) @@ -694,7 +694,7 @@ let doc_exp_lem, doc_let_lem = (prefix 2 1 (group body_lambda) (expN body)) ) ) - | _ -> raise (Reporting_basic.err_unreachable l __POS__ + | _ -> raise (Reporting.err_unreachable l __POS__ "Unexpected number of arguments for loop combinator") end | Id_aux (Id (("while" | "until") as combinator), _) -> @@ -731,7 +731,7 @@ let doc_exp_lem, doc_let_lem = (parens (prefix 2 1 (group lambda) (expN cond))) (parens (prefix 2 1 (group lambda) (expN body)))) ) - | _ -> raise (Reporting_basic.err_unreachable l __POS__ + | _ -> raise (Reporting.err_unreachable l __POS__ "Unexpected number of arguments for loop combinator") end | Id_aux (Id "early_return", _) -> @@ -751,7 +751,7 @@ let doc_exp_lem, doc_let_lem = | _ -> aexp_needed, epp in if aexp_needed then parens tepp else tepp - | _ -> raise (Reporting_basic.err_unreachable l __POS__ + | _ -> raise (Reporting.err_unreachable l __POS__ "Unexpected number of arguments for early_return builtin") end | _ -> @@ -787,10 +787,10 @@ let doc_exp_lem, doc_let_lem = end end | E_vector_access (v,e) -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "E_vector_access should have been rewritten before pretty-printing") | E_vector_subrange (v,e1,e2) -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "E_vector_subrange should have been rewritten before pretty-printing") | E_field((E_aux(_,(l,fannot)) as fexp),id) -> let ft = typ_of_annot (l,fannot) in @@ -847,7 +847,7 @@ let doc_exp_lem, doc_let_lem = let t = Env.base_typ_of (env_of full_exp) (typ_of full_exp) in let start, (len, order, etyp) = if is_vector_typ t then vector_start_index t, vector_typ_args_of t - else raise (Reporting_basic.err_unreachable l __POS__ + else raise (Reporting.err_unreachable l __POS__ "E_vector of non-vector type") in let dir,dir_out = if is_order_inc order then (true,"true") else (false, "false") in let start = match nexp_simp start with @@ -874,10 +874,10 @@ let doc_exp_lem, doc_let_lem = else (epp,aexp_needed) in if aexp_needed then parens (align epp) else epp | E_vector_update(v,e1,e2) -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "E_vector_update should have been rewritten before pretty-printing") | E_vector_update_subrange(v,e1,e2,e3) -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "E_vector_update should have been rewritten before pretty-printing") | E_list exps -> brackets (separate_map semi (expN) exps) @@ -895,7 +895,7 @@ let doc_exp_lem, doc_let_lem = (separate_map (break 1) (doc_case ctxt) pexps) ^/^ (string "end)"))) else - raise (Reporting_basic.err_todo l "Warning: try-block around pure expression") + raise (Reporting.err_todo l "Warning: try-block around pure expression") | E_throw e -> align (liftR (separate space [string "throw"; expY e])) | E_exit e -> liftR (separate space [string "exit"; expY e]) @@ -932,7 +932,7 @@ let doc_exp_lem, doc_let_lem = (match nexp_simp nexp with | Nexp_aux (Nexp_constant i, _) -> doc_lit_lem (L_aux (L_num i, l)) | _ -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "pretty-printing non-constant sizeof expressions to Lem not supported")) | E_return r -> let ta = @@ -948,7 +948,7 @@ let doc_exp_lem, doc_let_lem = align (parens (string "early_return" ^//^ expV true r ^//^ ta)) | E_constraint _ -> string "true" | E_internal_value _ -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "unsupported internal expression encountered while pretty-printing") and if_exp ctxt (elseif : bool) c t e = let if_pp = string (if elseif then "else if" else "if") in @@ -981,7 +981,7 @@ let doc_exp_lem, doc_let_lem = group (prefix 3 1 (separate space [pipe; doc_pat_lem ctxt false pat;arrow]) (group (top_exp ctxt false e))) | Pat_aux(Pat_when(_,_,_),(l,_)) -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "guarded pattern expression should have been rewritten before pretty-printing") and doc_lexp_deref_lem ctxt ((LEXP_aux(lexp,(l,annot))) as le) = match lexp with @@ -991,7 +991,7 @@ let doc_exp_lem, doc_let_lem = | LEXP_cast (typ,id) -> doc_id_lem (append_id id "_ref") | LEXP_tup lexps -> parens (separate_map comma_sp (doc_lexp_deref_lem ctxt) lexps) | _ -> - raise (Reporting_basic.err_unreachable l __POS__ ("doc_lexp_deref_lem: Unsupported lexp")) + raise (Reporting.err_unreachable l __POS__ ("doc_lexp_deref_lem: Unsupported lexp")) (* expose doc_exp_lem and doc_let *) in top_exp, let_exp @@ -1046,7 +1046,7 @@ let doc_typdef_lem (TD_aux(td, (l, annot))) = match td with match nexp_simp start with | Nexp_aux (Nexp_constant i, _) -> (i, is_order_inc ord) | _ -> - raise (Reporting_basic.err_unreachable Parse_ast.Unknown __POS__ + raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ ("register " ^ string_of_id id ^ " has non-constant start index " ^ string_of_nexp start)) with | _ -> (Big_int.zero, true) in @@ -1226,7 +1226,7 @@ let doc_typdef_lem (TD_aux(td, (l, annot))) = match td with fromInterpValuePP ^^ hardline ^^ hardline ^^ fromToInterpValuePP ^^ hardline else empty) - | _ -> raise (Reporting_basic.err_unreachable l __POS__ "register with non-constant indices") + | _ -> raise (Reporting.err_unreachable l __POS__ "register with non-constant indices") let args_of_typs l env typs = let arg i typ = @@ -1288,7 +1288,7 @@ let doc_funcl_lem (FCL_aux(FCL_Funcl(id, pexp), annot)) = let _ = match guard with | None -> () | _ -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "guarded pattern expression should have been rewritten before pretty-printing") in group (prefix 3 1 (separate space [doc_id_lem id; patspp; equals]) @@ -1342,8 +1342,8 @@ let doc_dec_lem (DEC_aux (reg, ((l, _) as annot))) = string o; string "[]"])) ^/^ hardline - else raise (Reporting_basic.err_unreachable l __POS__ ("can't deal with register type " ^ string_of_typ typ)) - else raise (Reporting_basic.err_unreachable l __POS__ ("can't deal with register type " ^ string_of_typ typ)) *) + else raise (Reporting.err_unreachable l __POS__ ("can't deal with register type " ^ string_of_typ typ)) + else raise (Reporting.err_unreachable l __POS__ ("can't deal with register type " ^ string_of_typ typ)) *) | DEC_alias(id,alspec) -> empty | DEC_typ_alias(typ,id,alspec) -> empty @@ -1369,7 +1369,7 @@ let is_field_accessor regtypes fdef = let doc_regtype_fields (tname, (n1, n2, fields)) = let i1, i2 = match n1, n2 with | Nexp_aux(Nexp_constant i1,_),Nexp_aux(Nexp_constant i2,_) -> i1, i2 - | _ -> raise (Reporting_basic.err_typ Parse_ast.Unknown + | _ -> raise (Reporting.err_typ Parse_ast.Unknown ("Non-constant indices in register type " ^ tname)) in let dir_b = i1 < i2 in let dir = (if dir_b then "true" else "false") in @@ -1377,7 +1377,7 @@ let doc_regtype_fields (tname, (n1, n2, fields)) = let i, j = match fr with | BF_aux (BF_single i, _) -> (i, i) | BF_aux (BF_range (i, j), _) -> (i, j) - | _ -> raise (Reporting_basic.err_unreachable Parse_ast.Unknown __POS__ + | _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ ("Unsupported type in field " ^ string_of_id fid ^ " of " ^ tname)) in let fsize = Big_int.succ (Big_int.abs (Big_int.sub i j)) in (* TODO Assumes normalised, decreasing bitvector slices; however, since diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index 37c48220..7de4dd40 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -162,7 +162,7 @@ let rec doc_typ (Typ_aux (typ_aux, l)) = separate space [doc_arg_typs typs; string "->"; doc_typ typ; string "effect"; ocaml_eff] | Typ_bidir (typ1, typ2) -> separate space [doc_typ typ1; string "<->"; doc_typ typ2] - | Typ_internal_unknown -> raise (Reporting_basic.err_unreachable l __POS__ "escaped Typ_internal_unknown") + | Typ_internal_unknown -> raise (Reporting.err_unreachable l __POS__ "escaped Typ_internal_unknown") and doc_typ_arg (Typ_arg_aux (ta_aux, _)) = match ta_aux with | Typ_arg_typ typ -> doc_typ typ diff --git a/src/process_file.ml b/src/process_file.ml index 2dfd9571..bb789d0a 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -65,7 +65,7 @@ let get_lexbuf f = lexbuf, in_chan let parse_file ?loc:(l=Parse_ast.Unknown) (f : string) : Parse_ast.defs = - let open Reporting_basic in + let open Reporting in try let lexbuf, in_chan = get_lexbuf f in begin @@ -111,7 +111,7 @@ let cond_pragma l defs = decr depth; push_def def; scan defs | def :: defs -> push_def def; scan defs - | [] -> raise (Reporting_basic.err_general l "$ifdef or $ifndef never ended by $endif") + | [] -> raise (Reporting.err_general l "$ifdef or $ifndef never ended by $endif") in scan defs @@ -123,19 +123,24 @@ let parseid_to_string (Parse_ast.Id_aux (id, _)) = match id with | Parse_ast.Id x | Parse_ast.DeIid x -> x -let rec realise_union_anon_rec_types (Parse_ast.TD_variant (union_id, name_scm_opt, typq, _, flag) as orig_union) arms = - match arms with - | [] -> [] - | arm :: arms -> - match arm with - | (Parse_ast.Tu_aux ((Parse_ast.Tu_ty_id _), _)) -> (None, arm) :: realise_union_anon_rec_types orig_union arms - | (Parse_ast.Tu_aux ((Parse_ast.Tu_ty_anon_rec (fields, id)), l)) -> - let open Parse_ast in - let record_str = "_" ^ parseid_to_string union_id ^ "_" ^ parseid_to_string id ^ "_record" in - let record_id = Id_aux (Id record_str, Generated l) in - let new_arm = Tu_aux ((Tu_ty_id ((ATyp_aux (ATyp_id record_id, Generated l)), id)), Generated l) in - let new_rec_def = DEF_type (TD_aux (TD_record (record_id, name_scm_opt, typq, fields, flag), Generated l)) in - (Some new_rec_def, new_arm) :: (realise_union_anon_rec_types orig_union arms) +let rec realise_union_anon_rec_types orig_union arms = + match orig_union with + | Parse_ast.TD_variant (union_id, name_scm_opt, typq, _, flag) -> + begin match arms with + | [] -> [] + | arm :: arms -> + match arm with + | (Parse_ast.Tu_aux ((Parse_ast.Tu_ty_id _), _)) -> (None, arm) :: realise_union_anon_rec_types orig_union arms + | (Parse_ast.Tu_aux ((Parse_ast.Tu_ty_anon_rec (fields, id)), l)) -> + let open Parse_ast in + let record_str = "_" ^ parseid_to_string union_id ^ "_" ^ parseid_to_string id ^ "_record" in + let record_id = Id_aux (Id record_str, Generated l) in + let new_arm = Tu_aux ((Tu_ty_id ((ATyp_aux (ATyp_id record_id, Generated l)), id)), Generated l) in + let new_rec_def = DEF_type (TD_aux (TD_record (record_id, name_scm_opt, typq, fields, flag), Generated l)) in + (Some new_rec_def, new_arm) :: (realise_union_anon_rec_types orig_union arms) + end + | _ -> + raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Non union type-definition passed to realise_union_anon_rec_typs") let rec preprocess opts = function | [] -> [] @@ -149,11 +154,10 @@ let rec preprocess opts = function let args = Str.split (Str.regexp " +") command in Arg.parse_argv ~current:(ref 0) (Array.of_list ("sail" :: args)) opts (fun _ -> ()) ""; with - | Arg.Bad message | Arg.Help message -> raise (Reporting_basic.err_general l message) + | Arg.Bad message | Arg.Help message -> raise (Reporting.err_general l message) end; preprocess opts defs - | Parse_ast.DEF_pragma ("ifndef", symbol, l) :: defs -> let then_defs, else_defs, defs = cond_pragma l defs in if not (StringSet.mem symbol !symbols) then @@ -309,7 +313,7 @@ let output_lem filename libs defs = open_output_with_check_unformatted (filename ^ ".lem") in (Pretty_print.pp_defs_lem (ot, base_imports) - (o, base_imports @ (String.capitalize types_module :: libs)) + (o, base_imports @ (String.capitalize_ascii types_module :: libs)) defs generated_line); close_output_with_check ext_ot; close_output_with_check ext_o; @@ -378,7 +382,7 @@ let rewrite_step defs (name,rewriter) = let rewrite rewriters defs = try List.fold_left rewrite_step defs rewriters with | Type_check.Type_error (l, err) -> - raise (Reporting_basic.err_typ l (Type_error.string_of_type_error err)) + raise (Reporting.err_typ l (Type_error.string_of_type_error err)) let rewrite_ast = rewrite [("initial", Rewriter.rewrite_defs)] let rewrite_undefined bitvectors = rewrite [("undefined", fun x -> Rewrites.rewrite_undefined bitvectors x)] diff --git a/src/reporting.ml b/src/reporting.ml new file mode 100644 index 00000000..fffae5a7 --- /dev/null +++ b/src/reporting.ml @@ -0,0 +1,296 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + + +(**************************************************************************) +(* Lem *) +(* *) +(* Dominic Mulligan, University of Cambridge *) +(* Francesco Zappa Nardelli, INRIA Paris-Rocquencourt *) +(* Gabriel Kerneis, University of Cambridge *) +(* Kathy Gray, University of Cambridge *) +(* Peter Boehm, University of Cambridge (while working on Lem) *) +(* Peter Sewell, University of Cambridge *) +(* Scott Owens, University of Kent *) +(* Thomas Tuerk, University of Cambridge *) +(* *) +(* The Lem sources are copyright 2010-2013 *) +(* by the UK authors above and Institut National de Recherche en *) +(* Informatique et en Automatique (INRIA). *) +(* *) +(* All files except ocaml-lib/pmap.{ml,mli} and ocaml-libpset.{ml,mli} *) +(* are distributed under the license below. The former are distributed *) +(* under the LGPLv2, as in the LICENSE file. *) +(* *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in the *) +(* documentation and/or other materials provided with the distribution. *) +(* 3. The names of the authors may not be used to endorse or promote *) +(* products derived from this software without specific prior written *) +(* permission. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS *) +(* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED *) +(* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE *) +(* ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY *) +(* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL *) +(* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE *) +(* GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS *) +(* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER *) +(* IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR *) +(* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN *) +(* IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) +(**************************************************************************) + +let rec skip_lines in_chan = function + | n when n <= 0 -> () + | n -> ignore (input_line in_chan); skip_lines in_chan (n - 1) + +let rec read_lines in_chan = function + | n when n <= 0 -> [] + | n -> + let l = input_line in_chan in + let ls = read_lines in_chan (n - 1) in + l :: ls + +let termcode n = "\x1B[" ^ string_of_int n ^ "m" + +let print_code1 ff fname lnum1 cnum1 cnum2 = + try + let in_chan = open_in fname in + begin + try + skip_lines in_chan (lnum1 - 1); + let line = input_line in_chan in + Format.fprintf ff "%s%s%s" + (Str.string_before line cnum1) + Util.(Str.string_before (Str.string_after line cnum1) (cnum2 - cnum1) |> red_bg |> clear) + (Str.string_after line cnum2); + close_in in_chan + with e -> (close_in_noerr in_chan; + prerr_endline (Printf.sprintf "print_code1: %s %d %d %d %s" fname lnum1 cnum1 cnum2 (Printexc.to_string e))) + end + with _ -> () + +let format_pos ff p = + let open Lexing in + begin + Format.fprintf ff "file \"%s\", line %d, character %d:\n\n" + p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol); + print_code1 ff p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol) (p.pos_cnum - p.pos_bol + 1); + Format.fprintf ff "\n\n"; + Format.pp_print_flush ff () + end + +let print_code2 ff fname lnum1 cnum1 lnum2 cnum2 = + try + let in_chan = open_in fname in + begin + try + skip_lines in_chan (lnum1 - 1); + let line = input_line in_chan in + Format.fprintf ff "%s%s\n" + (Str.string_before line cnum1) + Util.(Str.string_after line cnum1 |> red_bg |> clear); + let lines = read_lines in_chan (lnum2 - lnum1 - 1) in + List.iter (fun l -> Format.fprintf ff "%s\n" Util.(l |> red_bg |> clear)) lines; + let line = input_line in_chan in + Format.fprintf ff "%s%s" + Util.(Str.string_before line cnum2 |> red_bg |> clear) + (Str.string_after line cnum2); + close_in in_chan + with e -> (close_in_noerr in_chan; prerr_endline (Printexc.to_string e)) + end + with _ -> () + +let format_pos2 ff p1 p2 = + let open Lexing in + begin + Format.fprintf ff "file \"%s\", line %d, character %d to line %d, character %d\n\n" + p1.pos_fname + p1.pos_lnum (p1.pos_cnum - p1.pos_bol + 1) + p2.pos_lnum (p2.pos_cnum - p2.pos_bol); + if p1.pos_lnum == p2.pos_lnum + then print_code1 ff p1.pos_fname p1.pos_lnum (p1.pos_cnum - p1.pos_bol) (p2.pos_cnum - p2.pos_bol) + else print_code2 ff p1.pos_fname p1.pos_lnum (p1.pos_cnum - p1.pos_bol) p2.pos_lnum (p2.pos_cnum - p2.pos_bol); + Format.pp_print_flush ff () + end + +(* reads the part between p1 and p2 from the file *) + +let read_from_file_pos2 p1 p2 = + let (s, e, multi) = if p1.Lexing.pos_lnum = p2.Lexing.pos_lnum then + (* everything in the same line, so really only read this small part*) + (p1.Lexing.pos_cnum, p2.Lexing.pos_cnum, None) + else (*multiline, so start reading at beginning of line *) + (p1.Lexing.pos_bol, p2.Lexing.pos_cnum, Some (p1.Lexing.pos_cnum - p1.Lexing.pos_bol)) in + + let ic = open_in p1.Lexing.pos_fname in + let _ = seek_in ic s in + let l = (e - s) in + let buf = Bytes.create l in + let _ = input ic buf 0 l in + let _ = match multi with None -> () | Some sk -> Bytes.fill buf 0 sk ' ' in + let _ = close_in ic in + (buf, not (multi = None)) + +(* Destruct a location by splitting all the Internal strings except possibly the + last one into a string list and keeping only the last location *) +let dest_loc (l : Parse_ast.l) : (Parse_ast.l * string list) = + let rec aux acc l = match l with + | Parse_ast.Int(s, Some l') -> aux (s::acc) l' + | _ -> (l, acc) + in + aux [] l + +let rec format_loc_aux ff l = + let (l_org, mod_s) = dest_loc l in + let _ = match l_org with + | Parse_ast.Unknown -> Format.fprintf ff "no location information available" + | Parse_ast.Generated l -> Format.fprintf ff "code generated: original nearby source is "; (format_loc_aux ff l) + | Parse_ast.Range(p1,p2) -> format_pos2 ff p1 p2 + | Parse_ast.Int(s,_) -> Format.fprintf ff "code in lib from: %s" s + | Parse_ast.Documented(_, l) -> format_loc_aux ff l + in + () + +let format_loc_source ff l = + match dest_loc l with + | (Parse_ast.Range (p1, p2), _) -> + begin + let (s, multi_line) = read_from_file_pos2 p1 p2 in + if multi_line then + Format.fprintf ff " original input:\n%s\n" (Bytes.to_string s) + else + Format.fprintf ff " original input: \"%s\"\n" (Bytes.to_string s) + end + | _ -> () + +let format_loc ff l = + (format_loc_aux ff l; + Format.pp_print_newline ff (); + Format.pp_print_flush ff () +);; + +let print_err_loc l = + (format_loc Format.err_formatter l) + +let print_pos p = format_pos Format.std_formatter p +let print_err_pos p = format_pos Format.err_formatter p + +let loc_to_string l = + let _ = Format.flush_str_formatter () in + let _ = format_loc_aux Format.str_formatter l in + let s = Format.flush_str_formatter () in + s + +type pos_or_loc = Loc of Parse_ast.l | LocD of Parse_ast.l * Parse_ast.l | Pos of Lexing.position + +let print_err_internal fatal verb_loc p_l m1 m2 = + Format.eprintf "%s at " m1; + let _ = (match p_l with Pos p -> print_err_pos p + | Loc l -> print_err_loc l + | LocD (l1,l2) -> + print_err_loc l1; Format.fprintf Format.err_formatter " and "; print_err_loc l2) in + Format.eprintf "%s\n" m2; + if verb_loc then (match p_l with Loc l -> + format_loc_source Format.err_formatter l; + Format.pp_print_newline Format.err_formatter (); | _ -> ()); + Format.pp_print_flush Format.err_formatter (); + if fatal then (exit 1) else () + +let print_err fatal verb_loc l m1 m2 = + print_err_internal fatal verb_loc (Loc l) m1 m2 + +type error = + | Err_general of Parse_ast.l * string + | Err_unreachable of Parse_ast.l * (string * int * int * int) * string + | Err_todo of Parse_ast.l * string + | Err_syntax of Lexing.position * string + | Err_syntax_locn of Parse_ast.l * string + | Err_lex of Lexing.position * string + | Err_type of Parse_ast.l * string + | Err_type_dual of Parse_ast.l * Parse_ast.l * string + +let issues = "\n\nPlease report this as an issue on GitHub at https://github.com/rems-project/sail/issues" + +let dest_err = function + | Err_general (l, m) -> ("Error", false, Loc l, m) + | Err_unreachable (l, (file, line, _, _), m) -> + ((Printf.sprintf "Internal error: Unreachable code (at \"%s\" line %d)" file line), false, Loc l, m ^ issues) + | Err_todo (l, m) -> ("Todo" ^ m, false, Loc l, "") + | Err_syntax (p, m) -> ("Syntax error", false, Pos p, m) + | Err_syntax_locn (l, m) -> ("Syntax error", false, Loc l, m) + | Err_lex (p, s) -> ("Lexical error", false, Pos p, s) + | Err_type (l, m) -> ("Type error", false, Loc l, m) + | Err_type_dual(l1,l2,m) -> ("Type error", false, LocD (l1,l2), m) + +exception Fatal_error of error + +(* Abbreviations for the very common cases *) +let err_todo l m = Fatal_error (Err_todo (l, m)) +let err_unreachable l ocaml_pos m = Fatal_error (Err_unreachable (l, ocaml_pos, m)) +let err_general l m = Fatal_error (Err_general (l, m)) +let err_typ l m = Fatal_error (Err_type (l,m)) +let err_typ_dual l1 l2 m = Fatal_error (Err_type_dual (l1,l2,m)) + +let report_error e = + let (m1, verb_pos, pos_l, m2) = dest_err e in + (print_err_internal verb_pos false pos_l m1 m2; exit 1) + +let print_error e = + let (m1, verb_pos, pos_l, m2) = dest_err e in + print_err_internal verb_pos false pos_l m1 m2 diff --git a/src/reporting.mli b/src/reporting.mli new file mode 100644 index 00000000..a6878d6a --- /dev/null +++ b/src/reporting.mli @@ -0,0 +1,115 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +(** Basic error reporting + + [Reporting] contains functions to report errors and warnings. + It contains functions to print locations ([Parse_ast.l] and [Ast.l]) and lexing positions. + + The main functionality is reporting errors. This is done by raising a + [Fatal_error] exception. This is caught internally and reported via [report_error]. + There are several predefined types of errors which all cause different error + messages. If none of these fit, [Err_general] can be used. + +*) + +(** {2 Auxiliary Functions } *) + +val loc_to_string : Parse_ast.l -> string + +(** [print_err fatal print_loc_source l head mes] prints an error / warning message to + std-err. It starts with printing location information stored in [l] + It then prints "head: mes". If [fatal] is set, the program exists with error-code 1 afterwards. +*) +val print_err : bool -> bool -> Parse_ast.l -> string -> string -> unit + +(** {2 Errors } *) + +(** Errors stop execution and print a message; they typically have a location and message. +*) +type error = + (** General errors, used for multi purpose. If you are unsure, use this one. *) + | Err_general of Parse_ast.l * string + + (** Unreachable errors should never be thrown. It means that some + code was excuted that the programmer thought of as unreachable *) + | Err_unreachable of Parse_ast.l * (string * int * int * int) * string + + (** [Err_todo] indicates that some feature is unimplemented; it should be built using [err_todo]. *) + | Err_todo of Parse_ast.l * string + + | Err_syntax of Lexing.position * string + | Err_syntax_locn of Parse_ast.l * string + | Err_lex of Lexing.position * string + | Err_type of Parse_ast.l * string + | Err_type_dual of Parse_ast.l * Parse_ast.l * string + +exception Fatal_error of error + +(** [err_todo l m] is an abreviatiation for [Fatal_error (Err_todo (l, m))] *) +val err_todo : Parse_ast.l -> string -> exn + +(** [err_general l m] is an abreviatiation for [Fatal_error (Err_general (b, l, m))] *) +val err_general : Parse_ast.l -> string -> exn + +(** [err_unreachable l __POS__ m] is an abreviatiation for [Fatal_error (Err_unreachable (l, __POS__, m))] *) +val err_unreachable : Parse_ast.l -> (string * int * int * int) -> string -> exn + +(** [err_typ l m] is an abreviatiation for [Fatal_error (Err_type (l, m))] *) +val err_typ : Parse_ast.l -> string -> exn + +(** [err_typ_dual l1 l2 m] is an abreviatiation for [Fatal_error (Err_type_dual (l1, l2, m))] *) +val err_typ_dual : Parse_ast.l -> Parse_ast.l -> string -> exn + +(** Report error should only be used by main to print the error in the end. Everywhere else, + raising a [Fatal_error] exception is recommended. *) +val report_error : error -> 'a + +val print_error : error -> unit diff --git a/src/reporting_basic.ml b/src/reporting_basic.ml deleted file mode 100644 index a90c2bcd..00000000 --- a/src/reporting_basic.ml +++ /dev/null @@ -1,293 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(**************************************************************************) - - -(**************************************************************************) -(* Lem *) -(* *) -(* Dominic Mulligan, University of Cambridge *) -(* Francesco Zappa Nardelli, INRIA Paris-Rocquencourt *) -(* Gabriel Kerneis, University of Cambridge *) -(* Kathy Gray, University of Cambridge *) -(* Peter Boehm, University of Cambridge (while working on Lem) *) -(* Peter Sewell, University of Cambridge *) -(* Scott Owens, University of Kent *) -(* Thomas Tuerk, University of Cambridge *) -(* *) -(* The Lem sources are copyright 2010-2013 *) -(* by the UK authors above and Institut National de Recherche en *) -(* Informatique et en Automatique (INRIA). *) -(* *) -(* All files except ocaml-lib/pmap.{ml,mli} and ocaml-libpset.{ml,mli} *) -(* are distributed under the license below. The former are distributed *) -(* under the LGPLv2, as in the LICENSE file. *) -(* *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in the *) -(* documentation and/or other materials provided with the distribution. *) -(* 3. The names of the authors may not be used to endorse or promote *) -(* products derived from this software without specific prior written *) -(* permission. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS *) -(* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED *) -(* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE *) -(* ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY *) -(* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL *) -(* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE *) -(* GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS *) -(* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER *) -(* IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR *) -(* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN *) -(* IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) -(**************************************************************************) - -let rec skip_lines in_chan = function - | n when n <= 0 -> () - | n -> ignore (input_line in_chan); skip_lines in_chan (n - 1) - -let rec read_lines in_chan = function - | n when n <= 0 -> [] - | n -> - let l = input_line in_chan in - let ls = read_lines in_chan (n - 1) in - l :: ls - -let termcode n = "\x1B[" ^ string_of_int n ^ "m" - -let print_code1 ff fname lnum1 cnum1 cnum2 = - try - let in_chan = open_in fname in - begin - try - skip_lines in_chan (lnum1 - 1); - let line = input_line in_chan in - Format.fprintf ff "%s%s%s" - (Str.string_before line cnum1) - Util.(Str.string_before (Str.string_after line cnum1) (cnum2 - cnum1) |> red_bg |> clear) - (Str.string_after line cnum2); - close_in in_chan - with e -> (close_in_noerr in_chan; - prerr_endline (Printf.sprintf "print_code1: %s %d %d %d %s" fname lnum1 cnum1 cnum2 (Printexc.to_string e))) - end - with _ -> () - -let format_pos ff p = - let open Lexing in - begin - Format.fprintf ff "file \"%s\", line %d, character %d:\n\n" - p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol); - print_code1 ff p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol) (p.pos_cnum - p.pos_bol + 1); - Format.fprintf ff "\n\n"; - Format.pp_print_flush ff () - end - -let print_code2 ff fname lnum1 cnum1 lnum2 cnum2 = - try - let in_chan = open_in fname in - begin - try - skip_lines in_chan (lnum1 - 1); - let line = input_line in_chan in - Format.fprintf ff "%s%s\n" - (Str.string_before line cnum1) - Util.(Str.string_after line cnum1 |> red_bg |> clear); - let lines = read_lines in_chan (lnum2 - lnum1 - 1) in - List.iter (fun l -> Format.fprintf ff "%s\n" Util.(l |> red_bg |> clear)) lines; - let line = input_line in_chan in - Format.fprintf ff "%s%s" - Util.(Str.string_before line cnum2 |> red_bg |> clear) - (Str.string_after line cnum2); - close_in in_chan - with e -> (close_in_noerr in_chan; prerr_endline (Printexc.to_string e)) - end - with _ -> () - -let format_pos2 ff p1 p2 = - let open Lexing in - begin - Format.fprintf ff "file \"%s\", line %d, character %d to line %d, character %d\n\n" - p1.pos_fname - p1.pos_lnum (p1.pos_cnum - p1.pos_bol + 1) - p2.pos_lnum (p2.pos_cnum - p2.pos_bol); - if p1.pos_lnum == p2.pos_lnum - then print_code1 ff p1.pos_fname p1.pos_lnum (p1.pos_cnum - p1.pos_bol) (p2.pos_cnum - p2.pos_bol) - else print_code2 ff p1.pos_fname p1.pos_lnum (p1.pos_cnum - p1.pos_bol) p2.pos_lnum (p2.pos_cnum - p2.pos_bol); - Format.pp_print_flush ff () - end - -(* reads the part between p1 and p2 from the file *) - -let read_from_file_pos2 p1 p2 = - let (s, e, multi) = if p1.Lexing.pos_lnum = p2.Lexing.pos_lnum then - (* everything in the same line, so really only read this small part*) - (p1.Lexing.pos_cnum, p2.Lexing.pos_cnum, None) - else (*multiline, so start reading at beginning of line *) - (p1.Lexing.pos_bol, p2.Lexing.pos_cnum, Some (p1.Lexing.pos_cnum - p1.Lexing.pos_bol)) in - - let ic = open_in p1.Lexing.pos_fname in - let _ = seek_in ic s in - let l = (e - s) in - let buf = Bytes.create l in - let _ = input ic buf 0 l in - let _ = match multi with None -> () | Some sk -> Bytes.fill buf 0 sk ' ' in - let _ = close_in ic in - (buf, not (multi = None)) - -(* Destruct a location by splitting all the Internal strings except possibly the - last one into a string list and keeping only the last location *) -let dest_loc (l : Parse_ast.l) : (Parse_ast.l * string list) = - let rec aux acc l = match l with - | Parse_ast.Int(s, Some l') -> aux (s::acc) l' - | _ -> (l, acc) - in - aux [] l - -let rec format_loc_aux ff l = - let (l_org, mod_s) = dest_loc l in - let _ = match l_org with - | Parse_ast.Unknown -> Format.fprintf ff "no location information available" - | Parse_ast.Generated l -> Format.fprintf ff "code generated: original nearby source is "; (format_loc_aux ff l) - | Parse_ast.Range(p1,p2) -> format_pos2 ff p1 p2 - | Parse_ast.Int(s,_) -> Format.fprintf ff "code in lib from: %s" s - | Parse_ast.Documented(_, l) -> format_loc_aux ff l - in - () - -let format_loc_source ff l = - match dest_loc l with - | (Parse_ast.Range (p1, p2), _) -> - begin - let (s, multi_line) = read_from_file_pos2 p1 p2 in - if multi_line then - Format.fprintf ff " original input:\n%s\n" (Bytes.to_string s) - else - Format.fprintf ff " original input: \"%s\"\n" (Bytes.to_string s) - end - | _ -> () - -let format_loc ff l = - (format_loc_aux ff l; - Format.pp_print_newline ff (); - Format.pp_print_flush ff () -);; - -let print_err_loc l = - (format_loc Format.err_formatter l) - -let print_pos p = format_pos Format.std_formatter p -let print_err_pos p = format_pos Format.err_formatter p - -let loc_to_string l = - let _ = Format.flush_str_formatter () in - let _ = format_loc_aux Format.str_formatter l in - let s = Format.flush_str_formatter () in - s - -type pos_or_loc = Loc of Parse_ast.l | LocD of Parse_ast.l * Parse_ast.l | Pos of Lexing.position - -let print_err_internal fatal verb_loc p_l m1 m2 = - Format.eprintf "%s at " m1; - let _ = (match p_l with Pos p -> print_err_pos p - | Loc l -> print_err_loc l - | LocD (l1,l2) -> - print_err_loc l1; Format.fprintf Format.err_formatter " and "; print_err_loc l2) in - Format.eprintf "%s\n" m2; - if verb_loc then (match p_l with Loc l -> - format_loc_source Format.err_formatter l; - Format.pp_print_newline Format.err_formatter (); | _ -> ()); - Format.pp_print_flush Format.err_formatter (); - if fatal then (exit 1) else () - -let print_err fatal verb_loc l m1 m2 = - print_err_internal fatal verb_loc (Loc l) m1 m2 - -type error = - | Err_general of Parse_ast.l * string - | Err_unreachable of Parse_ast.l * (string * int * int * int) * string - | Err_todo of Parse_ast.l * string - | Err_syntax of Lexing.position * string - | Err_syntax_locn of Parse_ast.l * string - | Err_lex of Lexing.position * string - | Err_type of Parse_ast.l * string - | Err_type_dual of Parse_ast.l * Parse_ast.l * string - -let dest_err = function - | Err_general (l, m) -> ("Error", false, Loc l, m) - | Err_unreachable (l, (file, line, _, _), m) -> ((Printf.sprintf "Internal error: Unreachable code (at \"%s\" line %d)" file line), false, Loc l, m) - | Err_todo (l, m) -> ("Todo" ^ m, false, Loc l, "") - | Err_syntax (p, m) -> ("Syntax error", false, Pos p, m) - | Err_syntax_locn (l, m) -> ("Syntax error", false, Loc l, m) - | Err_lex (p, s) -> ("Lexical error", false, Pos p, s) - | Err_type (l, m) -> ("Type error", false, Loc l, m) - | Err_type_dual(l1,l2,m) -> ("Type error", false, LocD (l1,l2), m) - -exception Fatal_error of error - -(* Abbreviations for the very common cases *) -let err_todo l m = Fatal_error (Err_todo (l, m)) -let err_unreachable l ocaml_pos m = Fatal_error (Err_unreachable (l, ocaml_pos, m)) -let err_general l m = Fatal_error (Err_general (l, m)) -let err_typ l m = Fatal_error (Err_type (l,m)) -let err_typ_dual l1 l2 m = Fatal_error (Err_type_dual (l1,l2,m)) - -let report_error e = - let (m1, verb_pos, pos_l, m2) = dest_err e in - (print_err_internal verb_pos false pos_l m1 m2; exit 1) - -let print_error e = - let (m1, verb_pos, pos_l, m2) = dest_err e in - print_err_internal verb_pos false pos_l m1 m2 diff --git a/src/reporting_basic.mli b/src/reporting_basic.mli deleted file mode 100644 index 39ac32f0..00000000 --- a/src/reporting_basic.mli +++ /dev/null @@ -1,115 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(**************************************************************************) - -(** Basic error reporting - - [Reporting_basic] contains functions to report errors and warnings. - It contains functions to print locations ([Parse_ast.l] and [Ast.l]) and lexing positions. - - The main functionality is reporting errors. This is done by raising a - [Fatal_error] exception. This is caught internally and reported via [report_error]. - There are several predefined types of errors which all cause different error - messages. If none of these fit, [Err_general] can be used. - -*) - -(** {2 Auxiliary Functions } *) - -val loc_to_string : Parse_ast.l -> string - -(** [print_err fatal print_loc_source l head mes] prints an error / warning message to - std-err. It starts with printing location information stored in [l] - It then prints "head: mes". If [fatal] is set, the program exists with error-code 1 afterwards. -*) -val print_err : bool -> bool -> Parse_ast.l -> string -> string -> unit - -(** {2 Errors } *) - -(** Errors stop execution and print a message; they typically have a location and message. -*) -type error = - (** General errors, used for multi purpose. If you are unsure, use this one. *) - | Err_general of Parse_ast.l * string - - (** Unreachable errors should never be thrown. It means that some - code was excuted that the programmer thought of as unreachable *) - | Err_unreachable of Parse_ast.l * (string * int * int * int) * string - - (** [Err_todo] indicates that some feature is unimplemented; it should be built using [err_todo]. *) - | Err_todo of Parse_ast.l * string - - | Err_syntax of Lexing.position * string - | Err_syntax_locn of Parse_ast.l * string - | Err_lex of Lexing.position * string - | Err_type of Parse_ast.l * string - | Err_type_dual of Parse_ast.l * Parse_ast.l * string - -exception Fatal_error of error - -(** [err_todo l m] is an abreviatiation for [Fatal_error (Err_todo (l, m))] *) -val err_todo : Parse_ast.l -> string -> exn - -(** [err_general l m] is an abreviatiation for [Fatal_error (Err_general (b, l, m))] *) -val err_general : Parse_ast.l -> string -> exn - -(** [err_unreachable l __POS__ m] is an abreviatiation for [Fatal_error (Err_unreachable (l, __POS__, m))] *) -val err_unreachable : Parse_ast.l -> (string * int * int * int) -> string -> exn - -(** [err_typ l m] is an abreviatiation for [Fatal_error (Err_type (l, m))] *) -val err_typ : Parse_ast.l -> string -> exn - -(** [err_typ_dual l1 l2 m] is an abreviatiation for [Fatal_error (Err_type_dual (l1, l2, m))] *) -val err_typ_dual : Parse_ast.l -> Parse_ast.l -> string -> exn - -(** Report error should only be used by main to print the error in the end. Everywhere else, - raising a [Fatal_error] exception is recommended. *) -val report_error : error -> 'a - -val print_error : error -> unit diff --git a/src/rewriter.ml b/src/rewriter.ml index 3eb0ffe6..cf04eef4 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -319,8 +319,8 @@ let rewrite_exp rewriters (E_aux (exp,(l,annot)) as orig_exp) = | E_assert(e1,e2) -> rewrap (E_assert(rewrite e1,rewrite e2)) | E_var (lexp, e1, e2) -> rewrap (E_var (rewriters.rewrite_lexp rewriters lexp, rewriters.rewrite_exp rewriters e1, rewriters.rewrite_exp rewriters e2)) - | E_internal_return _ -> raise (Reporting_basic.err_unreachable l __POS__ "Internal return found before it should have been introduced") - | E_internal_plet _ -> raise (Reporting_basic.err_unreachable l __POS__ " Internal plet found before it should have been introduced") + | E_internal_return _ -> raise (Reporting.err_unreachable l __POS__ "Internal return found before it should have been introduced") + | E_internal_plet _ -> raise (Reporting.err_unreachable l __POS__ " Internal plet found before it should have been introduced") | _ -> rewrap exp let rewrite_let rewriters (LB_aux(letbind,(l,annot))) = @@ -358,7 +358,7 @@ let rewrite_def rewriters d = match d with | DEF_fundef fdef -> DEF_fundef (rewriters.rewrite_fun rewriters fdef) | DEF_internal_mutrec fdefs -> DEF_internal_mutrec (List.map (rewriters.rewrite_fun rewriters) fdefs) | DEF_val letbind -> DEF_val (rewriters.rewrite_let rewriters letbind) - | DEF_scattered _ -> raise (Reporting_basic.err_unreachable Parse_ast.Unknown __POS__ "DEF_scattered survived to rewritter") + | DEF_scattered _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "DEF_scattered survived to rewritter") let rewrite_defs_base rewriters (Defs defs) = let rec rewrite ds = match ds with diff --git a/src/rewrites.ml b/src/rewrites.ml index 313d30e5..25d1467f 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -169,16 +169,16 @@ let vector_string_to_bit_list l lit = | 'D' -> ['1';'1';'0';'1'] | 'E' -> ['1';'1';'1';'0'] | 'F' -> ['1';'1';'1';'1'] - | _ -> raise (Reporting_basic.err_unreachable l __POS__ "hexchar_to_binlist given unrecognized character") in + | _ -> raise (Reporting.err_unreachable l __POS__ "hexchar_to_binlist given unrecognized character") in let s_bin = match lit with | L_hex s_hex -> List.flatten (List.map hexchar_to_binlist (explode (String.uppercase_ascii s_hex))) | L_bin s_bin -> explode s_bin - | _ -> raise (Reporting_basic.err_unreachable l __POS__ "s_bin given non vector literal") in + | _ -> raise (Reporting.err_unreachable l __POS__ "s_bin given non vector literal") in List.map (function '0' -> L_aux (L_zero, gen_loc l) | '1' -> L_aux (L_one, gen_loc l) - | _ -> raise (Reporting_basic.err_unreachable (gen_loc l) __POS__ "binary had non-zero or one")) s_bin + | _ -> raise (Reporting.err_unreachable (gen_loc l) __POS__ "binary had non-zero or one")) s_bin let find_used_vars exp = (* Overapproximates the set of used identifiers, but for the use cases below @@ -461,7 +461,7 @@ let rewrite_sizeof (Defs defs) = let inst = try instantiation_of orig_exp with | Type_error (l, err) -> - raise (Reporting_basic.err_typ l (Type_error.string_of_type_error err)) in + raise (Reporting.err_typ l (Type_error.string_of_type_error err)) in (* Rewrite the inst using orig_kid so that each type variable has it's original name rather than a mangled typechecker name *) let inst = KBindings.fold (fun kid uvar b -> KBindings.add (orig_kid kid) uvar b) inst KBindings.empty in @@ -474,13 +474,13 @@ let rewrite_sizeof (Defs defs) = let sizeof = E_aux (E_sizeof nexp, (l, mk_tannot env (atom_typ nexp) no_effect)) in (try rewrite_trivial_sizeof_exp sizeof with | Type_error (l, err) -> - raise (Reporting_basic.err_typ l (Type_error.string_of_type_error err))) + raise (Reporting.err_typ l (Type_error.string_of_type_error err))) (* If the type variable is Not_found then it was probably introduced by a P_var pattern, so it likely exists as a variable in scope. It can't be an existential because the assert rules that out. *) | None -> annot_exp (E_id (id_of_kid (orig_kid kid))) l env (atom_typ (nvar (orig_kid kid))) | _ -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ ("failed to infer nexp for type variable " ^ string_of_kid kid ^ " of function " ^ string_of_id f)) end in @@ -605,10 +605,10 @@ let rewrite_sizeof (Defs defs) = | P_as (_, id) | P_id id -> (* adding parameters here would change the type of id; we should remove the P_as/P_id here and add a let-binding to the body *) - raise (Reporting_basic.err_todo l + raise (Reporting.err_todo l "rewriting as- or id-patterns for sizeof expressions not yet implemented") | _ -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "unexpected pattern while rewriting function parameters for sizeof expressions")) | ptyp -> let ptyp' = Typ_aux (Typ_tup (kid_typs @ [ptyp]), l) in @@ -661,7 +661,7 @@ let rewrite_sizeof (Defs defs) = | Typ_aux (Typ_fn (vtyp_args, vtyp_ret, declared_eff), vl) -> Typ_aux (Typ_fn (kid_typs @ vtyp_args, vtyp_ret, declared_eff), vl) | _ -> - raise (Reporting_basic.err_typ l "val spec with non-function type") in + raise (Reporting.err_typ l "val spec with non-function type") in TypSchm_aux (TypSchm_ts (tq, typ'), l) else ts in match def with @@ -758,7 +758,7 @@ let remove_vector_concat_pat pat = P_aux (P_app (id, List.map aux pats), a) | _ -> raise - (Reporting_basic.err_unreachable + (Reporting.err_unreachable l __POS__ "name_vector_concat_elements: Non-vector in vector-concat pattern") in P_vector_concat (List.map aux pats) in {id_pat_alg with p_vector_concat = p_vector_concat} in @@ -806,7 +806,7 @@ let remove_vector_concat_pat pat = then Big_int.sub (Big_int.add start length) (Big_int.of_int 1) else Big_int.add (Big_int.sub start length) (Big_int.of_int 1)) | _ -> - raise (Reporting_basic.err_unreachable (fst rannot') __POS__ + raise (Reporting.err_unreachable (fst rannot') __POS__ ("unname_vector_concat_elements: vector of unspecified length in vector-concat pattern"))) in let rec aux typ_opt (pos,pat_acc,decl_acc) (P_aux (p,cannot),is_last) = let ctyp = Env.base_typ_of (env_of_annot cannot) (typ_of_annot cannot) in @@ -820,7 +820,7 @@ let remove_vector_concat_pat pat = if is_last then (pos,last_idx) else raise - (Reporting_basic.err_unreachable + (Reporting.err_unreachable l __POS__ ("unname_vector_concat_elements: vector of unspecified length in vector-concat pattern")) in (match p with (* if we see a named vector pattern, remove the name and remember to @@ -930,7 +930,7 @@ let remove_vector_concat_pat pat = | _, _ -> (*if is_last then*) acc @ [wild Big_int.zero] else raise - (Reporting_basic.err_unreachable l __POS__ + (Reporting.err_unreachable l __POS__ ("remove_vector_concats: Non-vector in vector-concat pattern " ^ string_of_typ (typ_of_annot annot))) in @@ -1160,7 +1160,7 @@ let rec pat_to_exp ((P_aux (pat,(l,annot))) as p_aux) = let typ = typ_of_pat p_aux in match pat with | P_lit lit -> rewrap (E_lit lit) - | P_wild -> raise (Reporting_basic.err_unreachable l __POS__ + | P_wild -> raise (Reporting.err_unreachable l __POS__ "pat_to_exp given wildcard pattern") | P_or(pat1, pat2) -> (* todo: insert boolean or *) pat_to_exp pat1 | P_not(pat) -> (* todo: insert boolean not *) pat_to_exp pat @@ -1248,7 +1248,7 @@ let rewrite_guarded_clauses l cs = | ((pat,guard,body,annot) as c) :: cs -> group_aux (remove_wildcards "g__" pat, [c], annot) [] cs | _ -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "group given empty list in rewrite_guarded_clauses") in let add_group cs groups = (if_pexp (groups @ fallthrough) cs) :: groups in List.fold_right add_group groups [] @@ -1260,7 +1260,7 @@ let rewrite_guarded_clauses l cs = let (Pat_aux (_,annot)) = pexp in (pat, body, annot) | [] -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "if_pexp given empty list in rewrite_guarded_clauses")) and if_exp fallthrough current_pat = (function | (pat,guard,body,annot) :: ((pat',guard',body',annot') as c') :: cs -> @@ -1284,7 +1284,7 @@ let rewrite_guarded_clauses l cs = fix_eff_exp (annot_exp (E_if (exp,body,else_exp)) (fst annot) (env_of exp) (typ_of body)) | _, _ -> body) | [] -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "if_exp given empty list in rewrite_guarded_clauses")) in group [] cs @@ -1419,7 +1419,7 @@ let remove_bitvector_pat (P_aux (_, (l, _)) as pat) = let start_idx = match start with | Nexp_aux (Nexp_constant s, _) -> s | _ -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "guard_bitvector_pat called on pattern with non-constant start index") in let add_bit_pat (idx, current, guards, dls) pat = let idx' = @@ -1727,9 +1727,9 @@ let rec rewrite_lexp_to_rhs ((LEXP_aux(lexp,((l,_) as annot))) as le) = | Typ_aux (Typ_id rectyp_id, _) | Typ_aux (Typ_app (rectyp_id, _), _) when Env.is_record rectyp_id env -> let field_update exp = FES_aux (FES_Fexps ([FE_aux (FE_Fexp (id, exp), annot)], false), annot) in (lhs, (fun exp -> rhs (E_aux (E_record_update (lexp_to_exp lexp, field_update exp), lannot)))) - | _ -> raise (Reporting_basic.err_unreachable l __POS__ ("Unsupported lexp: " ^ string_of_lexp le)) + | _ -> raise (Reporting.err_unreachable l __POS__ ("Unsupported lexp: " ^ string_of_lexp le)) end - | _ -> raise (Reporting_basic.err_unreachable l __POS__ ("Unsupported lexp: " ^ string_of_lexp le)) + | _ -> raise (Reporting.err_unreachable l __POS__ ("Unsupported lexp: " ^ string_of_lexp le)) let updates_vars exp = let e_assign ((_, lexp), (u, exp)) = @@ -2093,7 +2093,7 @@ let rewrite_defs_early_return (Defs defs) = let swaptyp typ (l,tannot) = match destruct_tannot tannot with | Some (env, typ', eff) -> (l, mk_tannot env typ eff) - | _ -> raise (Reporting_basic.err_unreachable l __POS__ "swaptyp called with empty type annotation") + | _ -> raise (Reporting.err_unreachable l __POS__ "swaptyp called with empty type annotation") let is_funcl_rec (FCL_aux (FCL_Funcl (id, pexp), _)) = let pat,guard,exp,pannot = destruct_pexp pexp in @@ -2174,7 +2174,7 @@ let rewrite_split_fun_constr_pats fun_name (Defs defs) = let pat, _, exp, _ = destruct_pexp pexp in env_of exp, typ_of_pat pat, typ_of exp | _ -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "rewrite_split_fun_constr_pats: empty auxiliary function") in let eff = List.fold_left @@ -2242,7 +2242,7 @@ let rewrite_fix_val_specs (Defs defs) = begin try Env.get_val_spec id env with | _ -> - raise (Reporting_basic.err_unreachable (Parse_ast.Unknown) __POS__ + raise (Reporting.err_unreachable (Parse_ast.Unknown) __POS__ ("No val spec found for " ^ string_of_id id)) end in @@ -2570,7 +2570,7 @@ let rewrite_vector_concat_assignments defs = begin try check_exp env e_aux unit_typ with | Type_error (l, err) -> - raise (Reporting_basic.err_typ l (Type_error.string_of_type_error err)) + raise (Reporting.err_typ l (Type_error.string_of_type_error err)) end else E_aux (e_aux, annot) | _ -> E_aux (e_aux, annot) @@ -2596,7 +2596,7 @@ let rewrite_tuple_assignments defs = begin try check_exp env let_exp unit_typ with | Type_error (l, err) -> - raise (Reporting_basic.err_typ l (Type_error.string_of_type_error err)) + raise (Reporting.err_typ l (Type_error.string_of_type_error err)) end | _ -> E_aux (e_aux, annot) in @@ -2672,7 +2672,7 @@ let letbind (v : 'a exp) (body : 'a exp -> 'a exp) : 'a exp = let body = body (annot_exp (E_id id) l env typ) in fix_eff_exp (annot_exp (E_let (lb, body)) l env (typ_of body)) | None -> - raise (Reporting_basic.err_unreachable l __POS__ "no type information") + raise (Reporting.err_unreachable l __POS__ "no type information") let rec mapCont (f : 'b -> ('b -> 'a exp) -> 'a exp) (l : 'b list) (k : 'b list -> 'a exp) : 'a exp = @@ -2968,7 +2968,7 @@ let rewrite_defs_internal_lets = | LEXP_id id -> P_aux (P_id id, annot) | LEXP_cast (typ, id) -> add_p_typ typ (P_aux (P_id id, annot)) | LEXP_tup lexps -> P_aux (P_tup (List.map pat_of_local_lexp lexps), annot) - | _ -> raise (Reporting_basic.err_unreachable l __POS__ "unexpected local lexp") in + | _ -> raise (Reporting.err_unreachable l __POS__ "unexpected local lexp") in let e_let (lb,body) = match lb with @@ -3834,7 +3834,7 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = let ord_exp, kids, constr, lower, upper, lower_exp, upper_exp = match destruct_numeric env (typ_of exp1), destruct_numeric env (typ_of exp2) with | None, _ | _, None -> - raise (Reporting_basic.err_unreachable el __POS__ "Could not determine loop bounds") + raise (Reporting.err_unreachable el __POS__ "Could not determine loop bounds") | Some (kids1, constr1, n1), Some (kids2, constr2, n2) -> let kids = kids1 @ kids2 in let constr = nc_and constr1 constr2 in @@ -3940,7 +3940,7 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = let pannot = (l, mk_tannot (env_of exp) (typ_of exp) (effect_of exp)) in Pat_aux (Pat_exp (pat, exp), pannot) | Pat_when _ -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "Guarded patterns should have been rewritten already") in let ps = List.map rewrite_pexp ps in let expaux = if is_case then E_case (e1, ps) else E_try (e1, ps) in @@ -3954,7 +3954,7 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = | Local (_, typ) -> add_p_typ typ (annot_pat (P_id id) pl env typ) | _ -> - raise (Reporting_basic.err_unreachable pl __POS__ + raise (Reporting.err_unreachable pl __POS__ ("Failed to look up type of variable " ^ string_of_id id)) in if effectful exp then Same_vars (E_aux (E_assign (lexp,vexp),annot)) @@ -4000,7 +4000,7 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = | LEXP_aux (LEXP_cast (typ, id), _) -> unaux_pat (add_p_typ typ (annot_pat (P_id id) l env (typ_of v))), typ | _ -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "E_var with a lexp that is not a variable") in let lb = fix_eff_lb (annot_letbind (paux, v) l env typ) in let exp = fix_eff_exp (annot_exp (E_let (lb, body)) l env (typ_of body)) in @@ -4553,7 +4553,7 @@ let rec remove_clause_from_pattern ctx (P_aux (rm_pat,ann)) res_pat = in aux [] res_pats res_pats' in let inconsistent () = - raise (Reporting_basic.err_unreachable (fst ann) __POS__ + raise (Reporting.err_unreachable (fst ann) __POS__ ("Inconsistency during exhaustiveness analysis with " ^ string_of_rp res_pat)) in @@ -4637,12 +4637,12 @@ let rec remove_clause_from_pattern ctx (P_aux (rm_pat,ann)) res_pat = rp' @ List.map (function [rp1;rp2] -> RP_cons (rp1,rp2) | _ -> assert false) res_pats end | P_record _ -> - raise (Reporting_basic.err_unreachable (fst ann) __POS__ + raise (Reporting.err_unreachable (fst ann) __POS__ "Record pattern not supported") | P_vector _ | P_vector_concat _ | P_string_append _ -> - raise (Reporting_basic.err_unreachable (fst ann) __POS__ + raise (Reporting.err_unreachable (fst ann) __POS__ "Found pattern that should have been rewritten away in earlier stage") (*in let _ = printprefix := String.sub (!printprefix) 0 (String.length !printprefix - 2) @@ -4658,7 +4658,7 @@ let process_pexp env = | Pat_aux (Pat_exp (p,_),_) -> List.concat (List.map (remove_clause_from_pattern ctx p) rps) | Pat_aux (Pat_when _,(l,_)) -> - raise (Reporting_basic.err_unreachable l __POS__ + raise (Reporting.err_unreachable l __POS__ "Guarded pattern should have been rewritten away") (* We do some minimal redundancy checking to remove bogus wildcard patterns here *) @@ -4666,7 +4666,7 @@ let check_cases process is_wild loc_of cases = let rec aux rps acc = function | [] -> acc, rps | [p] when is_wild p && match rps with [] -> true | _ -> false -> - let () = Reporting_basic.print_err false false + let () = Reporting.print_err false false (loc_of p) "Match checking" "Redundant wildcard clause" in acc, [] | h::t -> aux (process rps h) (h::acc) t @@ -4706,7 +4706,7 @@ let rewrite_case (e,ann) = let _ = if !opt_coq_warn_nonexhaustive - then Reporting_basic.print_err false false + then Reporting.print_err false false (fst ann) "Non-exhaustive matching" ("Example: " ^ string_of_rp example) in let l = Parse_ast.Generated Parse_ast.Unknown in @@ -4726,7 +4726,7 @@ let rewrite_case (e,ann) = | (example::_) -> let _ = if !opt_coq_warn_nonexhaustive - then Reporting_basic.print_err false false + then Reporting.print_err false false (fst ann) "Non-exhaustive let" ("Example: " ^ string_of_rp example) in let l = Parse_ast.Generated Parse_ast.Unknown in let p = P_aux (P_wild, (l, empty_tannot)) in @@ -4742,7 +4742,7 @@ let rewrite_fun rewriters (FD_aux (FD_function (r,t,e,fcls),f_ann)) = let id,fcl_ann = match fcls with | FCL_aux (FCL_Funcl (id,_),ann) :: _ -> id,ann - | [] -> raise (Reporting_basic.err_unreachable (fst f_ann) __POS__ + | [] -> raise (Reporting.err_unreachable (fst f_ann) __POS__ "Empty function") in let env = env_of_annot fcl_ann in @@ -4756,7 +4756,7 @@ let rewrite_fun rewriters (FD_aux (FD_function (r,t,e,fcls),f_ann)) = | (example::_) -> let _ = if !opt_coq_warn_nonexhaustive - then Reporting_basic.print_err false false + then Reporting.print_err false false (fst f_ann) "Non-exhaustive matching" ("Example: " ^ string_of_rp example) in let l = Parse_ast.Generated Parse_ast.Unknown in @@ -5021,12 +5021,12 @@ let rewrite_check_annot = let typ1 = typ_of exp in let typ2 = Env.expand_synonyms (env_of exp) (typ_of exp) in (if not (alpha_equivalent (env_of exp) typ1 typ2) - then raise (Reporting_basic.err_typ Parse_ast.Unknown + then raise (Reporting.err_typ Parse_ast.Unknown ("Found synonym in annotation " ^ string_of_typ typ1 ^ " vs " ^ string_of_typ typ2)) else ()); exp with - Type_error (l, err) -> raise (Reporting_basic.err_typ l (Type_error.string_of_type_error err)) + Type_error (l, err) -> raise (Reporting.err_typ l (Type_error.string_of_type_error err)) in let check_pat pat = prerr_endline ("CHECKING PAT: " ^ string_of_pat pat ^ " : " ^ string_of_typ (typ_of_pat pat)); diff --git a/src/sail.ml b/src/sail.ml index c1c965fe..4fd35902 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -373,6 +373,6 @@ let main() = let _ = try begin try ignore(main ()) - with Failure(s) -> raise (Reporting_basic.err_general Parse_ast.Unknown ("Failure "^s)) + with Failure(s) -> raise (Reporting.err_general Parse_ast.Unknown ("Failure "^s)) end - with Reporting_basic.Fatal_error e -> Reporting_basic.report_error e + with Reporting.Fatal_error e -> Reporting.report_error e diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index 56c488ff..fd43de16 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -598,7 +598,7 @@ let def_of_component graph defset comp = | DEF_fundef fundef -> [fundef] | DEF_internal_mutrec fundefs -> fundefs | _ -> - raise (Reporting_basic.err_unreachable (def_loc def) __POS__ + raise (Reporting.err_unreachable (def_loc def) __POS__ "Trying to merge non-function definition with mutually recursive functions") in let fundefs = List.concat (List.map get_fundefs defs) in print_dot graph (List.map (fun fd -> string_of_id (id_of_fundef fd)) fundefs); diff --git a/src/state.ml b/src/state.ml index 70e53a52..31f5c7eb 100644 --- a/src/state.ml +++ b/src/state.ml @@ -187,12 +187,12 @@ let rec regval_constr_id mwords (Typ_aux (t, l) as typ) = match t with | Typ_arg_order (Ord_aux (Ord_inc, _)) -> "inc" | Typ_arg_order (Ord_aux (Ord_dec, _)) -> "dec" | _ -> - raise (Reporting_basic.err_typ l "Unsupported register type") + raise (Reporting.err_typ l "Unsupported register type") in let builtins = IdSet.of_list (List.map mk_id ["vector"; "list"; "option"]) in if IdSet.mem id builtins && not (mwords && is_bitvector_typ typ) then id else append_id id (String.concat "_" ("" :: List.map name_arg args)) - | _ -> raise (Reporting_basic.err_typ l "Unsupported register type") + | _ -> raise (Reporting.err_typ l "Unsupported register type") let register_base_types mwords typs = let rec add_base_typs typs (Typ_aux (t, _) as typ) = diff --git a/src/type_check.ml b/src/type_check.ml index 3e6ec2a3..acba67fe 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -1295,7 +1295,7 @@ let rec nc_constraint env var_of (NC_aux (nc, l)) = (List.map (fun i -> Constraint.eq (nexp_constraint env var_of (nvar kid)) (Constraint.constant i)) ints) | NC_or (nc1, nc2) -> Constraint.disj (nc_constraint env var_of nc1) (nc_constraint env var_of nc2) | NC_and (nc1, nc2) -> Constraint.conj (nc_constraint env var_of nc1) (nc_constraint env var_of nc2) - | NC_app (id, nexps) -> raise (Reporting_basic.err_unreachable l __POS__ "constraint synonym reached smt generation") + | NC_app (id, nexps) -> raise (Reporting.err_unreachable l __POS__ "constraint synonym reached smt generation") | NC_false -> Constraint.literal false | NC_true -> Constraint.literal true @@ -2026,17 +2026,17 @@ let destruct_vec_typ l env typ = let env_of_annot (l, tannot) = match tannot with | Some ((env, _, _),_) -> env - | None -> raise (Reporting_basic.err_unreachable l __POS__ "no type annotation") + | None -> raise (Reporting.err_unreachable l __POS__ "no type annotation") let env_of (E_aux (_, (l, tannot))) = env_of_annot (l, tannot) let typ_of_annot (l, tannot) = match tannot with | Some ((_, typ, _), _) -> typ - | None -> raise (Reporting_basic.err_unreachable l __POS__ "no type annotation") + | None -> raise (Reporting.err_unreachable l __POS__ "no type annotation") let env_of_annot (l, tannot) = match tannot with | Some ((env, _, _), _) -> env - | None -> raise (Reporting_basic.err_unreachable l __POS__ "no type annotation") + | None -> raise (Reporting.err_unreachable l __POS__ "no type annotation") let typ_of (E_aux (_, (l, tannot))) = typ_of_annot (l, tannot) @@ -2064,7 +2064,7 @@ let lexp_env_of (LEXP_aux (_, (l, tannot))) = env_of_annot (l, tannot) let expected_typ_of (l, tannot) = match tannot with | Some ((_, _, _), exp_typ) -> exp_typ - | None -> raise (Reporting_basic.err_unreachable l __POS__ "no type annotation") + | None -> raise (Reporting.err_unreachable l __POS__ "no type annotation") (* Flow typing *) @@ -2592,7 +2592,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) if Env.is_union_constructor v env then Util.warn (Printf.sprintf "Identifier %s found in pattern is also a union constructor at %s\n" (string_of_id v) - (Reporting_basic.loc_to_string l)) + (Reporting.loc_to_string l)) else (); match Env.lookup_id v env with | Local _ | Unbound -> annot_pat (P_id v) typ, Env.add_local v (Immutable, typ) env, [] @@ -3479,7 +3479,7 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) ( if Env.is_union_constructor v env then Util.warn (Printf.sprintf "Identifier %s found in mapping-pattern is also a union constructor at %s\n" (string_of_id v) - (Reporting_basic.loc_to_string l)) + (Reporting.loc_to_string l)) else (); match Env.lookup_id v env with | Local (Immutable, _) | Unbound -> annot_mpat (MP_id v) typ, Env.add_local v (Immutable, typ) env, [] @@ -4264,7 +4264,7 @@ let check_fundef env (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls) in let vtyp_args, vtyp_ret, declared_eff, vl = match typ with | Typ_aux (Typ_fn (vtyp_args, vtyp_ret, declared_eff), vl) -> vtyp_args, vtyp_ret, declared_eff, vl - | _ -> typ_error l "Function val spec was not a function type" + | _ -> typ_error l "Function val spec is not a function type" in check_tannotopt env quant vtyp_ret tannotopt; typ_debug (lazy ("Checking fundef " ^ string_of_id id ^ " has type " ^ string_of_bind (quant, typ))); @@ -4412,7 +4412,7 @@ let mk_synonym typq typ = ^ " with " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env)) let check_kinddef env (KD_aux (kdef, (l, _))) = - let kd_err () = raise (Reporting_basic.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented kind def") in + let kd_err () = raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented kind def") in match kdef with | KD_nabbrev ((K_aux(K_kind([BK_aux (BK_int, _)]),_) as kind), id, nmscm, nexp) -> [DEF_kind (KD_aux (KD_nabbrev (kind, id, nmscm, nexp), (l, None)))], @@ -4421,7 +4421,7 @@ let check_kinddef env (KD_aux (kdef, (l, _))) = let rec check_typedef : 'a. Env.t -> 'a type_def -> (tannot def) list * Env.t = fun env (TD_aux (tdef, (l, _))) -> - let td_err () = raise (Reporting_basic.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented Typedef") in + let td_err () = raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented Typedef") in match tdef with | TD_abbrev (id, nmscm, (TypSchm_aux (TypSchm_ts (typq, typ), _))) -> [DEF_type (TD_aux (tdef, (l, None)))], Env.add_typ_synonym id (mk_synonym typq typ) env @@ -4454,7 +4454,7 @@ let rec check_typedef : 'a. Env.t -> 'a type_def -> (tannot def) list * Env.t = and check_def : 'a. Env.t -> 'a def -> (tannot def) list * Env.t = fun env def -> - let cd_err () = raise (Reporting_basic.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented Case") in + let cd_err () = raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented Case") in match def with | DEF_kind kdef -> check_kinddef env kdef | DEF_type tdef -> check_typedef env tdef @@ -4485,7 +4485,7 @@ and check_def : 'a. Env.t -> 'a def -> (tannot def) list * Env.t = [DEF_reg_dec (DEC_aux (DEC_config (id, typ, checked_exp), (l, Some ((env, typ, no_effect), Some typ))))], env | DEF_reg_dec (DEC_aux (DEC_alias (id, aspec), (l, annot))) -> cd_err () | DEF_reg_dec (DEC_aux (DEC_typ_alias (typ, id, aspec), (l, tannot))) -> cd_err () - | DEF_scattered _ -> raise (Reporting_basic.err_unreachable Parse_ast.Unknown __POS__ "Scattered given to type checker") + | DEF_scattered _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Scattered given to type checker") and check : 'a. Env.t -> 'a defs -> tannot defs * Env.t = fun env (Defs defs) -> diff --git a/src/type_check.mli b/src/type_check.mli index ae46d956..1cb54770 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -405,7 +405,7 @@ Some invariants that will hold of a fully checked AST are: for them to have type annotations. check throws type_errors rather than Sail generic errors from - Reporting_basic. For a function that uses generic errors, use + Reporting. For a function that uses generic errors, use Type_error.check *) val check : Env.t -> 'a defs -> tannot defs * Env.t diff --git a/src/type_error.ml b/src/type_error.ml index 5e2ce628..39c22cde 100644 --- a/src/type_error.ml +++ b/src/type_error.ml @@ -170,7 +170,7 @@ let rec pp_type_error = function ^/^ string "in context" ^/^ bullet pp_n_constraint constrs ^/^ string "where" - ^/^ bullet (fun (kid, l) -> string (string_of_kid kid ^ " bound at " ^ Reporting_basic.loc_to_string l ^ "\n")) (KBindings.bindings locs) + ^/^ bullet (fun (kid, l) -> string (string_of_kid kid ^ " bound at " ^ Reporting.loc_to_string l ^ "\n")) (KBindings.bindings locs) | Err_no_num_ident id -> string "No num identifier" ^^ space ^^ string (string_of_id id) @@ -192,4 +192,4 @@ let rec string_of_type_error err = let check : 'a. Env.t -> 'a defs -> tannot defs * Env.t = fun env defs -> try Type_check.check env defs with - | Type_error (l, err) -> raise (Reporting_basic.err_typ l (string_of_type_error err)) + | Type_error (l, err) -> raise (Reporting.err_typ l (string_of_type_error err)) -- cgit v1.2.3 From 1eedc27eeca4496bada669b700a59283cc6932e9 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 31 Oct 2018 16:53:18 +0000 Subject: Remove Parse_ast.Int, add unique locations Remove Parse_ast.Int (for internal locations) as this was unused. Add a Parse_ast.Unique constructor to create unique locations. Change locate_X functions to take a function modifying locations, rather than just replacing them and add a function unique : l -> l that makes locations unique, such that `locate unique X` will make a locations in X unique. --- src/ast_util.ml | 259 +++++++++++++++++++++++++++------------------------- src/ast_util.mli | 21 +++-- src/monomorphise.ml | 7 +- src/parse_ast.ml | 2 +- src/reporting.ml | 42 +++------ src/type_check.ml | 2 +- 6 files changed, 168 insertions(+), 165 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index a0b75fc2..3cd2f361 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -1320,174 +1320,189 @@ let hex_to_bin hex = (* Functions for working with locations *) -let locate_id l (Id_aux (name, _)) = Id_aux (name, l) +let locate_id f (Id_aux (name, l)) = Id_aux (name, f l) -let locate_kid l (Kid_aux (name, _)) = Kid_aux (name, l) +let locate_kid f (Kid_aux (name, l)) = Kid_aux (name, f l) -let locate_lit l (L_aux (lit, _)) = L_aux (lit, l) +let locate_lit f (L_aux (lit, l)) = L_aux (lit, f l) -let locate_base_effect l (BE_aux (base_effect, _)) = BE_aux (base_effect, l) +let locate_base_effect f (BE_aux (base_effect, l)) = BE_aux (base_effect, f l) -let locate_effect l (Effect_aux (Effect_set effects, _)) = - Effect_aux (Effect_set (List.map (locate_base_effect l) effects), l) +let locate_effect f (Effect_aux (Effect_set effects, l)) = + Effect_aux (Effect_set (List.map (locate_base_effect f) effects), f l) -let rec locate_nexp l (Nexp_aux (nexp_aux, _)) = +let locate_order f (Ord_aux (ord_aux, l)) = + let ord_aux = match ord_aux with + | Ord_inc -> Ord_inc + | Ord_dec -> Ord_dec + | Ord_var v -> Ord_var (locate_kid f v) + in + Ord_aux (ord_aux, f l) + +let rec locate_nexp f (Nexp_aux (nexp_aux, l)) = let nexp_aux = match nexp_aux with - | Nexp_id id -> Nexp_id (locate_id l id) - | Nexp_var kid -> Nexp_var (locate_kid l kid) + | Nexp_id id -> Nexp_id (locate_id f id) + | Nexp_var kid -> Nexp_var (locate_kid f kid) | Nexp_constant n -> Nexp_constant n - | Nexp_app (id, nexps) -> Nexp_app (locate_id l id, List.map (locate_nexp l) nexps) - | Nexp_times (nexp1, nexp2) -> Nexp_times (locate_nexp l nexp1, locate_nexp l nexp2) - | Nexp_sum (nexp1, nexp2) -> Nexp_sum (locate_nexp l nexp1, locate_nexp l nexp2) - | Nexp_minus (nexp1, nexp2) -> Nexp_minus (locate_nexp l nexp1, locate_nexp l nexp2) - | Nexp_exp nexp -> Nexp_exp (locate_nexp l nexp) - | Nexp_neg nexp -> Nexp_neg (locate_nexp l nexp) + | Nexp_app (id, nexps) -> Nexp_app (locate_id f id, List.map (locate_nexp f) nexps) + | Nexp_times (nexp1, nexp2) -> Nexp_times (locate_nexp f nexp1, locate_nexp f nexp2) + | Nexp_sum (nexp1, nexp2) -> Nexp_sum (locate_nexp f nexp1, locate_nexp f nexp2) + | Nexp_minus (nexp1, nexp2) -> Nexp_minus (locate_nexp f nexp1, locate_nexp f nexp2) + | Nexp_exp nexp -> Nexp_exp (locate_nexp f nexp) + | Nexp_neg nexp -> Nexp_neg (locate_nexp f nexp) in - Nexp_aux (nexp_aux, l) + Nexp_aux (nexp_aux, f l) -let rec locate_nc l (NC_aux (nc_aux, _)) = +let rec locate_nc f (NC_aux (nc_aux, l)) = let nc_aux = match nc_aux with - | NC_equal (nexp1, nexp2) -> NC_equal (locate_nexp l nexp1, locate_nexp l nexp2) - | NC_bounded_ge (nexp1, nexp2) -> NC_bounded_ge (locate_nexp l nexp1, locate_nexp l nexp2) - | NC_bounded_le (nexp1, nexp2) -> NC_bounded_le (locate_nexp l nexp1, locate_nexp l nexp2) - | NC_not_equal (nexp1, nexp2) -> NC_not_equal (locate_nexp l nexp1, locate_nexp l nexp2) - | NC_set (kid, nums) -> NC_set (locate_kid l kid, nums) - | NC_or (nc1, nc2) -> NC_or (locate_nc l nc1, locate_nc l nc2) - | NC_and (nc1, nc2) -> NC_and (locate_nc l nc1, locate_nc l nc2) - | NC_app (id, nexps) -> NC_app (id, List.map (locate_nexp l) nexps) + | NC_equal (nexp1, nexp2) -> NC_equal (locate_nexp f nexp1, locate_nexp f nexp2) + | NC_bounded_ge (nexp1, nexp2) -> NC_bounded_ge (locate_nexp f nexp1, locate_nexp f nexp2) + | NC_bounded_le (nexp1, nexp2) -> NC_bounded_le (locate_nexp f nexp1, locate_nexp f nexp2) + | NC_not_equal (nexp1, nexp2) -> NC_not_equal (locate_nexp f nexp1, locate_nexp f nexp2) + | NC_set (kid, nums) -> NC_set (locate_kid f kid, nums) + | NC_or (nc1, nc2) -> NC_or (locate_nc f nc1, locate_nc f nc2) + | NC_and (nc1, nc2) -> NC_and (locate_nc f nc1, locate_nc f nc2) + | NC_app (id, nexps) -> NC_app (id, List.map (locate_nexp f) nexps) | NC_true -> NC_true | NC_false -> NC_false in - NC_aux (nc_aux, l) + NC_aux (nc_aux, f l) -let rec locate_typ l (Typ_aux (typ_aux, _)) = +let rec locate_typ f (Typ_aux (typ_aux, l)) = let typ_aux = match typ_aux with | Typ_internal_unknown -> Typ_internal_unknown - | Typ_id id -> Typ_id (locate_id l id) - | Typ_var kid -> Typ_var (locate_kid l kid) + | Typ_id id -> Typ_id (locate_id f id) + | Typ_var kid -> Typ_var (locate_kid f kid) | Typ_fn (arg_typs, ret_typ, effect) -> - Typ_fn (List.map (locate_typ l) arg_typs, locate_typ l ret_typ, locate_effect l effect) - | Typ_bidir (typ1, typ2) -> Typ_bidir (locate_typ l typ1, locate_typ l typ2) - | Typ_tup typs -> Typ_tup (List.map (locate_typ l) typs) - | Typ_exist (kids, constr, typ) -> Typ_exist (List.map (locate_kid l) kids, locate_nc l constr, locate_typ l typ) - | Typ_app (id, typ_args) -> Typ_app (locate_id l id, List.map (locate_typ_arg l) typ_args) + Typ_fn (List.map (locate_typ f) arg_typs, locate_typ f ret_typ, locate_effect f effect) + | Typ_bidir (typ1, typ2) -> Typ_bidir (locate_typ f typ1, locate_typ f typ2) + | Typ_tup typs -> Typ_tup (List.map (locate_typ f) typs) + | Typ_exist (kids, constr, typ) -> Typ_exist (List.map (locate_kid f) kids, locate_nc f constr, locate_typ f typ) + | Typ_app (id, typ_args) -> Typ_app (locate_id f id, List.map (locate_typ_arg f) typ_args) in - Typ_aux (typ_aux, l) + Typ_aux (typ_aux, f l) -and locate_typ_arg l (Typ_arg_aux (typ_arg_aux, _)) = +and locate_typ_arg f (Typ_arg_aux (typ_arg_aux, l)) = let typ_arg_aux = match typ_arg_aux with - | Typ_arg_nexp nexp -> Typ_arg_nexp nexp - | Typ_arg_typ typ -> Typ_arg_typ (locate_typ l typ) - | Typ_arg_order ord -> Typ_arg_order ord + | Typ_arg_nexp nexp -> Typ_arg_nexp (locate_nexp f nexp) + | Typ_arg_typ typ -> Typ_arg_typ (locate_typ f typ) + | Typ_arg_order ord -> Typ_arg_order (locate_order f ord) in - Typ_arg_aux (typ_arg_aux, l) + Typ_arg_aux (typ_arg_aux, f l) -let rec locate_typ_pat l (TP_aux (tp_aux, _)) = +let rec locate_typ_pat f (TP_aux (tp_aux, l)) = let tp_aux = match tp_aux with | TP_wild -> TP_wild - | TP_var kid -> TP_var (locate_kid l kid) - | TP_app (id, tps) -> TP_app (locate_id l id, List.map (locate_typ_pat l) tps) + | TP_var kid -> TP_var (locate_kid f kid) + | TP_app (id, tps) -> TP_app (locate_id f id, List.map (locate_typ_pat f) tps) in - TP_aux (tp_aux, l) + TP_aux (tp_aux, f l) -let rec locate_pat : 'a. l -> 'a pat -> 'a pat = fun l (P_aux (p_aux, (_, annot))) -> +let rec locate_pat : 'a. (l -> l) -> 'a pat -> 'a pat = fun f (P_aux (p_aux, (l, annot))) -> let p_aux = match p_aux with - | P_lit lit -> P_lit (locate_lit l lit) + | P_lit lit -> P_lit (locate_lit f lit) | P_wild -> P_wild - | P_or (pat1, pat2) -> P_or (locate_pat l pat1, locate_pat l pat2) - | P_not pat -> P_not (locate_pat l pat) - | P_as (pat, id) -> P_as (locate_pat l pat, locate_id l id) - | P_typ (typ, pat) -> P_typ (locate_typ l typ, locate_pat l pat) - | P_id id -> P_id (locate_id l id) - | P_var (pat, typ_pat) -> P_var (locate_pat l pat, locate_typ_pat l typ_pat) - | P_app (id, pats) -> P_app (locate_id l id, List.map (locate_pat l) pats) - | P_record (fpats, semi) -> P_record (List.map (locate_fpat l) fpats, semi) - | P_vector pats -> P_vector (List.map (locate_pat l) pats) - | P_vector_concat pats -> P_vector_concat (List.map (locate_pat l) pats) - | P_tup pats -> P_tup (List.map (locate_pat l) pats) - | P_list pats -> P_list (List.map (locate_pat l) pats) - | P_cons (hd_pat, tl_pat) -> P_cons (locate_pat l hd_pat, locate_pat l tl_pat) - | P_string_append pats -> P_string_append (List.map (locate_pat l) pats) + | P_or (pat1, pat2) -> P_or (locate_pat f pat1, locate_pat f pat2) + | P_not pat -> P_not (locate_pat f pat) + | P_as (pat, id) -> P_as (locate_pat f pat, locate_id f id) + | P_typ (typ, pat) -> P_typ (locate_typ f typ, locate_pat f pat) + | P_id id -> P_id (locate_id f id) + | P_var (pat, typ_pat) -> P_var (locate_pat f pat, locate_typ_pat f typ_pat) + | P_app (id, pats) -> P_app (locate_id f id, List.map (locate_pat f) pats) + | P_record (fpats, semi) -> P_record (List.map (locate_fpat f) fpats, semi) + | P_vector pats -> P_vector (List.map (locate_pat f) pats) + | P_vector_concat pats -> P_vector_concat (List.map (locate_pat f) pats) + | P_tup pats -> P_tup (List.map (locate_pat f) pats) + | P_list pats -> P_list (List.map (locate_pat f) pats) + | P_cons (hd_pat, tl_pat) -> P_cons (locate_pat f hd_pat, locate_pat f tl_pat) + | P_string_append pats -> P_string_append (List.map (locate_pat f) pats) in - P_aux (p_aux, (l, annot)) + P_aux (p_aux, (f l, annot)) -and locate_fpat : 'a. l -> 'a fpat -> 'a fpat = fun l (FP_aux (FP_Fpat (id, pat), (_, annot))) -> - FP_aux (FP_Fpat (locate_id l id, locate_pat l pat), (l, annot)) +and locate_fpat : 'a. (l -> l) -> 'a fpat -> 'a fpat = fun f (FP_aux (FP_Fpat (id, pat), (l, annot))) -> + FP_aux (FP_Fpat (locate_id f id, locate_pat f pat), (f l, annot)) -let rec locate : 'a. l -> 'a exp -> 'a exp = fun l (E_aux (e_aux, (_, annot))) -> +let rec locate : 'a. (l -> l) -> 'a exp -> 'a exp = fun f (E_aux (e_aux, (l, annot))) -> let e_aux = match e_aux with - | E_block exps -> E_block (List.map (locate l) exps) - | E_nondet exps -> E_nondet (List.map (locate l) exps) - | E_id id -> E_id (locate_id l id) - | E_lit lit -> E_lit (locate_lit l lit) - | E_cast (typ, exp) -> E_cast (locate_typ l typ, locate l exp) - | E_app (f, exps) -> E_app (locate_id l f, List.map (locate l) exps) - | E_app_infix (exp1, op, exp2) -> E_app_infix (locate l exp1, locate_id l op, locate l exp2) - | E_tuple exps -> E_tuple (List.map (locate l) exps) - | E_if (cond_exp, then_exp, else_exp) -> E_if (locate l cond_exp, locate l then_exp, locate l else_exp) - | E_loop (loop, cond, body) -> E_loop (loop, locate l cond, locate l body) + | E_block exps -> E_block (List.map (locate f) exps) + | E_nondet exps -> E_nondet (List.map (locate f) exps) + | E_id id -> E_id (locate_id f id) + | E_lit lit -> E_lit (locate_lit f lit) + | E_cast (typ, exp) -> E_cast (locate_typ f typ, locate f exp) + | E_app (id, exps) -> E_app (locate_id f id, List.map (locate f) exps) + | E_app_infix (exp1, op, exp2) -> E_app_infix (locate f exp1, locate_id f op, locate f exp2) + | E_tuple exps -> E_tuple (List.map (locate f) exps) + | E_if (cond_exp, then_exp, else_exp) -> E_if (locate f cond_exp, locate f then_exp, locate f else_exp) + | E_loop (loop, cond, body) -> E_loop (loop, locate f cond, locate f body) | E_for (id, exp1, exp2, exp3, ord, exp4) -> - E_for (locate_id l id, locate l exp1, locate l exp2, locate l exp3, ord, locate l exp4) - | E_vector exps -> E_vector (List.map (locate l) exps) - | E_vector_access (exp1, exp2) -> E_vector_access (locate l exp1, locate l exp2) - | E_vector_subrange (exp1, exp2, exp3) -> E_vector_subrange (locate l exp1, locate l exp2, locate l exp3) - | E_vector_update (exp1, exp2, exp3) -> E_vector_update (locate l exp1, locate l exp2, locate l exp3) + E_for (locate_id f id, locate f exp1, locate f exp2, locate f exp3, ord, locate f exp4) + | E_vector exps -> E_vector (List.map (locate f) exps) + | E_vector_access (exp1, exp2) -> E_vector_access (locate f exp1, locate f exp2) + | E_vector_subrange (exp1, exp2, exp3) -> E_vector_subrange (locate f exp1, locate f exp2, locate f exp3) + | E_vector_update (exp1, exp2, exp3) -> E_vector_update (locate f exp1, locate f exp2, locate f exp3) | E_vector_update_subrange (exp1, exp2, exp3, exp4) -> - E_vector_update_subrange (locate l exp1, locate l exp2, locate l exp3, locate l exp4) + E_vector_update_subrange (locate f exp1, locate f exp2, locate f exp3, locate f exp4) | E_vector_append (exp1, exp2) -> - E_vector_append (locate l exp1, locate l exp2) - | E_list exps -> E_list (List.map (locate l) exps) - | E_cons (exp1, exp2) -> E_cons (locate l exp1, locate l exp2) - | E_record fexps -> E_record (locate_fexps l fexps) - | E_record_update (exp, fexps) -> E_record_update (locate l exp, locate_fexps l fexps) - | E_field (exp, id) -> E_field (locate l exp, locate_id l id) - | E_case (exp, cases) -> E_case (locate l exp, List.map (locate_pexp l) cases) - | E_let (letbind, exp) -> E_let (locate_letbind l letbind, locate l exp) - | E_assign (lexp, exp) -> E_assign (locate_lexp l lexp, locate l exp) - | E_sizeof nexp -> E_sizeof (locate_nexp l nexp) - | E_return exp -> E_return (locate l exp) - | E_exit exp -> E_exit (locate l exp) - | E_ref id -> E_ref (locate_id l id) - | E_throw exp -> E_throw (locate l exp) - | E_try (exp, cases) -> E_try (locate l exp, List.map (locate_pexp l) cases) - | E_assert (exp, message) -> E_assert (locate l exp, locate l message) - | E_constraint constr -> E_constraint (locate_nc l constr) - | E_var (lexp, exp1, exp2) -> E_var (locate_lexp l lexp, locate l exp1, locate l exp2) - | E_internal_plet (pat, exp1, exp2) -> E_internal_plet (locate_pat l pat, locate l exp1, locate l exp2) - | E_internal_return exp -> E_internal_return (locate l exp) + E_vector_append (locate f exp1, locate f exp2) + | E_list exps -> E_list (List.map (locate f) exps) + | E_cons (exp1, exp2) -> E_cons (locate f exp1, locate f exp2) + | E_record fexps -> E_record (locate_fexps f fexps) + | E_record_update (exp, fexps) -> E_record_update (locate f exp, locate_fexps f fexps) + | E_field (exp, id) -> E_field (locate f exp, locate_id f id) + | E_case (exp, cases) -> E_case (locate f exp, List.map (locate_pexp f) cases) + | E_let (letbind, exp) -> E_let (locate_letbind f letbind, locate f exp) + | E_assign (lexp, exp) -> E_assign (locate_lexp f lexp, locate f exp) + | E_sizeof nexp -> E_sizeof (locate_nexp f nexp) + | E_return exp -> E_return (locate f exp) + | E_exit exp -> E_exit (locate f exp) + | E_ref id -> E_ref (locate_id f id) + | E_throw exp -> E_throw (locate f exp) + | E_try (exp, cases) -> E_try (locate f exp, List.map (locate_pexp f) cases) + | E_assert (exp, message) -> E_assert (locate f exp, locate f message) + | E_constraint constr -> E_constraint (locate_nc f constr) + | E_var (lexp, exp1, exp2) -> E_var (locate_lexp f lexp, locate f exp1, locate f exp2) + | E_internal_plet (pat, exp1, exp2) -> E_internal_plet (locate_pat f pat, locate f exp1, locate f exp2) + | E_internal_return exp -> E_internal_return (locate f exp) | E_internal_value value -> E_internal_value value in - E_aux (e_aux, (l, annot)) + E_aux (e_aux, (f l, annot)) -and locate_letbind : 'a. l -> 'a letbind -> 'a letbind = fun l (LB_aux (LB_val (pat, exp), (_, annot))) -> - LB_aux (LB_val (locate_pat l pat, locate l exp), (l, annot)) +and locate_letbind : 'a. (l -> l) -> 'a letbind -> 'a letbind = fun f (LB_aux (LB_val (pat, exp), (l, annot))) -> + LB_aux (LB_val (locate_pat f pat, locate f exp), (f l, annot)) -and locate_pexp : 'a. l -> 'a pexp -> 'a pexp = fun l (Pat_aux (pexp_aux, (_, annot))) -> +and locate_pexp : 'a. (l -> l) -> 'a pexp -> 'a pexp = fun f (Pat_aux (pexp_aux, (l, annot))) -> let pexp_aux = match pexp_aux with - | Pat_exp (pat, exp) -> Pat_exp (locate_pat l pat, locate l exp) - | Pat_when (pat, guard, exp) -> Pat_when (locate_pat l pat, locate l guard, locate l exp) + | Pat_exp (pat, exp) -> Pat_exp (locate_pat f pat, locate f exp) + | Pat_when (pat, guard, exp) -> Pat_when (locate_pat f pat, locate f guard, locate f exp) in - Pat_aux (pexp_aux, (l, annot)) + Pat_aux (pexp_aux, (f l, annot)) -and locate_lexp : 'a. l -> 'a lexp -> 'a lexp = fun l (LEXP_aux (lexp_aux, (_, annot))) -> +and locate_lexp : 'a. (l -> l) -> 'a lexp -> 'a lexp = fun f (LEXP_aux (lexp_aux, (l, annot))) -> let lexp_aux = match lexp_aux with - | LEXP_id id -> LEXP_id (locate_id l id) - | LEXP_deref exp -> LEXP_deref (locate l exp) - | LEXP_memory (id, exps) -> LEXP_memory (locate_id l id, List.map (locate l) exps) - | LEXP_cast (typ, id) -> LEXP_cast (locate_typ l typ, locate_id l id) - | LEXP_tup lexps -> LEXP_tup (List.map (locate_lexp l) lexps) - | LEXP_vector_concat lexps -> LEXP_vector_concat (List.map (locate_lexp l) lexps) - | LEXP_vector (lexp, exp) -> LEXP_vector (locate_lexp l lexp, locate l exp) - | LEXP_vector_range (lexp, exp1, exp2) -> LEXP_vector_range (locate_lexp l lexp, locate l exp1, locate l exp2) - | LEXP_field (lexp, id) -> LEXP_field (locate_lexp l lexp, locate_id l id) + | LEXP_id id -> LEXP_id (locate_id f id) + | LEXP_deref exp -> LEXP_deref (locate f exp) + | LEXP_memory (id, exps) -> LEXP_memory (locate_id f id, List.map (locate f) exps) + | LEXP_cast (typ, id) -> LEXP_cast (locate_typ f typ, locate_id f id) + | LEXP_tup lexps -> LEXP_tup (List.map (locate_lexp f) lexps) + | LEXP_vector_concat lexps -> LEXP_vector_concat (List.map (locate_lexp f) lexps) + | LEXP_vector (lexp, exp) -> LEXP_vector (locate_lexp f lexp, locate f exp) + | LEXP_vector_range (lexp, exp1, exp2) -> LEXP_vector_range (locate_lexp f lexp, locate f exp1, locate f exp2) + | LEXP_field (lexp, id) -> LEXP_field (locate_lexp f lexp, locate_id f id) in - LEXP_aux (lexp_aux, (l, annot)) + LEXP_aux (lexp_aux, (f l, annot)) + +and locate_fexps : 'a. (l -> l) -> 'a fexps -> 'a fexps = fun f (FES_aux (FES_Fexps (fexps, semi), (l, annot))) -> + FES_aux (FES_Fexps (List.map (locate_fexp f) fexps, semi), (f l, annot)) + +and locate_fexp : 'a. (l -> l) -> 'a fexp -> 'a fexp = fun f (FE_aux (FE_Fexp (id, exp), (l, annot))) -> + FE_aux (FE_Fexp (locate_id f id, locate f exp), (f l, annot)) -and locate_fexps : 'a. l -> 'a fexps -> 'a fexps = fun l (FES_aux (FES_Fexps (fexps, semi), (_, annot))) -> - FES_aux (FES_Fexps (List.map (locate_fexp l) fexps, semi), (l, annot)) +let unique_ref = ref 0 -and locate_fexp : 'a. l -> 'a fexp -> 'a fexp = fun l (FE_aux (FE_Fexp (id, exp), (_, annot))) -> - FE_aux (FE_Fexp (locate_id l id, locate l exp), (l, annot)) +let unique l = + let l = Parse_ast.Unique (!unique_ref, l) in + incr unique_ref; + l (**************************************************************************) (* 1. Substitutions *) diff --git a/src/ast_util.mli b/src/ast_util.mli index fae7b81c..1cd621b4 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -355,17 +355,22 @@ val subst : id -> 'a exp -> 'a exp -> 'a exp val hex_to_bin : string -> string (** locate takes an expression and recursively sets the location in - every subexpression to the provided location. Expressions build - using mk_exp and similar do not have locations, so they can then be - annotated as e.g. locate (gen_loc l) (mk_exp ...) where l is the - location from which the code is being generated. *) -val locate : l -> 'a exp -> 'a exp + every subexpression using a function that takes the orginal + location as an argument. Expressions build using mk_exp and similar + do not have locations, so they can then be annotated as e.g. locate + (gen_loc l) (mk_exp ...) where l is the location from which the + code is being generated. *) +val locate : (l -> l) -> 'a exp -> 'a exp -val locate_pat : l -> 'a pat -> 'a pat +val locate_pat : (l -> l) -> 'a pat -> 'a pat -val locate_lexp : l -> 'a lexp -> 'a lexp +val locate_lexp : (l -> l) -> 'a lexp -> 'a lexp -val locate_typ : l -> typ -> typ +val locate_typ : (l -> l) -> typ -> typ + +(* Make a unique location by giving it a Parse_ast.Unique wrapper with + a generated number. *) +val unique : l -> l (** Substitutions *) diff --git a/src/monomorphise.ml b/src/monomorphise.ml index c43b4a56..975e8017 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -1737,8 +1737,8 @@ let split_defs all_errors splits defs = let map_locs ls (Defs defs) = let rec match_l = function - | Unknown - | Int _ -> [] + | Unknown -> [] + | Unique (_, l) -> match_l l | Generated l -> [] (* Could do match_l l, but only want to split user-written patterns *) | Documented (_,l) -> match_l l | Range (p,q) -> @@ -2602,8 +2602,7 @@ let string_of_lx lx = let rec simple_string_of_loc = function | Parse_ast.Unknown -> "Unknown" - | Parse_ast.Int (s,None) -> "Int(" ^ s ^ ",None)" - | Parse_ast.Int (s,Some l) -> "Int(" ^ s ^ ",Some("^simple_string_of_loc l^"))" + | Parse_ast.Unique (n, l) -> "Unique(" ^ string_of_int n ^ ", " ^ simple_string_of_loc l ^ ")" | Parse_ast.Generated l -> "Generated(" ^ simple_string_of_loc l ^ ")" | Parse_ast.Range (lx1,lx2) -> "Range(" ^ string_of_lx lx1 ^ "->" ^ string_of_lx lx2 ^ ")" | Parse_ast.Documented (_,l) -> "Documented(_," ^ simple_string_of_loc l ^ ")" diff --git a/src/parse_ast.ml b/src/parse_ast.ml index 3317c196..d19e85ed 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -56,7 +56,7 @@ type text = string type l = | Unknown - | Int of string * l option + | Unique of int * l | Generated of l | Range of Lexing.position * Lexing.position | Documented of string * l diff --git a/src/reporting.ml b/src/reporting.ml index fffae5a7..358a99a8 100644 --- a/src/reporting.ml +++ b/src/reporting.ml @@ -187,36 +187,20 @@ let read_from_file_pos2 p1 p2 = let _ = close_in ic in (buf, not (multi = None)) -(* Destruct a location by splitting all the Internal strings except possibly the - last one into a string list and keeping only the last location *) -let dest_loc (l : Parse_ast.l) : (Parse_ast.l * string list) = - let rec aux acc l = match l with - | Parse_ast.Int(s, Some l') -> aux (s::acc) l' - | _ -> (l, acc) - in - aux [] l +let rec format_loc_aux ff = function + | Parse_ast.Unknown -> Format.fprintf ff "no location information available" + | Parse_ast.Generated l -> Format.fprintf ff "code generated: original nearby source is "; (format_loc_aux ff l) + | Parse_ast.Unique (n, l) -> Format.fprintf ff "code unique (%d): original nearby source is " n; (format_loc_aux ff l) + | Parse_ast.Range (p1,p2) -> format_pos2 ff p1 p2 + | Parse_ast.Documented (_, l) -> format_loc_aux ff l -let rec format_loc_aux ff l = - let (l_org, mod_s) = dest_loc l in - let _ = match l_org with - | Parse_ast.Unknown -> Format.fprintf ff "no location information available" - | Parse_ast.Generated l -> Format.fprintf ff "code generated: original nearby source is "; (format_loc_aux ff l) - | Parse_ast.Range(p1,p2) -> format_pos2 ff p1 p2 - | Parse_ast.Int(s,_) -> Format.fprintf ff "code in lib from: %s" s - | Parse_ast.Documented(_, l) -> format_loc_aux ff l - in - () - -let format_loc_source ff l = - match dest_loc l with - | (Parse_ast.Range (p1, p2), _) -> - begin - let (s, multi_line) = read_from_file_pos2 p1 p2 in - if multi_line then - Format.fprintf ff " original input:\n%s\n" (Bytes.to_string s) - else - Format.fprintf ff " original input: \"%s\"\n" (Bytes.to_string s) - end +let format_loc_source ff = function + | Parse_ast.Range (p1, p2) -> + let (s, multi_line) = read_from_file_pos2 p1 p2 in + if multi_line then + Format.fprintf ff " original input:\n%s\n" (Bytes.to_string s) + else + Format.fprintf ff " original input: \"%s\"\n" (Bytes.to_string s) | _ -> () let format_loc ff l = diff --git a/src/type_check.ml b/src/type_check.ml index acba67fe..39842bc0 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -2774,7 +2774,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) match pat_aux with | P_lit lit -> let var = fresh_var () in - let guard = locate l (mk_exp (E_app_infix (mk_exp (E_id var), mk_id "==", mk_exp (E_lit lit)))) in + let guard = locate (fun _ -> l) (mk_exp (E_app_infix (mk_exp (E_id var), mk_id "==", mk_exp (E_lit lit)))) in let (typed_pat, env, guards) = bind_pat env (mk_pat (P_id var)) typ in typed_pat, env, guard::guards | _ -> raise typ_exn -- cgit v1.2.3 From aa451c3d9b9889ca00f45a928da9839788828072 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 31 Oct 2018 18:31:56 +0000 Subject: Add rewriting pass for not-patterns Doesn't work with nested not-patterns, but I think we should probably just disallow these as they seem very hard to remove in any kind of sensible way. --- src/rewrites.ml | 54 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 54 insertions(+) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index 25d1467f..c274ded4 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -4081,6 +4081,56 @@ let rewrite_defs_remove_superfluous_letbinds = ; rewrite_defs = rewrite_defs_base } +(* FIXME: We shouldn't allow nested not-patterns *) +let rewrite_defs_not_pats = + let rewrite_pexp (pexp_aux, annot) = + let rewrite_pexp' pat exp orig_guard = + let guards = ref [] in + let not_counter = ref 0 in + let rewrite_not_pat (pat_aux, annot) = + match pat_aux with + | P_not pat -> + incr not_counter; + let np_id = mk_id ("np#" ^ string_of_int !not_counter) in + let guard = + mk_exp (E_case (mk_exp (E_id np_id), + [mk_pexp (Pat_exp (strip_pat pat, mk_lit_exp L_false)); + mk_pexp (Pat_exp (mk_pat P_wild, mk_lit_exp L_true))])) + in + guards := (np_id, typ_of_annot annot, guard) :: !guards; + P_aux (P_id np_id, annot) + + | _ -> P_aux (pat_aux, annot) + in + let pat = fold_pat { id_pat_alg with p_aux = rewrite_not_pat } pat in + begin match !guards with + | [] -> + Pat_aux (pexp_aux, annot) + | guards -> + let guard_exp = + match orig_guard, guards with + | Some guard, _ -> + List.fold_left (fun exp1 (_, _, exp2) -> mk_exp (E_app_infix (exp1, mk_id "&", exp2))) guard guards + | None, (_, _, guard) :: guards -> + List.fold_left (fun exp1 (_, _, exp2) -> mk_exp (E_app_infix (exp1, mk_id "&", exp2))) guard guards + | _ -> raise (Reporting.err_unreachable (fst annot) __POS__ "Case in not-pattern re-writing should be unreachable") + in + (* We need to construct an environment to check the match guard in *) + let env = env_of_pat pat in + let env = List.fold_left (fun env (np_id, np_typ, _) -> Env.add_local np_id (Immutable, np_typ) env) env guards in + let guard_exp = Type_check.check_exp env guard_exp bool_typ in + Pat_aux (Pat_when (pat, guard_exp, exp), annot) + end + in + match pexp_aux with + | Pat_exp (pat, exp) -> + rewrite_pexp' pat exp None + | Pat_when (pat, guard, exp) -> + rewrite_pexp' pat exp (Some (strip_exp guard)) + in + let rw_exp = { id_exp_alg with pat_aux = rewrite_pexp } in + rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp rw_exp) } + let rewrite_defs_remove_superfluous_returns = let add_opt_cast typopt1 typopt2 annot exp = @@ -4872,6 +4922,7 @@ let rewrite_defs_lem = [ ("recheck_defs", if_mono recheck_defs); ("rewrite_undefined", rewrite_undefined_if_gen false); ("rewrite_defs_vector_string_pats_to_bit_list", rewrite_defs_vector_string_pats_to_bit_list); + ("remove_not_pats", rewrite_defs_not_pats); ("pat_lits", rewrite_defs_pat_lits rewrite_lit_lem); ("vector_concat_assignments", rewrite_vector_concat_assignments); ("tuple_assignments", rewrite_tuple_assignments); @@ -4914,6 +4965,7 @@ let rewrite_defs_coq = [ ("mapping_builtins", rewrite_defs_mapping_patterns); ("rewrite_undefined", rewrite_undefined_if_gen true); ("rewrite_defs_vector_string_pats_to_bit_list", rewrite_defs_vector_string_pats_to_bit_list); + ("remove_not_pats", rewrite_defs_not_pats); ("pat_lits", rewrite_defs_pat_lits rewrite_lit_lem); ("vector_concat_assignments", rewrite_vector_concat_assignments); ("tuple_assignments", rewrite_tuple_assignments); @@ -4962,6 +5014,7 @@ let rewrite_defs_ocaml = [ ("vector_concat_assignments", rewrite_vector_concat_assignments); ("tuple_assignments", rewrite_tuple_assignments); ("simple_assignments", rewrite_simple_assignments); + ("remove_not_pats", rewrite_defs_not_pats); ("remove_vector_concat", rewrite_defs_remove_vector_concat); ("remove_bitvector_pats", rewrite_defs_remove_bitvector_pats); ("remove_numeral_pats", rewrite_defs_remove_numeral_pats); @@ -4983,6 +5036,7 @@ let rewrite_defs_c = [ ("mapping_builtins", rewrite_defs_mapping_patterns); ("rewrite_undefined", rewrite_undefined_if_gen false); ("rewrite_defs_vector_string_pats_to_bit_list", rewrite_defs_vector_string_pats_to_bit_list); + ("remove_not_pats", rewrite_defs_not_pats); ("pat_lits", rewrite_defs_pat_lits (fun _ -> true)); ("vector_concat_assignments", rewrite_vector_concat_assignments); ("tuple_assignments", rewrite_tuple_assignments); -- cgit v1.2.3 From c54f60b713087e33758c63dc110fe02d3fea29c9 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Thu, 1 Nov 2018 17:26:01 +0000 Subject: Changes to enable analysing type errors in ASL parser Also some pretty printer improvements Make all the tests use the same colours for green/red/yellow --- src/ast_util.ml | 44 ++++++++++++++++++++++++++++++++++++++++- src/ast_util.mli | 6 ++++++ src/pretty_print_sail.ml | 50 ++++++++++++++++++++++++++++++++++++++--------- src/type_error.ml | 51 +++++++++++++++++++++++++++++++++++++++++++++++- src/util.ml | 9 +++++++++ src/util.mli | 5 +++++ 6 files changed, 154 insertions(+), 11 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index 3cd2f361..61bc9ba3 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -270,6 +270,47 @@ and nexp_simp_aux = function end | nexp -> nexp +let rec constraint_simp (NC_aux (nc_aux, l)) = + let nc_aux = match nc_aux with + | NC_equal (nexp1, nexp2) -> + let nexp1, nexp2 = nexp_simp nexp1, nexp_simp nexp2 in + if nexp_identical nexp1 nexp2 then + NC_true + else + NC_equal (nexp1, nexp2) + + | NC_and (nc1, nc2) -> + let nc1, nc2 = constraint_simp nc1, constraint_simp nc2 in + begin match nc1, nc2 with + | NC_aux (NC_true, _), NC_aux (nc, _) -> nc + | NC_aux (nc, _), NC_aux (NC_true, _) -> nc + | _, _ -> NC_and (nc1, nc2) + end + + | NC_or (nc1, nc2) -> + let nc1, nc2 = constraint_simp nc1, constraint_simp nc2 in + begin match nc1, nc2 with + | NC_aux (NC_false, _), NC_aux (nc, _) -> nc + | NC_aux (nc, _), NC_aux (NC_false, _) -> nc + | NC_aux (NC_true, _), NC_aux (nc, _) -> NC_true + | NC_aux (nc, _), NC_aux (NC_true, _) -> NC_true + | _, _ -> NC_or (nc1, nc2) + end + + | _ -> nc_aux + in + NC_aux (nc_aux, l) + +let rec constraint_conj (NC_aux (nc_aux, l) as nc) = + match nc_aux with + | NC_and (nc1, nc2) -> constraint_conj nc1 @ constraint_conj nc2 + | _ -> [nc] + +let rec constraint_disj (NC_aux (nc_aux, l) as nc) = + match nc_aux with + | NC_or (nc1, nc2) -> constraint_disj nc1 @ constraint_disj nc2 + | _ -> [nc] + let mk_typ typ = Typ_aux (typ, Parse_ast.Unknown) let mk_typ_arg arg = Typ_arg_aux (arg, Parse_ast.Unknown) let mk_kid str = Kid_aux (Var ("'" ^ str), Parse_ast.Unknown) @@ -618,9 +659,10 @@ and string_of_typ_aux = function | Typ_id id -> string_of_id id | Typ_var kid -> string_of_kid kid | Typ_tup typs -> "(" ^ string_of_list ", " string_of_typ typs ^ ")" + | Typ_app (id, args) when Id.compare id (mk_id "atom") = 0 -> "int(" ^ string_of_list ", " string_of_typ_arg args ^ ")" | Typ_app (id, args) -> string_of_id id ^ "(" ^ string_of_list ", " string_of_typ_arg args ^ ")" | Typ_fn ([typ_arg], typ_ret, eff) -> - string_of_typ typ_arg ^ " -> " ^ string_of_typ typ_ret ^ " effect " ^ string_of_effect eff + string_of_typ typ_arg ^ " -> " ^ string_of_typ typ_ret ^ " effect " ^ string_of_effect eff | Typ_fn (typ_args, typ_ret, eff) -> "(" ^ string_of_list ", " string_of_typ typ_args ^ ") -> " ^ string_of_typ typ_ret ^ " effect " ^ string_of_effect eff diff --git a/src/ast_util.mli b/src/ast_util.mli index 1cd621b4..f55cdf16 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -138,6 +138,12 @@ val no_effect : effect val mk_effect : base_effect_aux list -> effect val nexp_simp : nexp -> nexp +val constraint_simp : n_constraint -> n_constraint + +(* If a constraint is a conjunction, return a list of all the top-level conjuncts *) +val constraint_conj : n_constraint -> n_constraint list +(* Same as constraint_conj but for disjunctions *) +val constraint_disj : n_constraint -> n_constraint list (* Utilities for building n-expressions *) val nconstant : Big_int.num -> nexp diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index 7de4dd40..d71b32b2 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -52,6 +52,8 @@ open Ast open Ast_util open PPrint +let opt_use_heuristics = ref false + module Big_int = Nat_big_num let doc_op symb a b = infix 2 1 symb a b @@ -124,11 +126,26 @@ let doc_nc = | NC_set (kid, ints) -> separate space [doc_kid kid; string "in"; braces (separate_map (comma ^^ space) doc_int ints)] | NC_app (id, nexps) -> string "where" ^^ space ^^ doc_id id ^^ parens (separate_map (comma ^^ space) doc_nexp nexps) - | _ -> parens (nc0 nc) - and nc0 (NC_aux (nc_aux, _) as nc) = - match nc_aux with - | NC_or (c1, c2) -> separate space [nc0 c1; string "|"; nc1 c2] - | _ -> nc1 nc + | _ -> nc0 ~parenthesize:true nc + and nc0 ?parenthesize:(parenthesize=false) (NC_aux (nc_aux, _) as nc) = + (* Rather than parens (nc0 x) we use nc0 ~parenthesize:true x, because if + we rewrite a disjunction as a set constraint, then we can + always omit the parens. *) + let parens' = if parenthesize then parens else (fun x -> x) in + let disjs = constraint_disj nc in + let collect_constants kid = function + | NC_aux (NC_equal (Nexp_aux (Nexp_var kid', _), Nexp_aux (Nexp_constant c, _)), _) when Kid.compare kid kid' = 0 -> Some c + | _ -> None + in + match disjs with + | NC_aux (NC_equal (Nexp_aux (Nexp_var kid, _), Nexp_aux (Nexp_constant c, _)), _) :: ncs -> + let constants = List.map (collect_constants kid) ncs in + begin match Util.option_all (List.map (collect_constants kid) ncs) with + | None | Some [] -> parens' (separate_map (space ^^ bar ^^ space) nc1 disjs) + | Some cs -> + separate space [doc_kid kid; string "in"; braces (separate_map (comma ^^ space) doc_int (c :: cs))] + end + | _ -> parens' (separate_map (space ^^ bar ^^ space) nc1 disjs) and nc1 (NC_aux (nc_aux, _) as nc) = match nc_aux with | NC_and (c1, c2) -> separate space [nc1 c1; string "&"; atomic_nc c2] @@ -146,6 +163,7 @@ let rec doc_typ (Typ_aux (typ_aux, l)) = | Typ_app (id, [_; len; _; Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id tid, _)), _)]) when Id.compare (mk_id "vector") id == 0 && Id.compare (mk_id "bit") tid == 0-> string "bits" ^^ parens (doc_typ_arg len) *) + | Typ_app (id, typs) when Id.compare id (mk_id "atom") = 0 -> string "int" ^^ parens (separate_map (string ", ") doc_typ_arg typs) | Typ_app (id, typs) -> doc_id id ^^ parens (separate_map (string ", ") doc_typ_arg typs) | Typ_tup typs -> parens (separate_map (string ", ") doc_typ typs) | Typ_var kid -> doc_kid kid @@ -172,6 +190,12 @@ and doc_arg_typs = function | [typ] -> doc_typ typ | typs -> parens (separate_map (comma ^^ space) doc_typ typs) +let doc_kopt = function + | KOpt_aux (KOpt_none kid, _) -> doc_kid kid + | kopt when is_nat_kopt kopt -> doc_kid (kopt_kid kopt) + | kopt when is_typ_kopt kopt -> parens (separate space [doc_kid (kopt_kid kopt); colon; string "Type"]) + | kopt -> parens (separate space [doc_kid (kopt_kid kopt); colon; string "Order"]) + let doc_quants quants = let doc_qi_kopt (QI_aux (qi_aux, _)) = match qi_aux with @@ -193,14 +217,22 @@ let doc_quants quants = | [nc] -> kdoc ^^ comma ^^ space ^^ doc_nc nc | nc :: ncs -> kdoc ^^ comma ^^ space ^^ doc_nc (List.fold_left nc_and nc ncs) - - -let doc_binding (TypQ_aux (tq_aux, _), typ) = +let doc_binding ((TypQ_aux (tq_aux, _) as typq), typ) = match tq_aux with | TypQ_no_forall -> doc_typ typ | TypQ_tq [] -> doc_typ typ | TypQ_tq qs -> - string "forall" ^^ space ^^ doc_quants qs ^^ dot ^//^ doc_typ typ + if !opt_use_heuristics && String.length (string_of_typquant typq) > 60 then + let kopts, ncs = quant_split typq in + if ncs = [] then + string "forall" ^^ space ^^ separate_map space doc_kopt kopts ^^ dot + ^//^ doc_typ typ + else + string "forall" ^^ space ^^ separate_map space doc_kopt kopts ^^ comma + ^//^ (separate_map (space ^^ string "&" ^^ space) doc_nc ncs ^^ dot + ^^ hardline ^^ doc_typ typ) + else + string "forall" ^^ space ^^ doc_quants qs ^^ dot ^//^ doc_typ typ let doc_typschm (TypSchm_aux (TypSchm_ts (typq, typ), _)) = doc_binding (typq, typ) diff --git a/src/type_error.ml b/src/type_error.ml index 39c22cde..ada8e16b 100644 --- a/src/type_error.ml +++ b/src/type_error.ml @@ -100,6 +100,56 @@ and nc_subst_nexp_aux l sv subst = function | NC_false -> NC_false | NC_true -> NC_true +type suggestion = + | Suggest_add_constraint of n_constraint + | Suggest_none + +(* Temporary hack while I work on using these suggestions in asl_parser *) +let rec analyze_unresolved_quant2 locals ncs = function + | QI_aux (QI_const nc, _) -> + let gen_kids = List.filter is_kid_generated (KidSet.elements (tyvars_of_constraint nc)) in + if gen_kids = [] then + Suggest_add_constraint nc + else + (* If there are generated kind-identifiers in the constraint, + we don't want to make a suggestion based on them, so try to + look for generated kid free nexps in the set of constraints + that are equal to the generated identifier. This often + occurs due to how the type-checker introduces new type + variables. *) + let is_subst v = function + | NC_aux (NC_equal (Nexp_aux (Nexp_var v', _), nexp), _) + when Kid.compare v v' = 0 && not (KidSet.exists is_kid_generated (tyvars_of_nexp nexp)) -> + [(v, nexp)] + | NC_aux (NC_equal (nexp, Nexp_aux (Nexp_var v', _)), _) + when Kid.compare v v' = 0 && not (KidSet.exists is_kid_generated (tyvars_of_nexp nexp)) -> + [(v, nexp)] + | _ -> [] + in + let substs = List.concat (List.map (fun v -> List.concat (List.map (fun nc -> is_subst v nc) ncs)) gen_kids) in + let nc = List.fold_left (fun nc (v, nexp) -> nc_subst_nexp v (unaux_nexp nexp) nc) nc substs in + if not (KidSet.exists is_kid_generated (tyvars_of_constraint nc)) then + Suggest_add_constraint nc + else + (* If we have a really anonymous type-variable, try to find a + regular variable that corresponds to it. *) + let is_linked v = function + | (id, (Immutable, (Typ_aux (Typ_app (ty_id, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var v', _)), _)]), _) as typ))) + when Id.compare ty_id (mk_id "atom") = 0 && Kid.compare v v' = 0 -> + [(v, nid id, typ)] + | (id, (mut, typ)) -> + [] + in + let substs = List.concat (List.map (fun v -> List.concat (List.map (fun nc -> is_linked v nc) (Bindings.bindings locals))) gen_kids) in + let nc = List.fold_left (fun nc (v, nexp, _) -> nc_subst_nexp v (unaux_nexp nexp) nc) nc substs in + if not (KidSet.exists is_kid_generated (tyvars_of_constraint nc)) then + Suggest_none + else + Suggest_none + + | QI_aux (QI_id kopt, _) -> + Suggest_none + let rec analyze_unresolved_quant locals ncs = function | QI_aux (QI_const nc, _) -> let gen_kids = List.filter is_kid_generated (KidSet.elements (tyvars_of_constraint nc)) in @@ -133,7 +183,6 @@ let rec analyze_unresolved_quant locals ncs = function when Id.compare ty_id (mk_id "atom") = 0 && Kid.compare v v' = 0 -> [(v, nid id, typ)] | (id, (mut, typ)) -> - prerr_endline (string_of_id id ^ " : " ^ string_of_typ typ); [] in let substs = List.concat (List.map (fun v -> List.concat (List.map (fun nc -> is_linked v nc) (Bindings.bindings locals))) gen_kids) in diff --git a/src/util.ml b/src/util.ml index e0366fe7..c0b88815 100644 --- a/src/util.ml +++ b/src/util.ml @@ -232,6 +232,15 @@ let rec option_these = function | None :: xs -> option_these xs | [] -> [] +let rec option_all = function + | [] -> Some [] + | None :: _ -> None + | Some x :: xs -> + begin match option_all xs with + | None -> None + | Some xs -> Some (x :: xs) + end + let changed2 f g x h y = match (g x, h y) with | (None,None) -> None diff --git a/src/util.mli b/src/util.mli index eb4b4bd2..5bb7c559 100644 --- a/src/util.mli +++ b/src/util.mli @@ -105,6 +105,11 @@ val option_get_exn : exn -> 'a option -> 'a wrapped in [Some]. *) val option_these : 'a option list -> 'a list +(** [option_all xs] extracts the elements of the list [xs] if all of + them are wrapped in Some. If any are None then the result is None is + None. [option_all []] is [Some []] *) +val option_all : 'a option list -> 'a list option + (** [changed2 f g x h y] applies [g] to [x] and [h] to [y]. If both function applications return [None], then [None] is returned. Otherwise [f] is applied to the results. For this -- cgit v1.2.3 From d0f80cd274d16b049896628e6046062eac95258f Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Fri, 2 Nov 2018 14:20:06 +0000 Subject: Coq: add more autocasts for different but equal kids (only affects Reduce on Aarch64) --- src/pretty_print_coq.ml | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) (limited to 'src') diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 66c13678..2e62188d 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -800,11 +800,18 @@ let rec nexp_const_eval (Nexp_aux (n,l) as nexp) = (* Decide whether two nexps used in a vector size are similar; if not a cast will be inserted *) -let similar_nexps env n1 n2 = +let similar_nexps ctxt env n1 n2 = let rec same_nexp_shape (Nexp_aux (n1,_)) (Nexp_aux (n2,_)) = match n1, n2 with | Nexp_id _, Nexp_id _ -> true - | Nexp_var k1, Nexp_var k2 -> prove env (nc_eq (nvar k1) (nvar k2)) + (* TODO: this is really just an approximation to what we really want: + will the Coq types have the same names? We could probably do better + by tracking which existential kids are equal to bound kids. *) + | Nexp_var k1, Nexp_var k2 -> + Kid.compare k1 k2 == 0 || + (prove env (nc_eq (nvar k1) (nvar k2)) && ( + not (KidSet.mem k1 ctxt.bound_nvars) || + not (KidSet.mem k2 ctxt.bound_nvars))) | Nexp_constant c1, Nexp_constant c2 -> Nat_big_num.equal c1 c2 | Nexp_app (f1,args1), Nexp_app (f2,args2) -> Id.compare f1 f2 == 0 && List.for_all2 same_nexp_shape args1 args2 @@ -923,7 +930,7 @@ let doc_exp, doc_let = match in_typ, out_typ with | Typ_aux (Typ_app (_,[Typ_arg_aux (Typ_arg_nexp n1,_);_;_]),_), Typ_aux (Typ_app (_,[Typ_arg_aux (Typ_arg_nexp n2,_);_;_]),_) -> - not (similar_nexps (env_of exp) n1 n2) + not (similar_nexps ctxt (env_of exp) n1 n2) | _ -> false in let exp_pp = expV (want_parens || autocast || build_ex) exp in @@ -1176,7 +1183,7 @@ let doc_exp, doc_let = match typ_of_arg', typ_from_fn' with | Typ_aux (Typ_app (_,[Typ_arg_aux (Typ_arg_nexp n1,_);_;_]),_), Typ_aux (Typ_app (_,[Typ_arg_aux (Typ_arg_nexp n2,_);_;_]),_) -> - not (similar_nexps env n1 n2) + not (similar_nexps ctxt env n1 n2) | _ -> false in let want_parens1 = want_parens || autocast in @@ -1226,7 +1233,7 @@ let doc_exp, doc_let = match in_typ, out_typ with | Typ_aux (Typ_app (_,[Typ_arg_aux (Typ_arg_nexp n1,_);_;_]),_), Typ_aux (Typ_app (_,[Typ_arg_aux (Typ_arg_nexp n2,_);_;_]),_) -> - not (similar_nexps env n1 n2) + not (similar_nexps ctxt env n1 n2) | _ -> false in pack,unpack,autocast in @@ -1324,7 +1331,7 @@ let doc_exp, doc_let = match outer_typ', cast_typ' with | Typ_aux (Typ_app (_,[Typ_arg_aux (Typ_arg_nexp n1,_);_;_]),_), Typ_aux (Typ_app (_,[Typ_arg_aux (Typ_arg_nexp n2,_);_;_]),_) -> - not (similar_nexps env n1 n2) + not (similar_nexps ctxt env n1 n2) | _ -> false in let effects = effectful (effect_of e) in -- cgit v1.2.3 From b6bddcc8f07d419a1b49e33d40050950af051a1d Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Fri, 2 Nov 2018 16:29:46 +0000 Subject: Add code to analyse function return types For ASL parser, we have code that can add additional constraints to a function if they are required by functions it calls, but for more general range analysis we need to restrict the return types of various ASL functions that return int. To do this we can write some code that walks over the type-checked AST for a function body and tries to infer a more restrictive return type at each function exit point. Then we try to union those types together if possible to infer a more restricted return type. For example, for the highest_set_bit function val highest_set_bit : forall ('n : Int), 'n >= 0. bits('n) -> int function highest_set_bit x = { foreach (i from ('n - 1) to 0 by 1 in dec) { print_int("idx = ", i); if [x[i]] == 0b1 then return(i) else () }; return(negate(1)) } Which is annotated as returning any int, we can synthesise a return type of {'m, ('m = -1 | (0 <= 'm & 'm <= ('n - 1))). int('m)} Currently I have this code in Sail as it's likely also useful as a optimisation/lint but it could also live in the asl_parser repository. --- src/return_analysis.ml | 182 +++++++++++++++++++++++++++++++++++++++++++++++++ src/type_check.ml | 2 +- 2 files changed, 183 insertions(+), 1 deletion(-) create mode 100644 src/return_analysis.ml (limited to 'src') diff --git a/src/return_analysis.ml b/src/return_analysis.ml new file mode 100644 index 00000000..f60366fc --- /dev/null +++ b/src/return_analysis.ml @@ -0,0 +1,182 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Ast_util +open Type_check + +let analyze_exp_returns exp = + let returns = ref [] in + let add_return annot = returns := annot :: !returns in + + print_endline ("\nAnalyzing " ^ string_of_exp exp); + + let rec analyze last (E_aux (e_aux, annot)) = + let env = env_of_annot annot in + match e_aux with + | E_block exps -> + begin match List.rev exps with + | [] -> () + | (exp :: exps) -> + List.iter (analyze false) exps; + analyze last exp + end + + | E_nondet exps -> List.iter (analyze last) exps + + | E_id id -> + if last then + add_return annot + else + () + + | E_lit _ when last -> + add_return annot + + | E_app _ when last -> + add_return annot + | E_app (_, exps) -> + List.iter (analyze false) exps + + | E_if (_, then_exp, else_exp) -> + analyze last then_exp; analyze last else_exp + + | E_return (E_aux (_, annot)) -> + add_return annot + + | E_for (_, exp1, exp2, exp3, _, body) -> + analyze false exp1; analyze false exp2; analyze false exp3; + analyze last body + + | _ -> () + in + analyze true exp; + + !returns + +type existential = + | Equal of nexp + | Constraint of (kid -> n_constraint) + | Anything + +let existentialize_annot funcl_annot annot = + let funcl_env = env_of_annot funcl_annot in + let env = env_of_annot annot in + match Env.expand_synonyms env (typ_of_annot annot) with + | (Typ_aux (Typ_app (ty_id, [Typ_arg_aux (Typ_arg_nexp nexp, _)]), _) as typ) + when Id.compare ty_id (mk_id "atom") = 0 -> + let tyvars = Env.get_typ_vars funcl_env |> KBindings.bindings in + let toplevel_kids = + List.filter (fun (kid, bk) -> match bk with BK_int -> true | _ -> false) tyvars |> List.map fst |> KidSet.of_list + in + let new_kids = KidSet.diff (tyvars_of_nexp nexp) toplevel_kids in + + if KidSet.cardinal new_kids = 0 then + Some (Equal nexp) + else if KidSet.cardinal new_kids = 1 then + let ex_kid = KidSet.min_elt new_kids in + (* Now we search for constraints that involve the existential + kid, and only reference toplevel type variables. *) + let constraints = List.concat (List.map constraint_conj (Env.get_constraints env)) in + let constraints = List.filter (fun nc -> KidSet.mem ex_kid (tyvars_of_constraint nc)) constraints in + let constraints = + List.filter (fun nc -> KidSet.subset (tyvars_of_constraint nc) (KidSet.add ex_kid toplevel_kids)) constraints + in + + match constraints with + | c :: cs -> + Some (Constraint (fun kid -> nc_subst_nexp ex_kid (Nexp_var kid) (List.fold_left nc_and c cs))) + | [] -> + Some Anything + else + Some Anything + | _ -> + None + +let union_existential ex1 ex2 = + match ex1, ex2 with + | Equal nexp1, Equal nexp2 -> + Constraint (fun kid -> nc_or (nc_eq (nvar kid) nexp1) (nc_eq (nvar kid) nexp2)) + + | Equal nexp, Constraint c -> + Constraint (fun kid -> nc_or (nc_eq (nvar kid) nexp) (c kid)) + + | Constraint c, Equal nexp -> + Constraint (fun kid -> nc_or (c kid) (nc_eq (nvar kid) nexp)) + + | _, _ -> Anything + +let typ_of_existential = function + | Anything -> int_typ + | Equal nexp -> atom_typ nexp + | Constraint c -> exist_typ c (fun kid -> atom_typ (nvar kid)) + +let analyze_def_returns = function + | DEF_fundef (FD_aux (FD_function (_, _, _, funcls), _)) -> + let analyze_funcls = function + | FCL_aux (FCL_Funcl (id, Pat_aux (Pat_exp (pat, exp), _)), funcl_annot) -> + let return_exs = + List.map (fun annot -> existentialize_annot funcl_annot annot) (analyze_exp_returns exp) + in + begin match Util.option_all return_exs with + | Some [] -> () + | Some (ex :: exs) -> + print_endline (string_of_typ (typ_of_existential (List.fold_left union_existential ex exs))) + | None -> () + end + + | _ -> () + in + List.iter analyze_funcls funcls + + | def -> () + +let analyze_returns (Defs defs) = List.iter analyze_def_returns defs + diff --git a/src/type_check.ml b/src/type_check.ml index 39842bc0..c32529e4 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -4186,7 +4186,7 @@ let check_mapcl : 'a. Env.t -> 'a mapcl -> typ -> tannot mapcl = MCL_aux (MCL_backwards (typed_mpexp, typed_exp), (l, Some ((env, typ, prop_effs), Some typ))) end end - | _ -> typ_error l ("Mapping clause must have mapping type: " ^ string_of_typ typ ^ " is not a mapping type") + | _ -> typ_error l ("Mapping clause must have mapping type: " ^ string_of_typ typ ^ " is not a mapping type") let funcl_effect (FCL_aux (FCL_Funcl (id, typed_pexp), (l, annot))) = match annot with -- cgit v1.2.3 From 0f5a5f2ccf60aad9e466517265f75e1e5b800889 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 5 Nov 2018 15:39:01 +0000 Subject: Make sure undefined_type functions are generated before registers When topologically sorting the top-level definitions, we add the undefined_X functions for any type X to a registers dependencies if it uses the type X, this ensures that any such functions are generated before the register declaration. In theory this is only needed for OCaml, but adding these edges in the definition graph shouldn't cause any issues. --- src/spec_analysis.ml | 11 +++++++++++ 1 file changed, 11 insertions(+) (limited to 'src') diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index fd43de16..75f55c9c 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -475,6 +475,8 @@ let fv_of_def consider_var consider_scatter_as_one all_defs = function List.fold_left Nameset.union Nameset.empty (List.map snd fvs) | DEF_scattered sdef -> fv_of_scattered consider_var consider_scatter_as_one all_defs sdef | DEF_reg_dec rdec -> fv_of_rd consider_var rdec + | DEF_constraint (id, _, _) -> + raise (Reporting.err_unreachable (id_loc id) __POS__ "Constraint should be re-written") let group_defs consider_scatter_as_one (Ast.Defs defs) = List.map (fun d -> (fv_of_def false consider_scatter_as_one defs d,d)) defs @@ -549,6 +551,15 @@ let scc ?(original_order : string list option) (g : graph) = let add_def_to_graph (prelude, original_order, defset, graph) d = let bound, used = fv_of_def false true [] d in + let used = match d with + | DEF_reg_dec _ -> + (* For a register, we need to ensure that any undefined_type + functions for types used by the register are placed before + the register declaration. *) + let undefineds = Nameset.map (fun name -> "undefined_" ^ name) used in + Nameset.union undefineds used + | _ -> used + in try (* A definition may bind multiple identifiers, e.g. "let (x, y) = ...". We add all identifiers to the dependency graph as a cycle. The actual -- cgit v1.2.3 From 21e94e35b56b86d56b720ac2a38d22020f41fc19 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 5 Nov 2018 16:55:13 +0000 Subject: Ensure type-synonyms are handled correctly in register dependencies We need to ensure that we expand type-synonyms when calculating which types a register depends on during topological sorting in order to place the undefined_type function in the correct place, even when type is indirected through a function. --- src/ast_util.ml | 7 +++++++ src/ast_util.mli | 1 + src/spec_analysis.ml | 29 ++++++++++++++++++++--------- 3 files changed, 28 insertions(+), 9 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index 61bc9ba3..f0b6508b 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -888,6 +888,13 @@ let id_of_type_def (TD_aux (td_aux, _)) = id_of_type_def_aux td_aux let id_of_val_spec (VS_aux (VS_val_spec (_, id, _, _), _)) = id +let id_of_dec_spec (DEC_aux (ds_aux, _)) = + match ds_aux with + | DEC_reg (_, id) -> id + | DEC_config (id, _, _) -> id + | DEC_alias (id, _) -> id + | DEC_typ_alias (_, id, _) -> id + let ids_of_def = function | DEF_kind (KD_aux (KD_nabbrev (_, id, _, _), _)) -> IdSet.singleton id | DEF_type td -> IdSet.singleton (id_of_type_def td) diff --git a/src/ast_util.mli b/src/ast_util.mli index f55cdf16..2a303475 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -232,6 +232,7 @@ val string_of_index_range : index_range -> string val id_of_fundef : 'a fundef -> id val id_of_type_def : 'a type_def -> id val id_of_val_spec : 'a val_spec -> id +val id_of_dec_spec : 'a dec_spec -> id val id_of_kid : kid -> id val kid_of_id : id -> kid diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index 75f55c9c..c858754e 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -447,15 +447,26 @@ let rec fv_of_scattered consider_var consider_scatter_as_one all_defs (SD_aux(sd else init_env name in init_env (name ^ "/end"), uses -let fv_of_rd consider_var (DEC_aux (d,_)) = match d with - | DEC_reg(t,id) -> - init_env (string_of_id id), fv_of_typ consider_var mt mt t - | DEC_config(id,t,exp) -> - init_env (string_of_id id), fv_of_typ consider_var mt mt t - | DEC_alias(id,alias) -> - init_env (string_of_id id),mt - | DEC_typ_alias(t,id,alias) -> - init_env (string_of_id id), mt +let fv_of_rd consider_var (DEC_aux (d, annot)) = + (* When we get the free variables of a register, we have to ensure + that we expand all synonyms so we can pick up dependencies with + undefined_type function, even when type is indirected through a + synonym. *) + let open Type_check in + let env = env_of_annot annot in + match d with + | DEC_reg(t, id) -> + let t' = Env.expand_synonyms env t in + init_env (string_of_id id), + Nameset.union (fv_of_typ consider_var mt mt t) (fv_of_typ consider_var mt mt t') + | DEC_config(id, t, exp) -> + let t' = Env.expand_synonyms env t in + init_env (string_of_id id), + Nameset.union (fv_of_typ consider_var mt mt t) (fv_of_typ consider_var mt mt t') + | DEC_alias(id, alias) -> + init_env (string_of_id id), mt + | DEC_typ_alias(t, id, alias) -> + init_env (string_of_id id), mt let fv_of_def consider_var consider_scatter_as_one all_defs = function | DEF_kind kdef -> fv_of_kind_def consider_var kdef -- cgit v1.2.3 From e8f8f3e65c9cb541712cec3c38de80f78d8fdedb Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 5 Nov 2018 18:37:40 +0000 Subject: Ensure function quantifier is in scope when generating C return type This goes partway to resolving issue #23, as it now generates C code, but it seems like there is still an issue with the generated C. --- src/c_backend.ml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/c_backend.ml b/src/c_backend.ml index 6dca1f8a..4e1bde7e 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -566,12 +566,15 @@ let cdef_ctyps ctx = function | CDEF_reg_dec (_, ctyp, instrs) -> ctyp :: List.concat (List.map instr_ctyps instrs) | CDEF_spec (_, ctyps, ctyp) -> ctyp :: ctyps | CDEF_fundef (id, _, _, instrs) -> - let _, Typ_aux (fn_typ, _) = Env.get_val_spec id ctx.tc_env in + let quant, Typ_aux (fn_typ, _) = Env.get_val_spec id ctx.tc_env in let arg_typs, ret_typ = match fn_typ with | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ | _ -> assert false in - let arg_ctyps, ret_ctyp = List.map (ctyp_of_typ ctx) arg_typs, ctyp_of_typ ctx ret_typ in + let arg_ctyps, ret_ctyp = + List.map (ctyp_of_typ ctx) arg_typs, + ctyp_of_typ { ctx with local_env = add_typquant (id_loc id) quant ctx.local_env } ret_typ + in ret_ctyp :: arg_ctyps @ List.concat (List.map instr_ctyps instrs) | CDEF_startup (id, instrs) | CDEF_finish (id, instrs) -> List.concat (List.map instr_ctyps instrs) -- cgit v1.2.3 From 18c49a76854408d7c2cea74eeb07fd312a5927aa Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Tue, 6 Nov 2018 17:57:58 +0000 Subject: Fix bug with loop indices not being mapped to int64 in C This should fix the issue in cheri128 Also introduce a feature to more easily debug the C backend: sail -dfunction Name will pretty-print the ANF and IR representation of just the Name function. I want to make this work for the type-checker as well, but it's a bit hard to get that to not fire during re-writing passes right now. --- src/c_backend.ml | 44 +++++++++++++++++++++++++++++++------------- src/c_backend.mli | 3 ++- src/sail.ml | 5 ++++- src/util.ml | 2 ++ src/util.mli | 1 + 5 files changed, 40 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/src/c_backend.ml b/src/c_backend.ml index 4e1bde7e..0c4ae87d 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -61,7 +61,8 @@ open Anf module Big_int = Nat_big_num let c_verbosity = ref 0 -let opt_ddump_flow_graphs = ref false +let opt_debug_flow_graphs = ref false +let opt_debug_function = ref "" let opt_trace = ref false let opt_static = ref false let opt_no_main = ref false @@ -357,6 +358,8 @@ let rec analyze_functions ctx f (AE_aux (aexp, env, l)) = let aexp2 = analyze_functions ctx f aexp2 in let aexp3 = analyze_functions ctx f aexp3 in let aexp4 = analyze_functions ctx f aexp4 in + (* Currently we assume that loop indexes are always safe to put into an int64 *) + let ctx = { ctx with locals = Bindings.add id (Immutable, CT_int64) ctx.locals } in AE_for (id, aexp1, aexp2, aexp3, order, aexp4) | AE_case (aval, cases, typ) -> @@ -1227,14 +1230,8 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = cleanup | AE_for (loop_var, loop_from, loop_to, loop_step, Ord_aux (ord, _), body) -> - (* This is a bit of a hack, we force loop_var to be CT_int64 by - forcing it's type to be a known nexp that will map to - CT_int64. *) - let make_small _ _ = function - | AV_id (id, Local (Immutable, typ)) when Id.compare id loop_var = 0 -> AV_id (id, Local (Immutable, atom_typ (nint 0))) - | aval -> aval - in - let body = map_aval make_small body in + (* We assume that all loop indices are safe to put in a CT_int64. *) + let ctx = { ctx with locals = Bindings.add loop_var (Immutable, CT_int64) ctx.locals } in let is_inc = match ord with | Ord_inc -> true @@ -1573,7 +1570,18 @@ let rec compile_def ctx = function let aexp = no_shadow (pat_ids pat) (anf exp) in c_debug (lazy (Pretty_print_sail.to_string (pp_aexp aexp))); let aexp = analyze_functions ctx analyze_primop (c_literals ctx aexp) in - c_debug (lazy (Pretty_print_sail.to_string (pp_aexp aexp))); + + if Id.compare (mk_id !opt_debug_function) id = 0 then + let header = + Printf.sprintf "Sail ANF for %s %s %s. (%s) -> %s" Util.("function" |> red |> clear) (string_of_id id) + (string_of_typquant quant) + Util.(string_of_list ", " (fun typ -> string_of_typ typ |> yellow |> clear) arg_typs) + Util.(string_of_typ ret_typ |> yellow |> clear) + + in + prerr_endline (Util.header header (List.length arg_typs + 2)); + prerr_endline (Pretty_print_sail.to_string (pp_aexp aexp)) + else (); (* Compile the function arguments as patterns. *) let arg_setup, compiled_args, arg_cleanup = compile_arg_pats ctx fundef_label pat arg_ctyps in @@ -2779,9 +2787,7 @@ let codegen_def' ctx = function string (Printf.sprintf "%svoid %s(%s *rop, %s);" static (sgen_id id) (sgen_ctyp ret_ctyp) (Util.string_of_list ", " sgen_ctyp arg_ctyps)) | CDEF_fundef (id, ret_arg, args, instrs) as def -> - if !opt_ddump_flow_graphs then make_dot id (instrs_graph instrs) else (); - - c_debug (lazy (Pretty_print_sail.to_string (separate_map hardline pp_instr instrs))); + if !opt_debug_flow_graphs then make_dot id (instrs_graph instrs) else (); (* Extract type information about the function from the environment. *) let quant, Typ_aux (fn_typ, _) = Env.get_val_spec id ctx.tc_env in @@ -2800,6 +2806,18 @@ let codegen_def' ctx = function ^ Util.string_of_list ", " string_of_ctyp arg_ctyps) else (); + (* If this function is set as opt_debug_function, then output its IR *) + if Id.compare (mk_id !opt_debug_function) id = 0 then + let header = + Printf.sprintf "Sail IR for %s %s(%s) : (%s) -> %s" Util.("function" |> red |> clear) (string_of_id id) + (Util.string_of_list ", " string_of_id args) + (Util.string_of_list ", " (fun ctyp -> Util.(string_of_ctyp ctyp |> yellow |> clear)) arg_ctyps) + Util.(string_of_ctyp ret_ctyp |> yellow |> clear) + in + prerr_endline (Util.header header (List.length arg_ctyps + 2)); + prerr_endline (Pretty_print_sail.to_string (separate_map hardline pp_instr instrs)) + else (); + let instrs = add_local_labels instrs in let args = Util.string_of_list ", " (fun x -> x) (List.map2 (fun ctyp arg -> sgen_ctyp ctyp ^ " " ^ sgen_id arg) arg_ctyps args) in let function_header = diff --git a/src/c_backend.mli b/src/c_backend.mli index 170c5bd9..6048f6b6 100644 --- a/src/c_backend.mli +++ b/src/c_backend.mli @@ -53,7 +53,8 @@ open Type_check (** Global compilation options *) -val opt_ddump_flow_graphs : bool ref +val opt_debug_flow_graphs : bool ref +val opt_debug_function : string ref val opt_trace : bool ref val opt_static : bool ref val opt_no_main : bool ref diff --git a/src/sail.ml b/src/sail.ml index 4fd35902..3505ecf4 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -223,7 +223,7 @@ let options = Arg.align ([ Arg.String (fun l -> opt_ddump_rewrite_ast := Some (l, 0)), " (debug) dump the ast after each rewriting step to _.lem"); ( "-ddump_flow_graphs", - Arg.Set C_backend.opt_ddump_flow_graphs, + Arg.Set C_backend.opt_debug_flow_graphs, " (debug) dump flow analysis for Sail functions when compiling to C"); ( "-dtc_verbose", Arg.Int (fun verbosity -> Type_check.opt_tc_debug := verbosity), @@ -237,6 +237,9 @@ let options = Arg.align ([ ( "-dmagic_hash", Arg.Set Initial_check.opt_magic_hash, " (debug) allow special character # in identifiers"); + ( "-dfunction", + Arg.String (fun f -> C_backend.opt_debug_function := f), + " (debug) print debugging output for a single function"); ( "-Xconstraint_synonyms", Arg.Set Type_check.opt_constraint_synonyms, " (extension) allow constraint synonyms"); diff --git a/src/util.ml b/src/util.ml index c0b88815..2e121a4f 100644 --- a/src/util.ml +++ b/src/util.ml @@ -455,3 +455,5 @@ let warn str = let log_line str line msg = "\n[" ^ (str ^ ":" ^ string_of_int line |> blue |> clear) ^ "] " ^ msg + +let header str n = "\n" ^ str ^ "\n" ^ String.make (String.length str - 9 * n) '=' diff --git a/src/util.mli b/src/util.mli index 5bb7c559..1d80bc10 100644 --- a/src/util.mli +++ b/src/util.mli @@ -260,3 +260,4 @@ val zencode_string : string -> string val zencode_upper_string : string -> string val log_line : string -> int -> string -> string +val header : string -> int -> string -- cgit v1.2.3 From 61e6bc97a7d5efb58f9b91738f1dd64404091137 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 7 Nov 2018 18:40:57 +0000 Subject: Move inline forall in function definitions * Previously we allowed the following bizarre syntax for a forall quantifier on a function: val foo(arg1: int('n), arg2: typ2) -> forall 'n, 'n >= 0. unit this commit changes this to the more sane: val foo forall 'n, 'n >= 2. (arg1: int('n), arg2: typ2) -> unit Having talked about it today, we could consider adding the syntax val foo where 'n >= 2. (arg1: int('n), arg2: typ2) -> unit which would avoid the forall (by implicitly quantifying variables in the constraint), and be slightly more friendly especially for documentation purposes. Only RISC-V used this syntax, so all uses of it there have been switched to the new style. * Second, there is a new (somewhat experimental) syntax for existentials, that is hopefully more readable and closer to minisail: val foo(x: int, y: int) -> int('m) with 'm >= 2 "type('n) with constraint" is equivalent to minisail: {'n: type | constraint} the type variables in typ are implicitly quantified, so this is equivalent to {'n, constraint. typ('n)} In order to make this syntax non-ambiguous we have to use == in constraints rather than =, but this is a good thing anyway because the previous situation where = was type level equality and == term level equality was confusing. Now all the type type-level and term-level operators can be consistent. However, to avoid breaking anything = is still allowed in non-with constraints, and produces a deprecated warning when parsed. --- src/initial_check.ml | 5 ++++ src/lexer.mll | 7 ++--- src/parse_ast.ml | 1 + src/parser.mly | 74 ++++++++++++++++++++++++++++++++++++++++------------ 4 files changed, 66 insertions(+), 21 deletions(-) (limited to 'src') diff --git a/src/initial_check.ml b/src/initial_check.ml index f98b11d8..897f3ec2 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -251,6 +251,11 @@ let rec to_ast_typ (k_env : kind Envmap.t) (def_ord : order) (t: Parse_ast.atyp) let k_env = List.fold_left Envmap.insert k_env (List.map (fun kid -> (var_to_string kid, {k=K_Nat})) kids) in let exist_typ = to_ast_typ k_env def_ord atyp in Typ_exist (kids, to_ast_nexp_constraint k_env nc, exist_typ) + | Parse_ast.ATyp_with (atyp, nc) -> + let exist_typ = to_ast_typ k_env def_ord atyp in + let kids = KidSet.elements (tyvars_of_typ exist_typ) in + let k_env = List.fold_left Envmap.insert k_env (List.map (fun kid -> (var_to_string kid, {k=K_Nat})) kids) in + Typ_exist (kids, to_ast_nexp_constraint k_env nc, exist_typ) | _ -> typ_error l "Required an item of kind Type, encountered an illegal form for this kind" None None None ), l) diff --git a/src/lexer.mll b/src/lexer.mll index 8b229772..de8eed7f 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -97,8 +97,7 @@ let operators = ref (List.fold_left (fun r (x, y) -> M.add x y r) M.empty - [ ("==", mk_operator Infix 4 "=="); - ("/", mk_operator InfixL 7 "/"); + [ ("/", mk_operator InfixL 7 "/"); ("%", mk_operator InfixL 7 "%"); ]) @@ -224,9 +223,7 @@ rule token = parse | "," { Comma } | ".." { DotDot } | "." { Dot } - | "==" as op - { try M.find op !operators - with Not_found -> raise (LexError ("Operator fixity undeclared " ^ op, Lexing.lexeme_start_p lexbuf)) } + | "==" { EqEq(r"==") } | "=" { (Eq(r"=")) } | ">" { (Gt(r">")) } | "-" { Minus } diff --git a/src/parse_ast.ml b/src/parse_ast.ml index d19e85ed..30f87bc3 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -156,6 +156,7 @@ atyp_aux = (* expressions of all kinds, to be translated to types, nats, orders | ATyp_tup of (atyp) list (* Tuple type *) | ATyp_app of id * (atyp) list (* type constructor application *) | ATyp_exist of kid list * n_constraint * atyp + | ATyp_with of atyp * n_constraint and atyp = ATyp_aux of atyp_aux * l diff --git a/src/parser.mly b/src/parser.mly index bd7c2f62..12286e13 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -197,6 +197,7 @@ let rec desugar_rchain chain s e = %token Amp At Caret Eq Gt Lt Plus Star EqGt Unit %token Colon ColonColon (* CaretCaret *) TildeTilde ExclEq +%token EqEq %token GtEq %token LtEq @@ -260,6 +261,7 @@ id: | Op Plus { mk_id (DeIid "+") $startpos $endpos } | Op Minus { mk_id (DeIid "-") $startpos $endpos } | Op Star { mk_id (DeIid "*") $startpos $endpos } + | Op EqEq { mk_id (DeIid "==") $startpos $endpos } | Op ExclEq { mk_id (DeIid "!=") $startpos $endpos } | Op Lt { mk_id (DeIid "<") $startpos $endpos } | Op Gt { mk_id (DeIid ">") $startpos $endpos } @@ -337,9 +339,12 @@ atomic_nc: { mk_nc NC_true $startpos $endpos } | False { mk_nc NC_false $startpos $endpos } - | typ Eq typ + | typ0 Eq typ0 + { Util.warn ("Deprecated syntax, use == instead at " ^ Reporting.loc_to_string (loc $startpos($2) $endpos($2)) ^ "\n"); + mk_nc (NC_equal ($1, $3)) $startpos $endpos } + | typ0 EqEq typ0 { mk_nc (NC_equal ($1, $3)) $startpos $endpos } - | typ ExclEq typ + | typ0 ExclEq typ0 { mk_nc (NC_not_equal ($1, $3)) $startpos $endpos } | nc_lchain { desugar_lchain $1 $startpos $endpos } @@ -350,6 +355,38 @@ atomic_nc: | kid In Lcurly num_list Rcurly { mk_nc (NC_set ($1, $4)) $startpos $endpos } +new_nc: + | new_nc Bar new_nc_and + { mk_nc (NC_or ($1, $3)) $startpos $endpos } + | nc_and + { $1 } + +new_nc_and: + | new_nc_and Amp new_atomic_nc + { mk_nc (NC_and ($1, $3)) $startpos $endpos } + | new_atomic_nc + { $1 } + +new_atomic_nc: + | Where id Lparen typ_list Rparen + { mk_nc (NC_app ($2, $4)) $startpos $endpos } + | True + { mk_nc NC_true $startpos $endpos } + | False + { mk_nc NC_false $startpos $endpos } + | typ0 EqEq typ0 + { mk_nc (NC_equal ($1, $3)) $startpos $endpos } + | typ0 ExclEq typ0 + { mk_nc (NC_not_equal ($1, $3)) $startpos $endpos } + | nc_lchain + { desugar_lchain $1 $startpos $endpos } + | nc_rchain + { desugar_rchain $1 $startpos $endpos } + | Lparen new_nc Rparen + { $2 } + | kid In Lcurly num_list Rcurly + { mk_nc (NC_set ($1, $4)) $startpos $endpos } + num_list: | Num { [$1] } @@ -357,28 +394,30 @@ num_list: { $1 :: $3 } nc_lchain: - | typ LtEq typ + | typ0 LtEq typ0 { [LC_nexp $1; LC_lteq; LC_nexp $3] } - | typ Lt typ + | typ0 Lt typ0 { [LC_nexp $1; LC_lt; LC_nexp $3] } - | typ LtEq nc_lchain + | typ0 LtEq nc_lchain { LC_nexp $1 :: LC_lteq :: $3 } - | typ Lt nc_lchain + | typ0 Lt nc_lchain { LC_nexp $1 :: LC_lt :: $3 } nc_rchain: - | typ GtEq typ + | typ0 GtEq typ0 { [RC_nexp $1; RC_gteq; RC_nexp $3] } - | typ Gt typ + | typ0 Gt typ0 { [RC_nexp $1; RC_gt; RC_nexp $3] } - | typ GtEq nc_rchain + | typ0 GtEq nc_rchain { RC_nexp $1 :: RC_gteq :: $3 } - | typ Gt nc_rchain + | typ0 Gt nc_rchain { RC_nexp $1 :: RC_gt :: $3 } typ: | typ0 { $1 } + | typ0 With new_nc + { mk_typ (ATyp_with ($1, $3)) $startpos $endpos } /* The following implements all nine levels of user-defined precedence for operators in types, with both left, right and non-associative operators */ @@ -677,8 +716,8 @@ pat_string_append: pat1: | atomic_pat { $1 } - | atomic_pat Bar pat1 - { mk_pat (P_or ($1, $3)) $startpos $endpos } + (* | atomic_pat Bar pat1 + { mk_pat (P_or ($1, $3)) $startpos $endpos } *) | atomic_pat At pat_concat { mk_pat (P_vector_concat ($1 :: $3)) $startpos $endpos } | atomic_pat ColonColon pat1 @@ -890,6 +929,7 @@ exp4: | exp5 LtEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id "<=") $startpos($2) $endpos($2), $3)) $startpos $endpos } | exp5 GtEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id ">=") $startpos($2) $endpos($2), $3)) $startpos $endpos } | exp5 ExclEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id "!=") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp5 EqEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id "==") $startpos($2) $endpos($2), $3)) $startpos $endpos } | exp4l op4l exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } | exp5 op4r exp4r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } | exp5 { $1 } @@ -1104,12 +1144,14 @@ funcl_patexp: funcl_patexp_typ: | pat Eq exp { (mk_pexp (Pat_exp ($1, $3)) $startpos $endpos, mk_tannotn) } - | pat MinusGt funcl_typ Eq exp - { (mk_pexp (Pat_exp ($1, $5)) $startpos $endpos, $3) } + | pat MinusGt typ Eq exp + { (mk_pexp (Pat_exp ($1, $5)) $startpos $endpos, mk_tannot mk_typqn $3 $startpos $endpos($3)) } + | Forall typquant Dot pat MinusGt typ Eq exp + { (mk_pexp (Pat_exp ($4, $8)) $startpos $endpos, mk_tannot $2 $6 $startpos $endpos($6)) } | Lparen pat If_ exp Rparen Eq exp { (mk_pexp (Pat_when ($2, $4, $7)) $startpos $endpos, mk_tannotn) } - | Lparen pat If_ exp Rparen MinusGt funcl_typ Eq exp - { (mk_pexp (Pat_when ($2, $4, $9)) $startpos $endpos, $7) } + | Forall typquant Dot Lparen pat If_ exp Rparen MinusGt typ Eq exp + { (mk_pexp (Pat_when ($5, $7, $12)) $startpos $endpos, mk_tannot $2 $10 $startpos $endpos($10)) } funcl: | id funcl_patexp -- cgit v1.2.3 From e06619625300a3bbf275f1cae6b327b6447f6625 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 7 Nov 2018 18:40:57 +0000 Subject: Move inline forall in function definitions * Previously we allowed the following bizarre syntax for a forall quantifier on a function: val foo(arg1: int('n), arg2: typ2) -> forall 'n, 'n >= 0. unit this commit changes this to the more sane: val foo forall 'n, 'n >= 2. (arg1: int('n), arg2: typ2) -> unit Having talked about it today, we could consider adding the syntax val foo where 'n >= 2. (arg1: int('n), arg2: typ2) -> unit which would avoid the forall (by implicitly quantifying variables in the constraint), and be slightly more friendly especially for documentation purposes. Only RISC-V used this syntax, so all uses of it there have been switched to the new style. * Second, there is a new (somewhat experimental) syntax for existentials, that is hopefully more readable and closer to minisail: val foo(x: int, y: int) -> int('m) with 'm >= 2 "type('n) with constraint" is equivalent to minisail: {'n: type | constraint} the type variables in typ are implicitly quantified, so this is equivalent to {'n, constraint. typ('n)} In order to make this syntax non-ambiguous we have to use == in constraints rather than =, but this is a good thing anyway because the previous situation where = was type level equality and == term level equality was confusing. Now all the type type-level and term-level operators can be consistent. However, to avoid breaking anything = is still allowed in non-with constraints, and produces a deprecated warning when parsed. --- src/initial_check.ml | 5 ++++ src/lexer.mll | 7 ++--- src/parse_ast.ml | 1 + src/parser.mly | 74 ++++++++++++++++++++++++++++++++++++++++------------ 4 files changed, 66 insertions(+), 21 deletions(-) (limited to 'src') diff --git a/src/initial_check.ml b/src/initial_check.ml index f98b11d8..897f3ec2 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -251,6 +251,11 @@ let rec to_ast_typ (k_env : kind Envmap.t) (def_ord : order) (t: Parse_ast.atyp) let k_env = List.fold_left Envmap.insert k_env (List.map (fun kid -> (var_to_string kid, {k=K_Nat})) kids) in let exist_typ = to_ast_typ k_env def_ord atyp in Typ_exist (kids, to_ast_nexp_constraint k_env nc, exist_typ) + | Parse_ast.ATyp_with (atyp, nc) -> + let exist_typ = to_ast_typ k_env def_ord atyp in + let kids = KidSet.elements (tyvars_of_typ exist_typ) in + let k_env = List.fold_left Envmap.insert k_env (List.map (fun kid -> (var_to_string kid, {k=K_Nat})) kids) in + Typ_exist (kids, to_ast_nexp_constraint k_env nc, exist_typ) | _ -> typ_error l "Required an item of kind Type, encountered an illegal form for this kind" None None None ), l) diff --git a/src/lexer.mll b/src/lexer.mll index 8b229772..de8eed7f 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -97,8 +97,7 @@ let operators = ref (List.fold_left (fun r (x, y) -> M.add x y r) M.empty - [ ("==", mk_operator Infix 4 "=="); - ("/", mk_operator InfixL 7 "/"); + [ ("/", mk_operator InfixL 7 "/"); ("%", mk_operator InfixL 7 "%"); ]) @@ -224,9 +223,7 @@ rule token = parse | "," { Comma } | ".." { DotDot } | "." { Dot } - | "==" as op - { try M.find op !operators - with Not_found -> raise (LexError ("Operator fixity undeclared " ^ op, Lexing.lexeme_start_p lexbuf)) } + | "==" { EqEq(r"==") } | "=" { (Eq(r"=")) } | ">" { (Gt(r">")) } | "-" { Minus } diff --git a/src/parse_ast.ml b/src/parse_ast.ml index d19e85ed..30f87bc3 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -156,6 +156,7 @@ atyp_aux = (* expressions of all kinds, to be translated to types, nats, orders | ATyp_tup of (atyp) list (* Tuple type *) | ATyp_app of id * (atyp) list (* type constructor application *) | ATyp_exist of kid list * n_constraint * atyp + | ATyp_with of atyp * n_constraint and atyp = ATyp_aux of atyp_aux * l diff --git a/src/parser.mly b/src/parser.mly index bd7c2f62..12286e13 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -197,6 +197,7 @@ let rec desugar_rchain chain s e = %token Amp At Caret Eq Gt Lt Plus Star EqGt Unit %token Colon ColonColon (* CaretCaret *) TildeTilde ExclEq +%token EqEq %token GtEq %token LtEq @@ -260,6 +261,7 @@ id: | Op Plus { mk_id (DeIid "+") $startpos $endpos } | Op Minus { mk_id (DeIid "-") $startpos $endpos } | Op Star { mk_id (DeIid "*") $startpos $endpos } + | Op EqEq { mk_id (DeIid "==") $startpos $endpos } | Op ExclEq { mk_id (DeIid "!=") $startpos $endpos } | Op Lt { mk_id (DeIid "<") $startpos $endpos } | Op Gt { mk_id (DeIid ">") $startpos $endpos } @@ -337,9 +339,12 @@ atomic_nc: { mk_nc NC_true $startpos $endpos } | False { mk_nc NC_false $startpos $endpos } - | typ Eq typ + | typ0 Eq typ0 + { Util.warn ("Deprecated syntax, use == instead at " ^ Reporting.loc_to_string (loc $startpos($2) $endpos($2)) ^ "\n"); + mk_nc (NC_equal ($1, $3)) $startpos $endpos } + | typ0 EqEq typ0 { mk_nc (NC_equal ($1, $3)) $startpos $endpos } - | typ ExclEq typ + | typ0 ExclEq typ0 { mk_nc (NC_not_equal ($1, $3)) $startpos $endpos } | nc_lchain { desugar_lchain $1 $startpos $endpos } @@ -350,6 +355,38 @@ atomic_nc: | kid In Lcurly num_list Rcurly { mk_nc (NC_set ($1, $4)) $startpos $endpos } +new_nc: + | new_nc Bar new_nc_and + { mk_nc (NC_or ($1, $3)) $startpos $endpos } + | nc_and + { $1 } + +new_nc_and: + | new_nc_and Amp new_atomic_nc + { mk_nc (NC_and ($1, $3)) $startpos $endpos } + | new_atomic_nc + { $1 } + +new_atomic_nc: + | Where id Lparen typ_list Rparen + { mk_nc (NC_app ($2, $4)) $startpos $endpos } + | True + { mk_nc NC_true $startpos $endpos } + | False + { mk_nc NC_false $startpos $endpos } + | typ0 EqEq typ0 + { mk_nc (NC_equal ($1, $3)) $startpos $endpos } + | typ0 ExclEq typ0 + { mk_nc (NC_not_equal ($1, $3)) $startpos $endpos } + | nc_lchain + { desugar_lchain $1 $startpos $endpos } + | nc_rchain + { desugar_rchain $1 $startpos $endpos } + | Lparen new_nc Rparen + { $2 } + | kid In Lcurly num_list Rcurly + { mk_nc (NC_set ($1, $4)) $startpos $endpos } + num_list: | Num { [$1] } @@ -357,28 +394,30 @@ num_list: { $1 :: $3 } nc_lchain: - | typ LtEq typ + | typ0 LtEq typ0 { [LC_nexp $1; LC_lteq; LC_nexp $3] } - | typ Lt typ + | typ0 Lt typ0 { [LC_nexp $1; LC_lt; LC_nexp $3] } - | typ LtEq nc_lchain + | typ0 LtEq nc_lchain { LC_nexp $1 :: LC_lteq :: $3 } - | typ Lt nc_lchain + | typ0 Lt nc_lchain { LC_nexp $1 :: LC_lt :: $3 } nc_rchain: - | typ GtEq typ + | typ0 GtEq typ0 { [RC_nexp $1; RC_gteq; RC_nexp $3] } - | typ Gt typ + | typ0 Gt typ0 { [RC_nexp $1; RC_gt; RC_nexp $3] } - | typ GtEq nc_rchain + | typ0 GtEq nc_rchain { RC_nexp $1 :: RC_gteq :: $3 } - | typ Gt nc_rchain + | typ0 Gt nc_rchain { RC_nexp $1 :: RC_gt :: $3 } typ: | typ0 { $1 } + | typ0 With new_nc + { mk_typ (ATyp_with ($1, $3)) $startpos $endpos } /* The following implements all nine levels of user-defined precedence for operators in types, with both left, right and non-associative operators */ @@ -677,8 +716,8 @@ pat_string_append: pat1: | atomic_pat { $1 } - | atomic_pat Bar pat1 - { mk_pat (P_or ($1, $3)) $startpos $endpos } + (* | atomic_pat Bar pat1 + { mk_pat (P_or ($1, $3)) $startpos $endpos } *) | atomic_pat At pat_concat { mk_pat (P_vector_concat ($1 :: $3)) $startpos $endpos } | atomic_pat ColonColon pat1 @@ -890,6 +929,7 @@ exp4: | exp5 LtEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id "<=") $startpos($2) $endpos($2), $3)) $startpos $endpos } | exp5 GtEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id ">=") $startpos($2) $endpos($2), $3)) $startpos $endpos } | exp5 ExclEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id "!=") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp5 EqEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id "==") $startpos($2) $endpos($2), $3)) $startpos $endpos } | exp4l op4l exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } | exp5 op4r exp4r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } | exp5 { $1 } @@ -1104,12 +1144,14 @@ funcl_patexp: funcl_patexp_typ: | pat Eq exp { (mk_pexp (Pat_exp ($1, $3)) $startpos $endpos, mk_tannotn) } - | pat MinusGt funcl_typ Eq exp - { (mk_pexp (Pat_exp ($1, $5)) $startpos $endpos, $3) } + | pat MinusGt typ Eq exp + { (mk_pexp (Pat_exp ($1, $5)) $startpos $endpos, mk_tannot mk_typqn $3 $startpos $endpos($3)) } + | Forall typquant Dot pat MinusGt typ Eq exp + { (mk_pexp (Pat_exp ($4, $8)) $startpos $endpos, mk_tannot $2 $6 $startpos $endpos($6)) } | Lparen pat If_ exp Rparen Eq exp { (mk_pexp (Pat_when ($2, $4, $7)) $startpos $endpos, mk_tannotn) } - | Lparen pat If_ exp Rparen MinusGt funcl_typ Eq exp - { (mk_pexp (Pat_when ($2, $4, $9)) $startpos $endpos, $7) } + | Forall typquant Dot Lparen pat If_ exp Rparen MinusGt typ Eq exp + { (mk_pexp (Pat_when ($5, $7, $12)) $startpos $endpos, mk_tannot $2 $10 $startpos $endpos($10)) } funcl: | id funcl_patexp -- cgit v1.2.3 From 953bfdd18c71bcd6c486aac74fe145104c3b2a4d Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 7 Nov 2018 18:56:28 +0000 Subject: Improvements to latex generation The main changes so far are: * Allow markdown formatting in doc comments. We parse the markdown using Omd, which is a OCaml library for parsing markdown. The nice thing about this library is it's pure OCaml and has no dependencies other the the stdlib. Incidentally it was also developed at OCaml labs. Using markdown keeps our doc-comments from becoming latex specfic, and having an actual parser is _much_ nicer than trying to hackily process latex in doc-comments using OCamls somewhat sub-par regex support. * More sane conversion latex identifiers the main approach is to convert Sail identifiers to lowerCamelCase, replacing numbers with words, and then add a 'category' code based on the type of identifier, so for a function we'd have fnlowerCamelCase and for type synonym typelowerCamelCase etc. Because this transformation is non-injective we keep track of identifiers we've generated so we end up with identifierA, identifierB, identifierC when there are collisions. * Because we parse markdown in doc comments doc comments can use Sail identifiers directly in hyperlinks, without having to care about how they are name-mangled down into TeX compatible things. * Allow directives to be passed through the compiler to backends. There are various $latex directives that modify the latex output. Most usefully there's a $latex newcommand name markdown directive that uses the markdown parser to generate latex commands. An example of why this is useful is bellow. We can also use $latex noref id To suppress automatically inserting links to an identifier * Refactor the latex generator to make the overall generation process cleaner * Work around the fact that some operating systems consider case-sensitive file names to be a good thing * Fix a bug where latex generation wouldn't occur unless the directory specified by -o didn't exist This isn't quite all the requested features for good CHERI documentation, but new features should be much easier to add now. --- src/_tags | 5 +- src/initial_check.ml | 4 +- src/isail.ml | 2 +- src/latex.ml | 380 +++++++++++++++++++++++++++++++++++++---------- src/pretty_print_sail.ml | 6 +- src/process_file.ml | 7 +- src/rewriter.ml | 2 + src/sail.ml | 20 ++- src/type_check.ml | 1 + src/util.ml | 8 + src/util.mli | 6 +- 11 files changed, 339 insertions(+), 102 deletions(-) (limited to 'src') diff --git a/src/_tags b/src/_tags index c5f4e127..826e87a5 100644 --- a/src/_tags +++ b/src/_tags @@ -1,11 +1,12 @@ true: -traverse, debug, use_menhir <**/*.ml>: bin_annot, annot -: package(zarith), package(linksem), package(lem), use_pprint -: package(zarith), package(linenoise), package(linksem), package(lem), use_pprint +: package(zarith), package(linksem), package(lem), package(omd), use_pprint +: package(zarith), package(linenoise), package(linksem), package(lem), package(omd), use_pprint : package(linenoise) : package(linksem) +: package(omd) <**/*.m{l,li}>: package(lem) : include diff --git a/src/initial_check.ml b/src/initial_check.ml index 897f3ec2..4dd72980 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -920,8 +920,8 @@ let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out let kids = List.map to_ast_var kids in let nc = to_ast_nexp_constraint k_env nc in ((Finished (DEF_constraint (id, kids, nc))), envs), partial_defs - | Parse_ast.DEF_pragma (_, _, l) -> - typ_error l "Encountered preprocessor directive in initial check" None None None + | Parse_ast.DEF_pragma (pragma, arg, l) -> + ((Finished(DEF_pragma (pragma, arg, l))), envs), partial_defs | Parse_ast.DEF_internal_mutrec _ -> (* Should never occur because of remove_mutrec *) typ_error Parse_ast.Unknown "Internal mutual block found when processing scattered defs" None None None diff --git a/src/isail.ml b/src/isail.ml index 7ec0848d..55f08f17 100644 --- a/src/isail.ml +++ b/src/isail.ml @@ -285,7 +285,7 @@ let handle_input' input = interactive_env := env; interactive_state := initial_state !interactive_ast Value.primops | ":pretty" -> - print_endline (Pretty_print_sail.to_string (Latex.latex_defs "sail_latex" !interactive_ast)) + print_endline (Pretty_print_sail.to_string (Latex.defs !interactive_ast)) | ":bytecode" -> let open PPrint in let open C_backend in diff --git a/src/latex.ml b/src/latex.ml index 4944c5e9..e5029e0e 100644 --- a/src/latex.ml +++ b/src/latex.ml @@ -51,51 +51,204 @@ open Ast open Ast_util open PPrint +open Printf -let opt_prefix_latex = ref "sail" +module StringSet = Set.Make(String);; -let replace_numbers str = - str - |> Str.global_replace (Str.regexp "0") "zero" - |> Str.global_replace (Str.regexp "1") "one" - |> Str.global_replace (Str.regexp "2") "two" - |> Str.global_replace (Str.regexp "3") "three" - |> Str.global_replace (Str.regexp "4") "four" - |> Str.global_replace (Str.regexp "5") "five" - |> Str.global_replace (Str.regexp "6") "six" - |> Str.global_replace (Str.regexp "7") "seven" - |> Str.global_replace (Str.regexp "8") "eight" - |> Str.global_replace (Str.regexp "9") "nine" - -let namecode_string str = - let str = Str.global_replace (Str.regexp "_") "" (Util.zencode_string str) in - replace_numbers (String.sub str 1 (String.length str - 1)) - -let namecode_id id = namecode_string (string_of_id id) +let opt_prefix = ref "sail" +let opt_directory = ref "sail_latex" + +let rec unique_postfix n = + if n < 0 then + "" + else if n >= 26 then + String.make 1 (Char.chr (n mod 26 + 65)) ^ unique_postfix (n - 26) + else + String.make 1 (Char.chr (n mod 26 + 65)) + +type latex_state = + { mutable noindent : bool; + mutable this : id option; + mutable norefs : StringSet.t; + mutable generated_names : string Bindings.t + } + +let reset_state state = + state.noindent <- false; + state.this <- None; + state.norefs <- StringSet.empty; + state.generated_names <- Bindings.empty + +let state = + { noindent = false; + this = None; + norefs = StringSet.empty; + generated_names = Bindings.empty + } + +let rec unique_postfix n = + if n < 0 then + "" + else if n >= 26 then + String.make 1 (Char.chr (n mod 26 + 65)) ^ unique_postfix (n - 26) + else + String.make 1 (Char.chr (n mod 26 + 65)) + +type id_category = + | Function + | Val + | Overload + | FunclCtor of id + | FunclNum of int + | FunclApp of string + +let category_name = function + | Function -> "fn" + | Val -> "val" + | Overload -> "overload" + | FunclNum n -> "fcl" ^ unique_postfix n + | FunclCtor id -> Util.zencode_string (string_of_id id) ^ "fcl" + | FunclApp str -> "fcl" ^ str + +(* Generate a unique latex identifier from a Sail identifier. We store + a mapping from identifiers to strings in state so we always return + the same latex id for a sail id. *) +let latex_id id = + if Bindings.mem id state.generated_names then + Bindings.find id state.generated_names + else + let str = string_of_id id in + let replacements = + [ ("0", "Zero"); + ("1", "One"); + ("2", "Two"); + ("3", "Three"); + ("4", "Four"); + ("5", "Five"); + ("6", "Six"); + ("7", "Seven"); + ("8", "Eight"); + ("9", "Nine") ] + in + let r = Str.regexp {|_\([a-zA-Z0-9]\)|} in + let str = + (* Convert to CamelCase. OCaml's regexp library is a bit arcane. *) + let str = ref str in + try + while true do + ignore (Str.search_forward r !str 0); + let replace = (Str.matched_group 0 !str).[1] |> Char.uppercase_ascii |> String.make 1 in + str := Str.replace_first r replace !str + done; "" + with Not_found -> !str + in + (* If we have any other weird symbols in the id, remove them using Util.zencode_string (removing the z prefix) *) + let str = Util.zencode_string str in + let str = String.sub str 1 (String.length str - 1) in + (* Latex only allows letters in identifiers, so replace all numbers *) + let str = List.fold_left (fun str (from, into) -> Str.global_replace (Str.regexp_string from) into str) str replacements in + + let generated = state.generated_names |> Bindings.bindings |> List.map snd |> StringSet.of_list in + + (* The above makes maps different names to the same name, so we need + to keep track of what names we've generated an ensure that they + remain unique. *) + let rec unique n str = + if StringSet.mem (str ^ unique_postfix n) generated then + unique (n + 1) str + else + str ^ unique_postfix n + in + let str = unique (-1) str in + state.generated_names <- Bindings.add id str state.generated_names; + str let refcode_string str = - replace_numbers (Str.global_replace (Str.regexp "_") "zy" (Util.zencode_string str)) + Str.global_replace (Str.regexp "_") "zy" (Util.zencode_string str) let refcode_id id = refcode_string (string_of_id id) +let inline_code str = sprintf "\\lstinline{%s}" str + +let text_code str = + str + |> Str.global_replace (Str.regexp_string "_") "\\_" + |> Str.global_replace (Str.regexp_string ">") "$<$" + |> Str.global_replace (Str.regexp_string "<") "$>$" + +let replace_this str = + match state.this with + | Some id -> + str + |> Str.global_replace (Str.regexp_string "NAME") (text_code (string_of_id id)) + |> Str.global_replace (Str.regexp_string "THIS") (inline_code (string_of_id id)) + | None -> str + +let latex_of_markdown str = + let open Omd in + let open Printf in + + let rec format_elem = function + | Paragraph elems -> + let prepend = if state.noindent then (state.noindent <- false; "\\noindent ") else "" in + prepend ^ format elems ^ "\n\n" + | Text str -> Str.global_replace (Str.regexp_string "_") "\\_" str + | Emph elems -> sprintf "\\emph{%s}" (format elems) + | Bold elems -> sprintf "\\textbf{%s}" (format elems) + | Ref (r, "THIS", alt, _) -> + begin match state.this with + | Some id -> sprintf "\\hyperref[%s]{%s}" (refcode_string (string_of_id id)) (replace_this alt) + | None -> failwith "Cannot create link to THIS" + end + | Ref (r, name, alt, _) -> + begin match r#get_ref name with + | None -> sprintf "\\hyperref[%s]{%s}" (refcode_string name) (replace_this alt) + | Some (link, _) -> sprintf "\\hyperref[%s]{%s}" (refcode_string link) (replace_this alt) + end + | Url (href, text, "") -> + sprintf "\\href{%s}{%s}" href (format text) + | Url (href, text, reference) -> + sprintf "%s\footnote{%s~\url{%s}}" (format text) reference href + | Code (_, code) -> + sprintf "\\lstinline`%s`" code + | Code_block (lang, code) -> + let lang = if lang = "" then "sail" else lang in + let uid = Digest.string str |> Digest.to_hex in + let chan = open_out (Filename.concat !opt_directory (sprintf "block%s.%s" uid lang)) in + output_string chan code; + close_out chan; + sprintf "\\lstinputlisting[language=%s]{%s/block%s.%s}" lang !opt_directory uid lang + | Ul list -> + "\\begin{itemize}\n\\item " + ^ Util.string_of_list "\n\\item " format list + ^ "\n\\end{itemize}" + | Br -> "\n" + | NL -> "\n" + | elem -> failwith ("Can't convert to latex: " ^ to_text [elem]) + + and format elems = + String.concat "" (List.map format_elem elems) + in + + replace_this (format (of_string str)) + let docstring = function - | Parse_ast.Documented (str, _) -> string str + | Parse_ast.Documented (str, _) -> string (latex_of_markdown str) | _ -> empty let add_links str = let r = Str.regexp {|\([a-zA-Z0-9_]+\)\([ ]*\)(|} in let subst s = - let module StringSet = Set.Make(String) in let keywords = StringSet.of_list [ "function"; "forall"; "if"; "then"; "else"; "exit"; "return"; "match"; "vector"; "assert"; "constraint"; "let"; "in"; "atom"; "range"; "throw"; "sizeof"; "foreach" ] in let fn = Str.matched_group 1 s in let spacing = Str.matched_group 2 s in - if StringSet.mem fn keywords then + if StringSet.mem fn keywords || StringSet.mem fn state.norefs then fn ^ spacing ^ "(" else - Printf.sprintf {|#\hyperref[%s]{%s}#%s(|} (refcode_string fn) (Str.global_replace (Str.regexp "_") {|\_|} fn) spacing + Printf.sprintf "#\\hyperref[%s]{%s}#%s(" (refcode_string fn) (Str.global_replace (Str.regexp "_") {|\_|} fn) spacing in Str.global_substitute r subst str @@ -116,30 +269,24 @@ let latex_loc no_loc l = | _ -> docstring l ^^ no_loc -module StringSet = Set.Make(String) - let commands = ref StringSet.empty -let rec latex_command ?prefix:(prefix="") ?label:(label=None) dir cmd no_loc ((l, _) as annot) = - let labelling = match label with - | None -> "" - | Some l -> Printf.sprintf "\\label{%s}" l +let rec latex_command cat id no_loc ((l, _) as annot) = + state.this <- Some id; + let labelling = match cat with + | Val -> sprintf "\\label{%s}" (refcode_id id) + | _ -> sprintf "\\label{%s%s}" (category_name cat) (refcode_id id) in - let cmd = !opt_prefix_latex ^ prefix ^ cmd in - let lcmd = String.lowercase_ascii cmd in (* lowercase to avoid file names differing only by case *) - if StringSet.mem lcmd !commands then - latex_command ~label:label dir (cmd ^ "v") no_loc annot - else - begin - commands := StringSet.add lcmd !commands; - let oc = open_out (Filename.concat dir (cmd ^ ".tex")) in - output_string oc (Pretty_print_sail.to_string (latex_loc no_loc l)); - close_out oc; - string (Printf.sprintf "\\newcommand{\\%s}{%s " cmd labelling) ^^ (docstring l) ^^ string (Printf.sprintf "\\lstinputlisting[language=sail]{%s/%s.tex}}" dir cmd) - end + (* To avoid problems with verbatim environments in commands, we have + to put the sail code for each command in a separate file. *) + let code_file = category_name cat ^ Util.file_encode_string (string_of_id id) ^ ".tex" in + let chan = open_out (Filename.concat !opt_directory code_file) in + output_string chan (Pretty_print_sail.to_string (latex_loc no_loc l)); + close_out chan; -let latex_command_id ?prefix:(prefix="") dir id no_loc annot = - latex_command ~prefix:prefix ~label:(Some (refcode_id id)) dir (namecode_id id) no_loc annot + ksprintf string "\\newcommand{\\sail%s%s}{\\phantomsection%s" (category_name cat) (latex_id id) labelling + ^^ docstring l + ^^ ksprintf string "\\lstinputlisting[language=sail]{%s}}" (Filename.concat !opt_directory code_file) let latex_label str id = string (Printf.sprintf "\\label{%s:%s}" str (Util.zencode_string (string_of_id id))) @@ -148,44 +295,113 @@ let counter = ref 0 let rec app_code (E_aux (exp, _)) = match exp with - | E_app (f, [exp]) -> namecode_id f ^ app_code exp - | E_app (f, _) -> namecode_id f - | E_id id -> namecode_id id + | E_app (f, [exp]) -> latex_id f ^ app_code exp + | E_app (f, _) -> latex_id f + | E_id id -> latex_id id | _ -> "" -let rec latex_funcls dir def = - let next funcls = twice hardline ^^ latex_funcls dir def funcls in - let funcl_command (FCL_Funcl (id, pexp)) = - match pexp with - | Pat_aux (Pat_exp (P_aux (P_app (ctor, _), _), _), _) -> namecode_id id ^ namecode_id ctor - | Pat_aux (Pat_exp (_, exp), _) -> namecode_id id ^ app_code exp - | _ -> (incr counter; namecode_id id ^ String.make 1 (Char.chr (!counter + 64))) +let latex_funcls def = + let counter = ref 0 in + + let rec latex_funcls' def = + let next funcls = twice hardline ^^ latex_funcls' def funcls in + let funcl_command (FCL_Funcl (id, pexp)) = + match pexp with + | Pat_aux (Pat_exp (P_aux (P_app (ctor, _), _), _), _) -> (FunclCtor ctor, id) + | Pat_aux (Pat_exp (_, exp), _) -> (FunclApp (app_code exp), id) + | _ -> incr counter; (FunclNum (!counter + 64), id) + in + function + | (FCL_aux (funcl_aux, annot) as funcl) :: funcls -> + let cat, id = funcl_command funcl_aux in + let first = latex_command cat id (Pretty_print_sail.doc_funcl funcl) annot in + first ^^ next funcls + | [] -> empty + in + latex_funcls' def + +let process_pragma l command = + let n = try String.index command ' ' with Not_found -> String.length command in + let cmd = Str.string_before command n in + let arg = String.trim (Str.string_after command n) in + + match cmd with + | "noindent" -> + state.noindent <- true; + None + + | "noref" -> + state.norefs <- StringSet.add arg state.norefs; + None + + | "newcommand" -> + let n = try String.index arg ' ' with Not_found -> failwith "No command given" in + let name = Str.string_before arg n in + let body = String.trim (latex_of_markdown (Str.string_after arg n)) in + Some (ksprintf string "\\newcommand{\\%s}{%s}" name body) + + | _ -> + Util.warn (Printf.sprintf "Bad latex pragma %s" (Reporting.loc_to_string l)); + None + +let defs (Defs defs) = + reset_state state; + + let valspecs = ref IdSet.empty in + let fundefs = ref IdSet.empty in + + let latex_def def = + match def with + | DEF_overload (id, ids) -> None + (* + let doc = + string (Printf.sprintf "overload %s = {%s}" (string_of_id id) (Util.string_of_list ", " string_of_id ids)) + in + Some (latex_command Overload id doc (id_loc id, None)) + *) + + | DEF_spec (VS_aux (VS_val_spec (_, id, _, _), annot)) as def -> + valspecs := IdSet.add id !valspecs; + Some (latex_command Val id (Pretty_print_sail.doc_def def) annot) + + | DEF_fundef (FD_aux (FD_function (_, _, _, [FCL_aux (FCL_Funcl (id, _), _)]), annot)) as def -> + fundefs := IdSet.add id !fundefs; + Some (latex_command Function id (Pretty_print_sail.doc_def def) annot) + + | DEF_fundef (FD_aux (FD_function (_, _, _, funcls), annot)) as def -> + Some (latex_funcls def funcls) + + | DEF_pragma ("latex", command, l) -> + process_pragma l command + + | _ -> None in - function - | (FCL_aux (funcl_aux, annot) as funcl) :: funcls -> - let first = latex_command ~prefix:"fn" dir (funcl_command funcl_aux) (Pretty_print_sail.doc_funcl funcl) annot in - first ^^ next funcls - | [] -> empty - -let rec latex_defs dir (Defs defs) = - let next defs = twice hardline ^^ latex_defs dir (Defs defs) in - match defs with - | DEF_overload (id, ids) :: defs -> - let doc = - string (Printf.sprintf "overload %s = {%s}" (string_of_id id) (Util.string_of_list ", " string_of_id ids)) - in - latex_command_id dir id doc (Parse_ast.Unknown, None) - ^^ next defs - | (DEF_type (TD_aux (TD_abbrev (id, _, _), annot)) as def) :: defs -> - latex_command_id dir id (Pretty_print_sail.doc_def def) annot ^^ next defs - | (DEF_type (TD_aux (TD_record (id, _, _, _, _), annot)) as def) :: defs -> - latex_command_id dir id (Pretty_print_sail.doc_def def) annot ^^ next defs - | (DEF_type (TD_aux (TD_enum (id, _, _, _), annot)) as def) :: defs -> - latex_command_id dir id (Pretty_print_sail.doc_def def) annot ^^ next defs - | (DEF_spec (VS_aux (VS_val_spec (_, id, _, _), annot)) as def) :: defs -> - latex_command_id dir id (Pretty_print_sail.doc_def def) annot ^^ next defs - | (DEF_fundef (FD_aux (FD_function (_, _, _, [FCL_aux (FCL_Funcl (id, _), _)]), annot)) as def) :: defs -> - latex_command_id dir ~prefix:"fn" id (Pretty_print_sail.doc_def def) annot ^^ next defs - | (DEF_fundef (FD_aux (FD_function (_, _, _, funcls), annot)) as def) :: defs -> latex_funcls dir def funcls ^^ next defs - | _ :: defs -> latex_defs dir (Defs defs) - | [] -> empty + + let rec process_defs = function + | [] -> empty + | def :: defs -> + let tex = match latex_def def with + | Some tex -> tex ^^ twice hardline + | None -> empty + in + tex ^^ process_defs defs + in + + let tex = process_defs defs in + + (* Rather than having latex functions that use mangled names, like + \sailfnmyFunction for a function my_function, we can write + \sailfn{my_function} by generating a latex macro that compares + identifiers then outputs the correct mangled command. *) + let id_command cat ids = + sprintf "\\newcommand{\\%s%s}[1]{\n " !opt_prefix (category_name cat) + ^ Util.string_of_list "%\n " (fun id -> sprintf "\\ifstrequal{#1}{%s}{\\sail%s%s}{}" (string_of_id id) (category_name cat) (latex_id id)) + (IdSet.elements ids) + ^ "}" + |> string + in + + tex + ^^ separate (twice hardline) [id_command Val !valspecs; + id_command Function !fundefs] + ^^ hardline diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index d71b32b2..c23b5ecc 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -567,7 +567,7 @@ let doc_typdef (TD_aux(td,_)) = match td with | _ -> string "TYPEDEF" -let doc_spec (VS_aux (v, annot)) = +let doc_spec ?comment:(comment=false) (VS_aux (v, annot)) = let doc_extern ext = let doc_backend b = Util.option_map (fun id -> string (b ^ ":") ^^ space ^^ utf8string ("\"" ^ String.escaped id ^ "\"")) (ext b) in @@ -576,7 +576,7 @@ let doc_spec (VS_aux (v, annot)) = in match v with | VS_val_spec(ts,id,ext,is_cast) -> - docstring annot + if comment then docstring annot else empty ^^ string "val" ^^ space ^^ (if is_cast then (string "cast" ^^ space) else empty) ^^ doc_id id ^^ space @@ -615,6 +615,8 @@ let rec doc_def def = group (match def with ^^ hardline ^^ string "}" | DEF_reg_dec dec -> doc_dec dec | DEF_scattered sdef -> doc_scattered sdef + | DEF_pragma (pragma, arg, l) -> + string ("$" ^ pragma ^ " " ^ arg) | DEF_fixity (prec, n, id) -> fixities := Bindings.add id (prec, Big_int.to_int n) !fixities; separate space [doc_prec prec; doc_int n; doc_id id] diff --git a/src/process_file.ml b/src/process_file.ml index bb789d0a..3788d269 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -75,7 +75,8 @@ let parse_file ?loc:(l=Parse_ast.Unknown) (f : string) : Parse_ast.defs = with | Parser.Error -> let pos = Lexing.lexeme_start_p lexbuf in - raise (Fatal_error (Err_syntax (pos, "no information"))) + let tok = Lexing.lexeme lexbuf in + raise (Fatal_error (Err_syntax (pos, "current token: " ^ tok))) | Lexer.LexError(s,p) -> raise (Fatal_error (Err_lex (p, s))) end @@ -204,8 +205,8 @@ let rec preprocess opts = function let help = "Make sure the filename is surrounded by quotes or angle brackets" in (Util.warn ("Skipping bad $include " ^ file ^ ". " ^ help); preprocess opts defs) - | Parse_ast.DEF_pragma (p, arg, _) :: defs -> - (Util.warn ("Bad pragma $" ^ p ^ " " ^ arg); preprocess opts defs) + | Parse_ast.DEF_pragma (p, arg, l) :: defs -> + Parse_ast.DEF_pragma (p, arg, l) :: preprocess opts defs (* realise any anonymous record arms of variants *) | Parse_ast.DEF_type (Parse_ast.TD_aux diff --git a/src/rewriter.ml b/src/rewriter.ml index cf04eef4..cf547307 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -358,6 +358,8 @@ let rewrite_def rewriters d = match d with | DEF_fundef fdef -> DEF_fundef (rewriters.rewrite_fun rewriters fdef) | DEF_internal_mutrec fdefs -> DEF_internal_mutrec (List.map (rewriters.rewrite_fun rewriters) fdefs) | DEF_val letbind -> DEF_val (rewriters.rewrite_let rewriters letbind) + | DEF_pragma (pragma, arg, l) -> DEF_pragma (pragma, arg, l) + | DEF_constraint _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "DEF_constraint survived to rewritter") | DEF_scattered _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "DEF_scattered survived to rewritter") let rewrite_defs_base rewriters (Defs defs) = diff --git a/src/sail.ml b/src/sail.ml index 3505ecf4..a7f780b9 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -167,7 +167,7 @@ let options = Arg.align ([ Arg.String (fun f -> Pretty_print_coq.opt_debug_on := f::!Pretty_print_coq.opt_debug_on), " produce debug messages for Coq output on given function"); ( "-latex_prefix", - Arg.String (fun prefix -> Latex.opt_prefix_latex := prefix), + Arg.String (fun prefix -> Latex.opt_prefix := prefix), " set a custom prefix for generated latex command (default sail)"); ( "-mono_split", Arg.String (fun s -> @@ -359,15 +359,19 @@ let main() = (if !(opt_print_latex) then begin + Util.opt_warnings := true; let latex_dir = match !opt_file_out with None -> "sail_latex" | Some s -> s in - try - if not (Sys.is_directory latex_dir) then begin - prerr_endline ("Failure: latex output directory exists but is not a directory: " ^ latex_dir); - exit 1 - end - with Sys_error(_) -> Unix.mkdir latex_dir 0o755; + begin + try + if not (Sys.is_directory latex_dir) then begin + prerr_endline ("Failure: latex output directory exists but is not a directory: " ^ latex_dir); + exit 1 + end + with Sys_error(_) -> Unix.mkdir latex_dir 0o755 + end; + Latex.opt_directory := latex_dir; let chan = open_out (Filename.concat latex_dir "commands.tex") in - output_string chan (Pretty_print_sail.to_string (Latex.latex_defs latex_dir ast)); + output_string chan (Pretty_print_sail.to_string (Latex.defs ast)); close_out chan end else ()); diff --git a/src/type_check.ml b/src/type_check.ml index c32529e4..46b67930 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -4483,6 +4483,7 @@ and check_def : 'a. Env.t -> 'a def -> (tannot def) list * Env.t = let checked_exp = crule check_exp env (strip_exp exp) typ in let env = Env.add_register id no_effect (mk_effect [BE_config]) typ env in [DEF_reg_dec (DEC_aux (DEC_config (id, typ, checked_exp), (l, Some ((env, typ, no_effect), Some typ))))], env + | DEF_pragma (pragma, arg, l) -> [DEF_pragma (pragma, arg, l)], env | DEF_reg_dec (DEC_aux (DEC_alias (id, aspec), (l, annot))) -> cd_err () | DEF_reg_dec (DEC_aux (DEC_typ_alias (typ, id, aspec), (l, tannot))) -> cd_err () | DEF_scattered _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Scattered given to type checker") diff --git a/src/util.ml b/src/util.ml index 2e121a4f..5e5654d1 100644 --- a/src/util.ml +++ b/src/util.ml @@ -448,6 +448,14 @@ let zencode_string str = "z" ^ List.fold_left (fun s1 s2 -> s1 ^ s2) "" (List.ma let zencode_upper_string str = "Z" ^ List.fold_left (fun s1 s2 -> s1 ^ s2) "" (List.map zchar (string_to_list str)) +(** Encode string for use as a filename. We can't use zencode directly + because some operating systems make the mistake of being + case-insensitive. *) +let file_encode_string str = + let zstr = zencode_string str in + let md5 = Digest.to_hex (Digest.string zstr) in + String.lowercase_ascii zstr ^ String.lowercase_ascii md5 + let warn str = if !opt_warnings then prerr_endline (("Warning" |> yellow |> clear) ^ ": " ^ str) diff --git a/src/util.mli b/src/util.mli index 1d80bc10..fd0242a3 100644 --- a/src/util.mli +++ b/src/util.mli @@ -57,8 +57,8 @@ val opt_colors : bool ref val butlast : 'a list -> 'a list (** Mixed useful things *) -module Duplicate(S : Set.S) : sig - type dups = +module Duplicate(S : Set.S) : sig + type dups = | No_dups of S.t | Has_dups of S.elt val duplicates : S.elt list -> dups @@ -259,5 +259,7 @@ val warn : string -> unit val zencode_string : string -> string val zencode_upper_string : string -> string +val file_encode_string : string -> string + val log_line : string -> int -> string -> string val header : string -> int -> string -- cgit v1.2.3 From a63c2e692792d69ae7ab9b9ef9b66ad2e5d2fe0b Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 12 Nov 2018 16:15:45 +0000 Subject: Improve latex naming scheme and avoid collisions --- src/latex.ml | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/latex.ml b/src/latex.ml index e5029e0e..f9154db2 100644 --- a/src/latex.ml +++ b/src/latex.ml @@ -107,7 +107,9 @@ let category_name = function | Val -> "val" | Overload -> "overload" | FunclNum n -> "fcl" ^ unique_postfix n - | FunclCtor id -> Util.zencode_string (string_of_id id) ^ "fcl" + | FunclCtor id -> + let str = Util.zencode_string (string_of_id id) in + "fcl" ^ String.sub str 1 (String.length str - 1) | FunclApp str -> "fcl" ^ str (* Generate a unique latex identifier from a Sail identifier. We store @@ -208,7 +210,7 @@ let latex_of_markdown str = | Url (href, text, "") -> sprintf "\\href{%s}{%s}" href (format text) | Url (href, text, reference) -> - sprintf "%s\footnote{%s~\url{%s}}" (format text) reference href + sprintf "%s\\footnote{%s~\\url{%s}}" (format text) reference href | Code (_, code) -> sprintf "\\lstinline`%s`" code | Code_block (lang, code) -> @@ -295,20 +297,28 @@ let counter = ref 0 let rec app_code (E_aux (exp, _)) = match exp with + | E_app (f, [exp]) when Id.compare f (mk_id "Some") = 0 -> app_code exp | E_app (f, [exp]) -> latex_id f ^ app_code exp | E_app (f, _) -> latex_id f | E_id id -> latex_id id | _ -> "" let latex_funcls def = + let module StringMap = Map.Make(String) in let counter = ref 0 in + let app_codes = ref StringMap.empty in let rec latex_funcls' def = + let counter = ref (-1) in let next funcls = twice hardline ^^ latex_funcls' def funcls in let funcl_command (FCL_Funcl (id, pexp)) = match pexp with | Pat_aux (Pat_exp (P_aux (P_app (ctor, _), _), _), _) -> (FunclCtor ctor, id) - | Pat_aux (Pat_exp (_, exp), _) -> (FunclApp (app_code exp), id) + | Pat_aux (Pat_exp (_, exp), _) -> + let ac = app_code exp in + let n = try StringMap.find ac !app_codes with Not_found -> -1 in + app_codes := StringMap.add ac (n + 1) !app_codes; + FunclApp (ac ^ unique_postfix n), id | _ -> incr counter; (FunclNum (!counter + 64), id) in function -- cgit v1.2.3 From 518776b45c4ad1f689bcd89ea6583c92583982a8 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 12 Nov 2018 16:32:59 +0000 Subject: Fix numbers in constructor arguments Also ensure no collisions for function clause constructor categories --- src/latex.ml | 43 +++++++++++++++++++++++++------------------ 1 file changed, 25 insertions(+), 18 deletions(-) (limited to 'src') diff --git a/src/latex.ml b/src/latex.ml index f9154db2..3c0ce03a 100644 --- a/src/latex.ml +++ b/src/latex.ml @@ -98,18 +98,33 @@ type id_category = | Function | Val | Overload - | FunclCtor of id + | FunclCtor of id * int | FunclNum of int | FunclApp of string +let replace_numbers str = + let replacements = + [ ("0", "Zero"); + ("1", "One"); + ("2", "Two"); + ("3", "Three"); + ("4", "Four"); + ("5", "Five"); + ("6", "Six"); + ("7", "Seven"); + ("8", "Eight"); + ("9", "Nine") ] + in + List.fold_left (fun str (from, into) -> Str.global_replace (Str.regexp_string from) into str) str replacements + let category_name = function | Function -> "fn" | Val -> "val" | Overload -> "overload" | FunclNum n -> "fcl" ^ unique_postfix n - | FunclCtor id -> - let str = Util.zencode_string (string_of_id id) in - "fcl" ^ String.sub str 1 (String.length str - 1) + | FunclCtor (id, n) -> + let str = replace_numbers (Util.zencode_string (string_of_id id)) in + "fcl" ^ String.sub str 1 (String.length str - 1) ^ unique_postfix n | FunclApp str -> "fcl" ^ str (* Generate a unique latex identifier from a Sail identifier. We store @@ -120,18 +135,6 @@ let latex_id id = Bindings.find id state.generated_names else let str = string_of_id id in - let replacements = - [ ("0", "Zero"); - ("1", "One"); - ("2", "Two"); - ("3", "Three"); - ("4", "Four"); - ("5", "Five"); - ("6", "Six"); - ("7", "Seven"); - ("8", "Eight"); - ("9", "Nine") ] - in let r = Str.regexp {|_\([a-zA-Z0-9]\)|} in let str = (* Convert to CamelCase. OCaml's regexp library is a bit arcane. *) @@ -148,7 +151,7 @@ let latex_id id = let str = Util.zencode_string str in let str = String.sub str 1 (String.length str - 1) in (* Latex only allows letters in identifiers, so replace all numbers *) - let str = List.fold_left (fun str (from, into) -> Str.global_replace (Str.regexp_string from) into str) str replacements in + let str = replace_numbers str in let generated = state.generated_names |> Bindings.bindings |> List.map snd |> StringSet.of_list in @@ -307,13 +310,17 @@ let latex_funcls def = let module StringMap = Map.Make(String) in let counter = ref 0 in let app_codes = ref StringMap.empty in + let ctors = ref Bindings.empty in let rec latex_funcls' def = let counter = ref (-1) in let next funcls = twice hardline ^^ latex_funcls' def funcls in let funcl_command (FCL_Funcl (id, pexp)) = match pexp with - | Pat_aux (Pat_exp (P_aux (P_app (ctor, _), _), _), _) -> (FunclCtor ctor, id) + | Pat_aux (Pat_exp (P_aux (P_app (ctor, _), _), _), _) -> + let n = try Bindings.find ctor !ctors with Not_found -> -1 in + ctors := Bindings.add ctor (n + 1) !ctors; + FunclCtor (ctor, n), id | Pat_aux (Pat_exp (_, exp), _) -> let ac = app_code exp in let n = try StringMap.find ac !app_codes with Not_found -> -1 in -- cgit v1.2.3 From f638a84add3ed60261bb86544e4332fd2180e1a6 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 12 Nov 2018 17:26:17 +0000 Subject: Add referencing commands to generated latex --- src/latex.ml | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/latex.ml b/src/latex.ml index 3c0ce03a..9b1e6da2 100644 --- a/src/latex.ml +++ b/src/latex.ml @@ -127,6 +127,10 @@ let category_name = function "fcl" ^ String.sub str 1 (String.length str - 1) ^ unique_postfix n | FunclApp str -> "fcl" ^ str +let category_name_val = function + | Val -> "" + | cat -> category_name cat + (* Generate a unique latex identifier from a Sail identifier. We store a mapping from identifiers to strings in state so we always return the same latex id for a sail id. *) @@ -417,8 +421,17 @@ let defs (Defs defs) = ^ "}" |> string in + let ref_command cat ids = + sprintf "\\newcommand{\\%sref%s}[2]{\n " !opt_prefix (category_name cat) + ^ Util.string_of_list "%\n " (fun id -> sprintf "\\ifstrequal{#1}{%s}{\\hyperref[%s%s]{#2}}{}" (string_of_id id) (category_name_val cat) (refcode_id id)) + (IdSet.elements ids) + ^ "}" + |> string + in tex ^^ separate (twice hardline) [id_command Val !valspecs; - id_command Function !fundefs] + ref_command Val !valspecs; + id_command Function !fundefs; + ref_command Function !fundefs] ^^ hardline -- cgit v1.2.3 From 76d5e3227d529f6ef23a822e498b476e9bccae5c Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 12 Nov 2018 20:39:17 +0000 Subject: Make type checker smarter at inferring l-expressions Previously the following would fail: ``` default Order dec $include register V : vector(1, dec, vector(32, dec, bit)) val zeros : forall 'n, 'n >= 0. unit -> vector('n, dec, bit) function main() : unit -> unit = { V[0] = zeros() } ``` Since the type-checker wouldn't see that zeros() must have type `vector(32, dec, bit)` from the type of `V[0]`. It now tries both to infer the expression, and use that to check the assignment, and if that fails we infer the lexp to check the assignment. This pattern occurs a lot in ASL, and we often had to patch zeros() to zeros(32) or similar there. --- src/type_check.ml | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/type_check.ml b/src/type_check.ml index c32529e4..716e6df5 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -2951,9 +2951,19 @@ and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as | _ -> assert false end | _ -> - let inferred_exp = irule infer_exp env exp in - let tlexp, env' = bind_lexp env lexp (typ_of inferred_exp) in - annot_assign tlexp inferred_exp, env' + (* Here we have two options, we can infer the type from the + expression, or we can infer the type from the + l-expression. Both are useful in different cases, so try + both. *) + try + let inferred_exp = irule infer_exp env exp in + let tlexp, env' = bind_lexp env lexp (typ_of inferred_exp) in + annot_assign tlexp inferred_exp, env' + with + | Type_error (_, _) -> + let inferred_lexp = infer_lexp env lexp in + let checked_exp = crule check_exp env exp (lexp_typ_of inferred_lexp) in + annot_assign inferred_lexp checked_exp, env and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = typ_print (lazy ("Binding mutable " ^ string_of_lexp lexp ^ " to " ^ string_of_typ typ)); -- cgit v1.2.3 From 7a0fba122b781a41de080e365c6d360f41117698 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 12 Nov 2018 20:54:27 +0000 Subject: Infer tuple l-expressions types if all components are inferrable This fixes another case we often have to patch manually in translated ASL code where a function returns a (result, Constraint)-pair. Also (slightly) improve the error message for when we fail to infer a l-expression, as we are going to hit this case more often now. --- src/type_check.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/type_check.ml b/src/type_check.ml index 716e6df5..e11505e5 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -3105,7 +3105,10 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) = in let typq, _, ret_typ, _ = Env.get_accessor rec_id fid env in annot_lexp_effect (LEXP_field (annot_lexp (LEXP_id v) (mk_id_typ rec_id), fid)) ret_typ weff - | _ -> typ_error l ("Unhandled l-expression " ^ string_of_lexp lexp) + | LEXP_tup lexps -> + let inferred_lexps = List.map (infer_lexp env) lexps in + annot_lexp (LEXP_tup inferred_lexps) (tuple_typ (List.map lexp_typ_of inferred_lexps)) + | _ -> typ_error l ("Could not infer the type of " ^ string_of_lexp lexp) and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = let annot_exp_effect exp typ eff = E_aux (exp, (l, Some ((env, typ, eff),None))) in -- cgit v1.2.3 From 60bcce4648ed029ca3c19c023f5ca525b43eced4 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Tue, 13 Nov 2018 18:54:35 +0000 Subject: Make pretty printer stricter with brace placement Also add a special case for shift-left when we are shifting 8 by a two bit opcode, or 32 by a one bit opcode. --- src/pretty_print_sail.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index d71b32b2..93693339 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -119,7 +119,7 @@ let doc_nc = match nc_aux with | NC_true -> string "true" | NC_false -> string "false" - | NC_equal (n1, n2) -> nc_op "=" n1 n2 + | NC_equal (n1, n2) -> nc_op "==" n1 n2 | NC_not_equal (n1, n2) -> nc_op "!=" n1 n2 | NC_bounded_ge (n1, n2) -> nc_op ">=" n1 n2 | NC_bounded_le (n1, n2) -> nc_op "<=" n1 n2 @@ -318,7 +318,8 @@ let fixities = let rec doc_exp (E_aux (e_aux, _) as exp) = match e_aux with | E_block [] -> string "()" - | E_block exps -> surround 2 0 lbrace (doc_block exps) rbrace + | E_block exps -> + group (lbrace ^^ nest 4 (hardline ^^ doc_block exps) ^^ hardline ^^ rbrace) | E_nondet exps -> assert false (* This is mostly for the -convert option *) | E_app_infix (x, id, y) when Id.compare (mk_id "quot") id == 0 -> -- cgit v1.2.3 From 0ea65cc4199e4a1924da93139c4790d9b85bb745 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Wed, 14 Nov 2018 15:32:45 +0000 Subject: latex: use callback macro saildocxxx (one per top-level category) to give usere more flexibility about formatting generated latex. --- src/latex.ml | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/latex.ml b/src/latex.ml index 9b1e6da2..e0dba234 100644 --- a/src/latex.ml +++ b/src/latex.ml @@ -131,6 +131,14 @@ let category_name_val = function | Val -> "" | cat -> category_name cat +let category_name_simple = function + | Function -> "fn" + | Val -> "val" + | Overload -> "overload" + | FunclNum _ -> "fcl" + | FunclCtor (_, _) -> "fcl" + | FunclApp _ -> "fcl" + (* Generate a unique latex identifier from a Sail identifier. We store a mapping from identifiers to strings in state so we always return the same latex id for a sail id. *) @@ -293,9 +301,9 @@ let rec latex_command cat id no_loc ((l, _) as annot) = output_string chan (Pretty_print_sail.to_string (latex_loc no_loc l)); close_out chan; - ksprintf string "\\newcommand{\\sail%s%s}{\\phantomsection%s" (category_name cat) (latex_id id) labelling - ^^ docstring l - ^^ ksprintf string "\\lstinputlisting[language=sail]{%s}}" (Filename.concat !opt_directory code_file) + ksprintf string "\\newcommand{\\sail%s%s}{\\phantomsection%s\\saildoc%s{" (category_name cat) (latex_id id) labelling (category_name_simple cat) + ^^ docstring l ^^ string "}{" + ^^ ksprintf string "\\lstinputlisting[language=sail]{%s}}}" (Filename.concat !opt_directory code_file) let latex_label str id = string (Printf.sprintf "\\label{%s:%s}" str (Util.zencode_string (string_of_id id))) -- cgit v1.2.3 From 5f00f0d75cfaabb89f2ec22115392443539664bd Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Wed, 14 Nov 2018 15:33:10 +0000 Subject: Use code style For [id] refs in doc comments. --- src/latex.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/latex.ml b/src/latex.ml index e0dba234..a86731b6 100644 --- a/src/latex.ml +++ b/src/latex.ml @@ -218,9 +218,11 @@ let latex_of_markdown str = | None -> failwith "Cannot create link to THIS" end | Ref (r, name, alt, _) -> + (* special case for [id] (format as code) *) + let format_fn = if name = alt then inline_code else replace_this in begin match r#get_ref name with - | None -> sprintf "\\hyperref[%s]{%s}" (refcode_string name) (replace_this alt) - | Some (link, _) -> sprintf "\\hyperref[%s]{%s}" (refcode_string link) (replace_this alt) + | None -> sprintf "\\hyperref[%s]{%s}" (refcode_string name) (format_fn alt) + | Some (link, _) -> sprintf "\\hyperref[%s]{%s}" (refcode_string link) (format_fn alt) end | Url (href, text, "") -> sprintf "\\href{%s}{%s}" href (format text) -- cgit v1.2.3 From c631ae96bbe9d659a8b3dbb1fc0c7ac812c2d43f Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Thu, 15 Nov 2018 15:13:06 +0000 Subject: ast_utils: simplify numeric constraints in inequalities. --- src/ast_util.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index f0b6508b..71b3299a 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -296,7 +296,10 @@ let rec constraint_simp (NC_aux (nc_aux, l)) = | NC_aux (nc, _), NC_aux (NC_true, _) -> NC_true | _, _ -> NC_or (nc1, nc2) end - + | NC_bounded_ge (nexp1, nexp2) -> + NC_bounded_ge (nexp_simp nexp1, nexp_simp nexp2) + | NC_bounded_le (nexp1, nexp2) -> + NC_bounded_le (nexp_simp nexp1, nexp_simp nexp2) | _ -> nc_aux in NC_aux (nc_aux, l) -- cgit v1.2.3 From 81ce65d8213b9dc26e204512408e6a340fe985fa Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Thu, 15 Nov 2018 17:12:37 +0000 Subject: Add simple valspec printing in latex that drops effects and other extraneous details (TODO make this optional). --- src/latex.ml | 12 +++++++++--- src/pretty_print_sail.ml | 25 ++++++++++++++----------- 2 files changed, 23 insertions(+), 14 deletions(-) (limited to 'src') diff --git a/src/latex.ml b/src/latex.ml index a86731b6..2f578f2c 100644 --- a/src/latex.ml +++ b/src/latex.ml @@ -290,6 +290,11 @@ let latex_loc no_loc l = let commands = ref StringSet.empty +let doc_spec_simple (VS_val_spec(ts,id,ext,is_cast)) = + Pretty_print_sail.doc_id id ^^ space + ^^ colon ^^ space + ^^ Pretty_print_sail.doc_typschm ~simple:true ts + let rec latex_command cat id no_loc ((l, _) as annot) = state.this <- Some id; let labelling = match cat with @@ -300,7 +305,8 @@ let rec latex_command cat id no_loc ((l, _) as annot) = to put the sail code for each command in a separate file. *) let code_file = category_name cat ^ Util.file_encode_string (string_of_id id) ^ ".tex" in let chan = open_out (Filename.concat !opt_directory code_file) in - output_string chan (Pretty_print_sail.to_string (latex_loc no_loc l)); + let doc = if cat = Val then no_loc else latex_loc no_loc l in + output_string chan (Pretty_print_sail.to_string doc); close_out chan; ksprintf string "\\newcommand{\\sail%s%s}{\\phantomsection%s\\saildoc%s{" (category_name cat) (latex_id id) labelling (category_name_simple cat) @@ -391,9 +397,9 @@ let defs (Defs defs) = Some (latex_command Overload id doc (id_loc id, None)) *) - | DEF_spec (VS_aux (VS_val_spec (_, id, _, _), annot)) as def -> + | DEF_spec (VS_aux (VS_val_spec (_, id, _, _) as vs, annot)) as def -> valspecs := IdSet.add id !valspecs; - Some (latex_command Val id (Pretty_print_sail.doc_def def) annot) + Some (latex_command Val id (doc_spec_simple vs) annot) | DEF_fundef (FD_aux (FD_function (_, _, _, [FCL_aux (FCL_Funcl (id, _), _)]), annot)) as def -> fundefs := IdSet.add id !fundefs; diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index c23b5ecc..7608f78b 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -113,7 +113,7 @@ let rec doc_nexp = in nexp0 -let doc_nc = +let doc_nc nc = let nc_op op n1 n2 = separate space [doc_nexp n1; string op; doc_nexp n2] in let rec atomic_nc (NC_aux (nc_aux, _) as nc) = match nc_aux with @@ -151,9 +151,9 @@ let doc_nc = | NC_and (c1, c2) -> separate space [nc1 c1; string "&"; atomic_nc c2] | _ -> atomic_nc nc in - nc0 + nc0 (constraint_simp nc) -let rec doc_typ (Typ_aux (typ_aux, l)) = +let rec doc_typ ?(simple=false) (Typ_aux (typ_aux, l)) = match typ_aux with | Typ_id id -> doc_id id | Typ_app (id, []) -> doc_id id @@ -177,7 +177,10 @@ let rec doc_typ (Typ_aux (typ_aux, l)) = separate space [doc_arg_typs typs; string "->"; doc_typ typ] | Typ_fn (typs, typ, Effect_aux (Effect_set effs, _)) -> let ocaml_eff = braces (separate (comma ^^ space) (List.map (fun be -> string (string_of_base_effect be)) effs)) in - separate space [doc_arg_typs typs; string "->"; doc_typ typ; string "effect"; ocaml_eff] + if simple then + separate space [doc_arg_typs typs; string "->"; doc_typ ~simple:simple typ] + else + separate space [doc_arg_typs typs; string "->"; doc_typ typ; string "effect"; ocaml_eff] | Typ_bidir (typ1, typ2) -> separate space [doc_typ typ1; string "<->"; doc_typ typ2] | Typ_internal_unknown -> raise (Reporting.err_unreachable l __POS__ "escaped Typ_internal_unknown") @@ -217,24 +220,24 @@ let doc_quants quants = | [nc] -> kdoc ^^ comma ^^ space ^^ doc_nc nc | nc :: ncs -> kdoc ^^ comma ^^ space ^^ doc_nc (List.fold_left nc_and nc ncs) -let doc_binding ((TypQ_aux (tq_aux, _) as typq), typ) = +let doc_binding ?(simple=false) ((TypQ_aux (tq_aux, _) as typq), typ) = match tq_aux with - | TypQ_no_forall -> doc_typ typ - | TypQ_tq [] -> doc_typ typ + | TypQ_no_forall -> doc_typ ~simple:simple typ + | TypQ_tq [] -> doc_typ ~simple:simple typ | TypQ_tq qs -> if !opt_use_heuristics && String.length (string_of_typquant typq) > 60 then let kopts, ncs = quant_split typq in if ncs = [] then string "forall" ^^ space ^^ separate_map space doc_kopt kopts ^^ dot - ^//^ doc_typ typ + ^//^ doc_typ ~simple:simple typ else string "forall" ^^ space ^^ separate_map space doc_kopt kopts ^^ comma ^//^ (separate_map (space ^^ string "&" ^^ space) doc_nc ncs ^^ dot - ^^ hardline ^^ doc_typ typ) + ^^ hardline ^^ doc_typ ~simple:simple typ) else - string "forall" ^^ space ^^ doc_quants qs ^^ dot ^//^ doc_typ typ + string "forall" ^^ space ^^ doc_quants qs ^^ dot ^//^ doc_typ ~simple:simple typ -let doc_typschm (TypSchm_aux (TypSchm_ts (typq, typ), _)) = doc_binding (typq, typ) +let doc_typschm ?(simple=false) (TypSchm_aux (TypSchm_ts (typq, typ), _)) = doc_binding ~simple:simple (typq, typ) let doc_typschm_typ (TypSchm_aux (TypSchm_ts (TypQ_aux (tq_aux, _), typ), _)) = doc_typ typ -- cgit v1.2.3 From 2a906e05a3313a25967833b10bb895db95d08165 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Thu, 15 Nov 2018 17:13:38 +0000 Subject: When outputing latex do not expand type synonyms in val specs during type check. --- src/sail.ml | 2 +- src/type_check.ml | 11 ++++++++++- src/type_check.mli | 4 ++++ 3 files changed, 15 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/sail.ml b/src/sail.ml index a7f780b9..9208190d 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -109,7 +109,7 @@ let options = Arg.align ([ Arg.String (fun s -> opt_ocaml_generators := s::!opt_ocaml_generators), " produce random generators for the given types"); ( "-latex", - Arg.Set opt_print_latex, + Arg.Tuple [Arg.Set opt_print_latex; Arg.Clear Type_check.opt_expand_valspec ], " pretty print the input to latex"); ( "-c", Arg.Tuple [Arg.Set opt_print_c; Arg.Set Initial_check.opt_undefined_gen], diff --git a/src/type_check.ml b/src/type_check.ml index 46b67930..4ad93a0c 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -73,6 +73,10 @@ let opt_no_lexp_bounds_check = ref false definitions *) let opt_constraint_synonyms = ref false +(* opt_expand_valspec expands typedefs in valspecs during type check. + We prefer not to do it for latex output but it is otherwise a good idea. *) +let opt_expand_valspec = ref true + let depth = ref 0 let rec indent n = match n with @@ -4337,7 +4341,12 @@ let check_val_spec env (VS_aux (vs, (l, _))) = in let env = Env.add_extern id ext_opt env in let env = if is_cast then Env.add_cast id env else env in - let typq, typ = expand_bind_synonyms ts_l env (typq, typ) in + let typq, typ = + if !opt_expand_valspec then + expand_bind_synonyms ts_l env (typq, typ) + else + (typq, typ) + in let vs = VS_val_spec (TypSchm_aux (TypSchm_ts (typq, typ), ts_l), id, ext_opt, is_cast) in (vs, id, typq, typ, env) in diff --git a/src/type_check.mli b/src/type_check.mli index 1cb54770..dc1cfe97 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -71,6 +71,10 @@ val opt_no_lexp_bounds_check : bool ref definitions *) val opt_constraint_synonyms : bool ref +(** opt_expand_valspec expands typedefs in valspecs during type check. + We prefer not to do it for latex output but it is otherwise a good idea. *) +val opt_expand_valspec : bool ref + (** {2 Type errors} *) type type_error = -- cgit v1.2.3 From b3ea287bcf8be43714595b6921a0c47d25a67eee Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Fri, 16 Nov 2018 16:26:35 +0000 Subject: Various bugfixes and a simple profiling feature for rewrites --- src/c_backend.ml | 10 ++++-- src/constraint.ml | 8 ++++- src/ocaml_backend.ml | 6 ++-- src/process_file.ml | 4 ++- src/profile.ml | 91 ++++++++++++++++++++++++++++++++++++++++++++++++++++ src/rewrites.ml | 7 ++-- src/sail.ml | 7 ++++ 7 files changed, 124 insertions(+), 9 deletions(-) create mode 100644 src/profile.ml (limited to 'src') diff --git a/src/c_backend.ml b/src/c_backend.ml index 0c4ae87d..97477163 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -306,7 +306,9 @@ let rec c_aval ctx = function else v (* id's type went from heap -> stack due to flow typing, so it's really still heap allocated! *) with - Not_found -> failwith ("could not find " ^ string_of_id id ^ " in local variables") + (* Hack: Assuming global letbindings don't change from flow typing... *) + Not_found -> AV_C_fragment (F_id id, typ) + (* failwith ("could not find " ^ string_of_id id ^ " in local variables") *) end | Register (_, _, typ) when is_stack_typ ctx typ -> AV_C_fragment (F_id id, typ) @@ -427,9 +429,11 @@ let analyze_primop' ctx id args typ = | _ -> no_change end + (* | "vector_subrange", [AV_C_fragment (vec, _); AV_C_fragment (f, _); AV_C_fragment (t, _)] when is_stack_typ ctx typ -> let len = F_op (f, "-", F_op (t, "-", v_one)) in AE_val (AV_C_fragment (F_op (F_call ("safe_rshift", [F_raw "UINT64_MAX"; F_op (v_int 64, "-", len)]), "&", F_op (vec, ">>", t)), typ)) + *) | "vector_access", [AV_C_fragment (vec, _); AV_C_fragment (n, _)] -> AE_val (AV_C_fragment (F_op (v_one, "&", F_op (vec, ">>", n)), typ)) @@ -437,8 +441,10 @@ let analyze_primop' ctx id args typ = | "eq_bit", [AV_C_fragment (a, _); AV_C_fragment (b, _)] -> AE_val (AV_C_fragment (F_op (a, "==", b), typ)) + (* | "slice", [AV_C_fragment (vec, _); AV_C_fragment (start, _); AV_C_fragment (len, _)] -> AE_val (AV_C_fragment (F_op (F_call ("safe_rshift", [F_raw "UINT64_MAX"; F_op (v_int 64, "-", len)]), "&", F_op (vec, ">>", start)), typ)) + *) | "undefined_bit", _ -> AE_val (AV_C_fragment (F_lit (V_bit Sail2_values.B0), typ)) @@ -2727,7 +2733,7 @@ let codegen_vector ctx (direction, ctyp) = ^^ string (Printf.sprintf " rop->data = malloc(len * sizeof(%s));\n" (sgen_ctyp ctyp)) ^^ (if not (is_stack_ctyp ctyp) then string " for (int i = 0; i < len; i++) {\n" - ^^ string (Printf.sprintf " CREATE(%s)((rop->data) + i);\n" (sgen_ctyp ctyp)) + ^^ string (Printf.sprintf " CREATE(%s)((rop->data) + i);\n" (sgen_ctyp_name ctyp)) ^^ string " }\n" else empty) ^^ string "}" diff --git a/src/constraint.ml b/src/constraint.ml index d66705b6..cf861423 100644 --- a/src/constraint.ml +++ b/src/constraint.ml @@ -219,7 +219,7 @@ let save_digests () = DigestMap.iter output !known_problems; close_out out_chan -let rec call_z3 constraints : smt_result = +let call_z3' constraints : smt_result = let problems = [constraints] in let z3_file = smtlib_of_constraints constraints in @@ -261,6 +261,12 @@ let rec call_z3 constraints : smt_result = else (known_problems := DigestMap.add digest Unknown !known_problems; Unknown) end +let call_z3 constraints = + let t = Profile.start_z3 () in + let result = call_z3' constraints in + Profile.finish_z3 t; + result + let rec solve_z3 constraints var = let problems = [constraints] in let z3_file = smtlib_of_constraints ~get_model:true constraints in diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index 3ad4c07f..9a48421a 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -359,10 +359,10 @@ and ocaml_assignment ctx (LEXP_aux (lexp_aux, _) as lexp) exp = else ocaml_atomic_exp ctx exp in separate space [zencode ctx id; string ":="; traced_exp] - | _ -> separate space [zencode ctx id; string ":="; ocaml_exp ctx exp] + | _ -> separate space [zencode ctx id; string ":="; parens (ocaml_exp ctx exp)] end | LEXP_deref ref_exp -> - separate space [ocaml_atomic_exp ctx ref_exp; string ":="; ocaml_exp ctx exp] + separate space [ocaml_atomic_exp ctx ref_exp; string ":="; parens (ocaml_exp ctx exp)] | _ -> string ("LEXP<" ^ string_of_lexp lexp ^ ">") and ocaml_lexp ctx (LEXP_aux (lexp_aux, _) as lexp) = match lexp_aux with @@ -933,7 +933,7 @@ let ocaml_main spec sail_dir = @ [ " zinitializze_registers ();"; if !opt_trace_ocaml then " Sail_lib.opt_trace := true;" else " ();"; " Printexc.record_backtrace true;"; - " try zmain () with _ -> prerr_endline(\"Exiting due to uncaught exception\")\n";]) + " try zmain () with exn -> prerr_endline(\"Exiting due to uncaught exception:\\n\" ^ Printexc.to_string exn)\n";]) |> String.concat "\n" let ocaml_pp_defs f defs generator_types = diff --git a/src/process_file.ml b/src/process_file.ml index bb789d0a..53293849 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -364,8 +364,10 @@ let output libpath out_arg files = output1 libpath out_arg f defs) files -let rewrite_step defs (name,rewriter) = +let rewrite_step defs (name, rewriter) = + let t = Profile.start () in let defs = rewriter defs in + Profile.finish ("rewrite " ^ name) t; let _ = match !(opt_ddump_rewrite_ast) with | Some (f, i) -> begin diff --git a/src/profile.ml b/src/profile.ml new file mode 100644 index 00000000..cb374403 --- /dev/null +++ b/src/profile.ml @@ -0,0 +1,91 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +let opt_profile = ref false + +type profile = { + z3_calls : int; + z3_time : float + } + +let new_profile = { + z3_calls = 0; + z3_time = 0.0 + } + +let profile_stack = ref [] + +let update_profile f = + match !profile_stack with + | [] -> () + | (p :: ps) -> + profile_stack := f p :: ps + +let start_z3 () = + update_profile (fun p -> { p with z3_calls = p.z3_calls + 1 }); + Sys.time () + +let finish_z3 t = + update_profile (fun p -> { p with z3_time = p.z3_time +. (Sys.time () -. t) }) + +let start () = + profile_stack := new_profile :: !profile_stack; + Sys.time () + +let finish msg t = + if !opt_profile then + begin match !profile_stack with + | p :: ps -> + prerr_endline (Printf.sprintf "%s %s: %fs" Util.("Profile" |> magenta |> clear) msg (Sys.time () -. t)); + prerr_endline (Printf.sprintf " Z3 calls: %d, Z3 time: %fs" p.z3_calls p.z3_time); + profile_stack := ps + | [] -> () + end + else () diff --git a/src/rewrites.ml b/src/rewrites.ml index c274ded4..591b86a7 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2591,7 +2591,10 @@ let rewrite_tuple_assignments defs = let (_, ids) = List.fold_left (fun (n, ids) _ -> (n + 1, ids @ [mk_id ("tup__" ^ string_of_int n)])) (0, []) lexps in let block_assign i lexp = mk_exp (E_assign (strip_lexp lexp, mk_exp (E_id (mk_id ("tup__" ^ string_of_int i))))) in let block = mk_exp (E_block (List.mapi block_assign lexps)) in - let letbind = mk_letbind (mk_pat (P_tup (List.map (fun id -> mk_pat (P_id id)) ids))) (strip_exp exp) in + let letbind = mk_letbind (mk_pat (P_typ (Type_check.typ_of exp, + mk_pat (P_tup (List.map (fun id -> mk_pat (P_id id)) ids))))) + (strip_exp exp) + in let let_exp = mk_exp (E_let (letbind, block)) in begin try check_exp env let_exp unit_typ with @@ -2641,7 +2644,7 @@ let rewrite_defs_remove_blocks = let e_aux = function | (E_block es,(l,_)) -> f l es | (e,annot) -> E_aux (e,annot) in - + let alg = { id_exp_alg with e_aux = e_aux } in rewrite_defs_base diff --git a/src/sail.ml b/src/sail.ml index 3505ecf4..df095e0e 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -240,6 +240,9 @@ let options = Arg.align ([ ( "-dfunction", Arg.String (fun f -> C_backend.opt_debug_function := f), " (debug) print debugging output for a single function"); + ( "-dprofile", + Arg.Set Profile.opt_profile, + " (debug) provides basic profiling information for rewriting passes within Sail"); ( "-Xconstraint_synonyms", Arg.Set Type_check.opt_constraint_synonyms, " (extension) allow constraint synonyms"); @@ -265,14 +268,18 @@ let interactive_env = ref Type_check.initial_env let load_files type_envs files = if !opt_memo_z3 then Constraint.load_digests () else (); + let t = Profile.start () in let parsed = List.map (fun f -> (f, parse_file f)) files in let ast = List.fold_right (fun (_, Parse_ast.Defs ast_nodes) (Parse_ast.Defs later_nodes) -> Parse_ast.Defs (ast_nodes@later_nodes)) parsed (Parse_ast.Defs []) in let ast = Process_file.preprocess_ast options ast in let ast = convert_ast Ast_util.inc_ord ast in + Profile.finish "parsing" t; + let t = Profile.start () in let (ast, type_envs) = check_ast type_envs ast in + Profile.finish "type checking" t; let ast = rewrite_ast ast in -- cgit v1.2.3 From 626c68dad5ea79da7776b4628e5ae22ca742669e Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Fri, 16 Nov 2018 18:28:17 +0000 Subject: Canonicalise functions types in val specs This brings Sail closer to MiniSail, and means that type my_range 'n 'm = {'o, 'n <= 'o <= 'm. int('o)} will work on the left hand side of a function type in the same way as a regular built-in range type. This means that in principle neither range nor int need be built-in types, as both can be implemented in terms of int('n) (atom internally). It also means we can easily identify type variables that need to be made into implict arguments, with the criterion for that being simply any type variable that doesn't appear in a base type on the LHS of the function, or only appears on the RHS. --- src/ast_util.ml | 7 +++++++ src/ast_util.mli | 2 ++ src/pretty_print_sail.ml | 17 ++++++++------- src/type_check.ml | 54 ++++++++++++++++++++++++++++++++++++++++-------- 4 files changed, 63 insertions(+), 17 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index f0b6508b..037fd1a7 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -399,6 +399,13 @@ let mk_effect effs = let no_effect = mk_effect [] +let quant_add qi typq = + match qi, typq with + | QI_aux (QI_const (NC_aux (NC_true, _)), _), _ -> typq + | QI_aux (QI_id _, _), TypQ_aux (TypQ_tq qis, l) -> TypQ_aux (TypQ_tq (qi :: qis), l) + | QI_aux (QI_const nc, _), TypQ_aux (TypQ_tq qis, l) -> TypQ_aux (TypQ_tq (qis @ [qi]), l) + | _, TypQ_aux (TypQ_no_forall, l) -> TypQ_aux (TypQ_tq [qi], l) + let quant_items : typquant -> quant_item list = function | TypQ_aux (TypQ_tq qis, _) -> qis | TypQ_aux (TypQ_no_forall, _) -> [] diff --git a/src/ast_util.mli b/src/ast_util.mli index 2a303475..8f555744 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -175,6 +175,8 @@ val nc_int_set : kid -> int list -> n_constraint de-morgans to switch and to or and vice versa. *) val nc_negate : n_constraint -> n_constraint +(* Functions for working with type quantifiers *) +val quant_add : quant_item -> typquant -> typquant val quant_items : typquant -> quant_item list val quant_kopts : typquant -> kinded_id list val quant_split : typquant -> kinded_id list * n_constraint list diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index 93693339..31b1ed85 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -68,7 +68,7 @@ let doc_kid kid = string (Ast_util.string_of_kid kid) let doc_int n = string (Big_int.to_string n) let docstring (l, _) = match l with - | Parse_ast.Documented (str, _) -> string "/**" ^^ string str ^^ string "*/" ^^ hardline + | Parse_ast.Documented (str, _) -> string "/*!" ^^ string str ^^ string "*/" ^^ hardline | _ -> empty let doc_ord (Ord_aux(o,_)) = match o with @@ -483,13 +483,14 @@ let doc_funcl (FCL_aux (FCL_Funcl (id, Pat_aux (pexp,_)), _)) = let doc_default (DT_aux (DT_order ord, _)) = separate space [string "default"; string "Order"; doc_ord ord] -let doc_fundef (FD_aux (FD_function (r, typa, efa, funcls), _)) = - match funcls with - | [] -> failwith "Empty function list" - | _ -> - let sep = hardline ^^ string "and" ^^ space in - let clauses = separate_map sep doc_funcl funcls in - string "function" ^^ space ^^ clauses +let doc_fundef (FD_aux (FD_function (r, typa, efa, funcls), annot)) = + docstring annot + ^^ match funcls with + | [] -> failwith "Empty function list" + | _ -> + let sep = hardline ^^ string "and" ^^ space in + let clauses = separate_map sep doc_funcl funcls in + string "function" ^^ space ^^ clauses let rec doc_mpat (MP_aux (mp_aux, _) as mpat) = match mp_aux with diff --git a/src/type_check.ml b/src/type_check.ml index e11505e5..aa2d3473 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -754,17 +754,52 @@ end = struct with | Not_found -> typ_error (id_loc id) ("No val spec found for " ^ string_of_id id) + let ex_counter = ref 0 + + (* TODO: Currently this is duplicated with destruct_exist outside of Env and deals with val spec arguments only. *) + let fresh_existential ?name:(n="") () = + let fresh = Kid_aux (Var ("'all" ^ string_of_int !ex_counter ^ "#" ^ n), Parse_ast.Unknown) in + incr ex_counter; fresh + + let destruct_exist env typ = + match expand_synonyms env typ with + | Typ_aux (Typ_exist (kids, nc, typ), _) -> + let fresh_kids = List.map (fun kid -> (kid, fresh_existential ~name:(string_of_id (id_of_kid kid)) ())) kids in + let nc = List.fold_left (fun nc (kid, fresh) -> nc_subst_nexp kid (Nexp_var fresh) nc) nc fresh_kids in + let typ = List.fold_left (fun typ (kid, fresh) -> typ_subst_nexp kid (Nexp_var fresh) typ) typ fresh_kids in + Some (List.map snd fresh_kids, nc, typ) + | _ -> None + let rec update_val_spec id (typq, typ) env = - begin - let typ = expand_synonyms env typ in - let typq = expand_typquant_synonyms env typq in - typ_print (lazy (adding ^ "val spec " ^ string_of_id id ^ " : " ^ string_of_bind (typq, typ))); - let env = match typ with - | Typ_aux (Typ_bidir (typ1, typ2), _) -> add_mapping id (typq, typ1, typ2) env - | _ -> env - in - { env with top_val_specs = Bindings.add id (typq, typ) env.top_val_specs } + begin match expand_synonyms env typ with + | Typ_aux (Typ_fn (arg_typs, ret_typ, effect), l) -> + (* We perform some canonicalisation for function types where existentials appear on the left, so + ({'n, 'n >= 2, int('n)}, foo) -> bar + would become + forall 'n, 'n >= 2. (int('n), foo) -> bar + this enforces the invariant that all things on the left of functions are 'base types' (i.e. without existentials) + *) + let typq = expand_typquant_synonyms env typq in + let base_args = List.map (destruct_exist env) arg_typs in + let existential_arg typq = function + | None -> typq + | Some (exs, nc, _) -> + List.fold_left (fun typq kid -> quant_add (mk_qi_id BK_int kid) typq) (quant_add (mk_qi_nc nc) typq) exs + in + let typq = List.fold_left existential_arg typq base_args in + let arg_typs = List.map2 (fun typ -> function Some (_, _, typ) -> typ | None -> typ) arg_typs base_args in + let typ = Typ_aux (Typ_fn (arg_typs, ret_typ, effect), l) in + typ_print (lazy (adding ^ "val " ^ string_of_id id ^ " : " ^ string_of_bind (typq, typ))); + { env with top_val_specs = Bindings.add id (typq, typ) env.top_val_specs } + + | Typ_aux (Typ_bidir (typ1, typ2), l) -> + let env = add_mapping id (typq, typ1, typ2) env in + typ_print (lazy (adding ^ "mapping " ^ string_of_id id ^ " : " ^ string_of_bind (typq, typ))); + { env with top_val_specs = Bindings.add id (typq, typ) env.top_val_specs } + + | _ -> typ_error (id_loc id) "val definition must have a mapping or function type" end + and add_val_spec id (bind_typq, bind_typ) env = if not (Bindings.mem id env.top_val_specs) then update_val_spec id (bind_typq, bind_typ) env @@ -776,6 +811,7 @@ end = struct typ_error (id_loc id) ("Identifier " ^ string_of_id id ^ " is already bound as " ^ string_of_bind (existing_typq, existing_typ) ^ ", cannot rebind as " ^ string_of_bind (bind_typq, bind_typ)) else env + and add_mapping id (typq, typ1, typ2) env = begin typ_print (lazy (adding ^ "mapping " ^ string_of_id id)); -- cgit v1.2.3 From e313c717efec50676fb101df1cd399b2c376dc2b Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 19 Nov 2018 16:00:26 +0000 Subject: Ensure sizeof re-writing occurs for configuration registers --- src/rewrites.ml | 3 +++ 1 file changed, 3 insertions(+) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index 591b86a7..53a20465 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -649,6 +649,9 @@ let rewrite_sizeof (Defs defs) = LB_val (pat, exp') in (params_map, defs @ [DEF_val (LB_aux (lb', annot))]) end + | DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp), annot)) -> + let exp' = fst (fold_exp { copy_exp_alg with e_aux = e_app_aux params_map } exp) in + (params_map, defs @ [DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp'), annot))]) | def -> (params_map, defs @ [def]) in -- cgit v1.2.3 From 4b8f3092b2c9767b916535ad73e045262d60d987 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 19 Nov 2018 17:14:19 +0000 Subject: Don't re-check AST repeatedly in exp_lift_assign re-write This was _really_ slow - about 50secs for ARM. If this changes causes breakages we should fix them in some other way. Also using Reporting.err_unreachable in ANF translation, and fix slice optimization when creating slices larger than 64-bits in C translation --- src/anf.ml | 26 +++++++------ src/c_backend.ml | 4 +- src/reporting.ml | 2 +- src/rewrites.ml | 113 +++---------------------------------------------------- 4 files changed, 21 insertions(+), 124 deletions(-) (limited to 'src') diff --git a/src/anf.ml b/src/anf.ml index 4b22b9ad..50f3ccba 100644 --- a/src/anf.ml +++ b/src/anf.ml @@ -57,9 +57,6 @@ open PPrint module Big_int = Nat_big_num -let anf_error ?loc:(l=Parse_ast.Unknown) message = - raise (Reporting.err_general l ("\nANF translation: " ^ message)) - (**************************************************************************) (* 1. Conversion to A-normal form (ANF) *) (**************************************************************************) @@ -453,7 +450,8 @@ let rec split_block l = function | exp :: exps -> let exps, last = split_block l exps in exp :: exps, last - | [] -> anf_error ~loc:l "empty block" + | [] -> + raise (Reporting.err_unreachable l __POS__ "empty block found when converting to ANF") let rec anf_pat ?global:(global=false) (P_aux (p_aux, annot) as pat) = let mk_apat aux = AP_aux (aux, env_of_annot annot, fst annot) in @@ -469,7 +467,9 @@ let rec anf_pat ?global:(global=false) (P_aux (p_aux, annot) as pat) = | P_cons (hd_pat, tl_pat) -> mk_apat (AP_cons (anf_pat ~global:global hd_pat, anf_pat ~global:global tl_pat)) | P_list pats -> List.fold_right (fun pat apat -> mk_apat (AP_cons (anf_pat ~global:global pat, apat))) pats (mk_apat (AP_nil (typ_of_pat pat))) | P_lit (L_aux (L_unit, _)) -> mk_apat (AP_wild (typ_of_pat pat)) - | _ -> anf_error ~loc:(fst annot) ("Could not convert pattern to ANF: " ^ string_of_pat pat) + | _ -> + raise (Reporting.err_unreachable (fst annot) __POS__ + ("Could not convert pattern to ANF: " ^ string_of_pat pat)) let rec apat_globals (AP_aux (aux, _, _)) = match aux with @@ -529,7 +529,8 @@ let rec anf (E_aux (e_aux, ((l, _) as exp_annot)) as exp) = mk_aexp (AE_assign (id, lvar_typ (Env.lookup_id id (env_of exp)), aexp)) | E_assign (lexp, _) -> - failwith ("Encountered complex l-expression " ^ string_of_lexp lexp ^ " when converting to ANF") + raise (Reporting.err_unreachable l __POS__ + ("Encountered complex l-expression " ^ string_of_lexp lexp ^ " when converting to ANF")) | E_loop (loop_typ, cond, exp) -> let acond = anf cond in @@ -665,7 +666,8 @@ let rec anf (E_aux (e_aux, ((l, _) as exp_annot)) as exp) = mk_aexp (AE_let (Mutable, id, lvar_typ lvar, anf binding, anf body, typ_of exp)) | E_var (lexp, _, _) -> - failwith ("Encountered complex l-expression " ^ string_of_lexp lexp ^ " when converting to ANF") + raise (Reporting.err_unreachable l __POS__ + ("Encountered complex l-expression " ^ string_of_lexp lexp ^ " when converting to ANF")) | E_let (LB_aux (LB_val (pat, binding), _), body) -> anf (E_aux (E_case (binding, [Pat_aux (Pat_exp (pat, body), (Parse_ast.Unknown, empty_tannot))]), exp_annot)) @@ -690,19 +692,19 @@ let rec anf (E_aux (e_aux, ((l, _) as exp_annot)) as exp) = | E_vector_access _ | E_vector_subrange _ | E_vector_update _ | E_vector_update_subrange _ | E_vector_append _ -> (* Should be re-written by type checker *) - failwith "encountered raw vector operation when converting to ANF" + raise (Reporting.err_unreachable l __POS__ "encountered raw vector operation when converting to ANF") | E_internal_value _ -> (* Interpreter specific *) - failwith "encountered E_internal_value when converting to ANF" + raise (Reporting.err_unreachable l __POS__ "encountered E_internal_value when converting to ANF") | E_sizeof _ | E_constraint _ -> (* Sizeof nodes removed by sizeof rewriting pass *) - failwith "encountered E_sizeof or E_constraint node when converting to ANF" + raise (Reporting.err_unreachable l __POS__ "encountered E_sizeof or E_constraint node when converting to ANF") | E_nondet _ -> (* We don't compile E_nondet nodes *) - failwith "encountered E_nondet node when converting to ANF" + raise (Reporting.err_unreachable l __POS__ "encountered E_nondet node when converting to ANF") | E_internal_return _ | E_internal_plet _ -> - failwith "encountered unexpected internal node when converting to ANF" + raise (Reporting.err_unreachable l __POS__ "encountered unexpected internal node when converting to ANF") diff --git a/src/c_backend.ml b/src/c_backend.ml index 97477163..b198c340 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -441,10 +441,8 @@ let analyze_primop' ctx id args typ = | "eq_bit", [AV_C_fragment (a, _); AV_C_fragment (b, _)] -> AE_val (AV_C_fragment (F_op (a, "==", b), typ)) - (* - | "slice", [AV_C_fragment (vec, _); AV_C_fragment (start, _); AV_C_fragment (len, _)] -> + | "slice", [AV_C_fragment (vec, _); AV_C_fragment (start, _); AV_C_fragment (len, _)] when is_stack_typ ctx typ -> AE_val (AV_C_fragment (F_op (F_call ("safe_rshift", [F_raw "UINT64_MAX"; F_op (v_int 64, "-", len)]), "&", F_op (vec, ">>", start)), typ)) - *) | "undefined_bit", _ -> AE_val (AV_C_fragment (F_lit (V_bit Sail2_values.B0), typ)) diff --git a/src/reporting.ml b/src/reporting.ml index 358a99a8..3f5f1627 100644 --- a/src/reporting.ml +++ b/src/reporting.ml @@ -254,7 +254,7 @@ let issues = "\n\nPlease report this as an issue on GitHub at https://github.com let dest_err = function | Err_general (l, m) -> ("Error", false, Loc l, m) | Err_unreachable (l, (file, line, _, _), m) -> - ((Printf.sprintf "Internal error: Unreachable code (at \"%s\" line %d)" file line), false, Loc l, m ^ issues) + ((Printf.sprintf "Internal error: Unreachable code (at \"%s\" line %d)\n" file line), false, Loc l, m ^ issues) | Err_todo (l, m) -> ("Todo" ^ m, false, Loc l, "") | Err_syntax (p, m) -> ("Syntax error", false, Pos p, m) | Err_syntax_locn (l, m) -> ("Syntax error", false, Loc l, m) diff --git a/src/rewrites.ml b/src/rewrites.ml index 53a20465..f10c0059 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -1739,6 +1739,7 @@ let updates_vars exp = (u || lexp_is_local lexp (env_of exp), E_assign (lexp, exp)) in fst (fold_exp { (compute_exp_alg false (||)) with e_assign = e_assign } exp) + (*Expects to be called after rewrite_defs; thus the following should not appear: internal_exp of any form lit vectors in patterns or expressions @@ -1762,72 +1763,18 @@ let rewrite_exp_lift_assign_intro rewriters ((E_aux (exp,((l,_) as annot))) as f let effects = union_eff_exps exps' in let block = E_aux (E_block exps', (gen_loc l, mk_tannot env unit_typ effects)) in [fix_eff_exp (E_aux (E_var(le', e', block), annot))] - (*| ((E_aux(E_if(c,t,e),(l,annot))) as exp)::exps -> - let vars_t = introduced_variables t in - let vars_e = introduced_variables e in - let new_vars = Envmap.intersect vars_t vars_e in - if Envmap.is_empty new_vars - then (rewrite_base exp)::walker exps - else - let new_nmap = match nmap with - | None -> Some(Nexpmap.empty,new_vars) - | Some(nm,s) -> Some(nm, Envmap.union new_vars s) in - let c' = rewrite_base c in - let t' = rewriters.rewrite_exp rewriters new_nmap t in - let e' = rewriters.rewrite_exp rewriters new_nmap e in - let exps' = walker exps in - fst ((Envmap.fold - (fun (res,effects) i (t,e) -> - let bitlit = E_aux (E_lit (L_aux(L_zero, Parse_ast.Generated l)), - (Parse_ast.Generated l, simple_annot bit_t)) in - let rangelit = E_aux (E_lit (L_aux (L_num 0, Parse_ast.Generated l)), - (Parse_ast.Generated l, simple_annot nat_t)) in - let set_exp = - match t.t with - | Tid "bit" | Tabbrev(_,{t=Tid "bit"}) -> bitlit - | Tapp("range", _) | Tapp("atom", _) -> rangelit - | Tapp("vector", [_;_;_;TA_typ ( {t=Tid "bit"} | {t=Tabbrev(_,{t=Tid "bit"})})]) - | Tapp(("reg"|"register"),[TA_typ ({t = Tapp("vector", - [_;_;_;TA_typ ( {t=Tid "bit"} - | {t=Tabbrev(_,{t=Tid "bit"})})])})]) - | Tabbrev(_,{t = Tapp("vector", - [_;_;_;TA_typ ( {t=Tid "bit"} - | {t=Tabbrev(_,{t=Tid "bit"})})])}) -> - E_aux (E_vector_indexed([], Def_val_aux(Def_val_dec bitlit, - (Parse_ast.Generated l,simple_annot bit_t))), - (Parse_ast.Generated l, simple_annot t)) - | _ -> e in - let unioneffs = union_effects effects (get_effsum_exp set_exp) in - ([E_aux (E_var (LEXP_aux (LEXP_id (Id_aux (Id i, Parse_ast.Generated l)), - (Parse_ast.Generated l, (tag_annot t Emp_intro))), - set_exp, - E_aux (E_block res, (Parse_ast.Generated l, (simple_annot_efr unit_t effects)))), - (Parse_ast.Generated l, simple_annot_efr unit_t unioneffs))],unioneffs))) - (E_aux(E_if(c',t',e'),(Parse_ast.Generated l, annot))::exps',eff_union_exps (c'::t'::e'::exps')) new_vars)*) | e::exps -> (rewrite_rec e)::(walker exps) in - check_exp (env_of full_exp) - (E_aux (E_block (List.map strip_exp (walker exps)), (l, ()))) (typ_of full_exp) + E_aux (E_block (walker exps), annot) + | E_assign(le,e) when lexp_is_local_intro le (env_of full_exp) && not (lexp_is_effectful le) -> let (le', re') = rewrite_lexp_to_rhs le in let e' = re' (rewrite_base e) in let block = annot_exp (E_block []) (gen_loc l) (env_of full_exp) unit_typ in - check_exp (env_of full_exp) - (strip_exp (E_aux (E_var(le', e', block), annot))) (typ_of full_exp) - | _ -> rewrite_base full_exp - -(*let rewrite_lexp_lift_assign_intro rewriters ((LEXP_aux(lexp,annot)) as le) = - let rewrap le = LEXP_aux(le,annot) in - let rewrite_base = rewrite_lexp rewriters in - match lexp, annot with - | (LEXP_id id | LEXP_cast (_,id)), (l, Some (env, typ, eff)) -> - (match Env.lookup_id id env with - | Unbound | Local _ -> - LEXP_aux (lexp, (l, Some (env, typ, union_effects eff (mk_effect [BE_lset])))) - | _ -> rewrap lexp) - | _ -> rewrite_base le*) + E_aux (E_var (le', e', block), annot) + | _ -> rewrite_base full_exp let rewrite_defs_exp_lift_assign defs = rewrite_defs_base {rewrite_exp = rewrite_exp_lift_assign_intro; @@ -1869,56 +1816,6 @@ let rewrite_register_ref_writes (Defs defs) = | [] -> [] in Defs (rewrite (write_reg_spec @ defs)) - (* rewrite_defs_base { rewriters_base with rewrite_exp = rewrite_exp } - (Defs (write_reg_spec @ defs)) *) - - -(*let rewrite_exp_separate_ints rewriters ((E_aux (exp,((l,_) as annot))) as full_exp) = - (*let tparms,t,tag,nexps,eff,cum_eff,bounds = match annot with - | Base((tparms,t),tag,nexps,eff,cum_eff,bounds) -> tparms,t,tag,nexps,eff,cum_eff,bounds - | _ -> [],unit_t,Emp_local,[],pure_e,pure_e,nob in*) - let rewrap e = E_aux (e,annot) in - (*let rewrap_effects e effsum = - E_aux (e,(l,Base ((tparms,t),tag,nexps,eff,effsum,bounds))) in*) - let rewrite_rec = rewriters.rewrite_exp rewriters in - let rewrite_base = rewrite_exp rewriters in - match exp with - | E_lit (L_aux (((L_num _) as lit),_)) -> - (match (is_within_machine64 t nexps) with - | Yes -> let _ = Printf.eprintf "Rewriter of num_const, within 64bit int yes\n" in rewrite_base full_exp - | Maybe -> let _ = Printf.eprintf "Rewriter of num_const, within 64bit int maybe\n" in rewrite_base full_exp - | No -> let _ = Printf.eprintf "Rewriter of num_const, within 64bit int no\n" in E_aux(E_app(Id_aux (Id "integer_of_int",l),[rewrite_base full_exp]), - (l, Base((tparms,t),External(None),nexps,eff,cum_eff,bounds)))) - | E_cast (typ, exp) -> rewrap (E_cast (typ, rewrite_rec exp)) - | E_app (id,exps) -> rewrap (E_app (id,List.map rewrite_rec exps)) - | E_app_infix(el,id,er) -> rewrap (E_app_infix(rewrite_rec el,id,rewrite_rec er)) - | E_for (id, e1, e2, e3, o, body) -> - rewrap (E_for (id, rewrite_rec e1, rewrite_rec e2, rewrite_rec e3, o, rewrite_rec body)) - | E_vector_access (vec,index) -> rewrap (E_vector_access (rewrite_rec vec,rewrite_rec index)) - | E_vector_subrange (vec,i1,i2) -> - rewrap (E_vector_subrange (rewrite_rec vec,rewrite_rec i1,rewrite_rec i2)) - | E_vector_update (vec,index,new_v) -> - rewrap (E_vector_update (rewrite_rec vec,rewrite_rec index,rewrite_rec new_v)) - | E_vector_update_subrange (vec,i1,i2,new_v) -> - rewrap (E_vector_update_subrange (rewrite_rec vec,rewrite_rec i1,rewrite_rec i2,rewrite_rec new_v)) - | E_case (exp ,pexps) -> - rewrap (E_case (rewrite_rec exp, - (List.map - (fun (Pat_aux (Pat_exp(p,e),pannot)) -> - Pat_aux (Pat_exp(rewriters.rewrite_pat rewriters nmap p,rewrite_rec e),pannot)) pexps))) - | E_let (letbind,body) -> rewrap (E_let(rewriters.rewrite_let rewriters nmap letbind,rewrite_rec body)) - | E_var (lexp,exp,body) -> - rewrap (E_var (rewriters.rewrite_lexp rewriters nmap lexp, rewrite_rec exp, rewrite_rec body)) - | _ -> rewrite_base full_exp - -let rewrite_defs_separate_numbs defs = rewrite_defs_base - {rewrite_exp = rewrite_exp_separate_ints; - rewrite_pat = rewrite_pat; - rewrite_let = rewrite_let; (*will likely need a new one?*) - rewrite_lexp = rewrite_lexp; (*will likely need a new one?*) - rewrite_fun = rewrite_fun; - rewrite_def = rewrite_def; - rewrite_defs = rewrite_defs_base} defs*) (* Remove redundant return statements, and translate remaining ones into an (effectful) call to builtin function "early_return" (in the Lem shallow -- cgit v1.2.3 From 8d85379367286c8e8a3aa4513aceae55db89f112 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Mon, 19 Nov 2018 17:56:35 +0000 Subject: Fix Lem untupling to correctly identify when multiple arguments are used Fixes CHERI Lem build --- src/pretty_print_lem.ml | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index 15d945ac..1afc0e50 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -1242,18 +1242,20 @@ let rec untuple_args_pat (P_aux (paux, ((l, _) as annot)) as pat) arg_typs = | P_tup [], _ -> let annot = (l, mk_tannot Env.empty unit_typ no_effect) in [P_aux (P_lit (mk_lit L_unit), annot)], identity - | P_wild, [Typ_aux (Typ_tup typs, _)] -> + | P_wild, (_::_::_) -> let wild typ = P_aux (P_wild, (l, mk_tannot env typ no_effect)) in - List.map wild typs, identity + List.map wild arg_typs, identity | P_typ (_, pat), _ -> untuple_args_pat pat arg_typs - | P_as _, [Typ_aux (Typ_tup _, _)] - | P_id _, [Typ_aux (Typ_tup _, _)] - | P_tup _, [Typ_aux (Typ_tup _, _)] -> + | P_as _, (_::_::_) + | P_id _, (_::_::_) -> let argpats, argexps = args_of_typs l env arg_typs in let argexp = E_aux (E_tuple argexps, annot) in let bindargs (E_aux (_, bannot) as body) = E_aux (E_let (LB_aux (LB_val (pat, argexp), annot), body), bannot) in argpats, bindargs + (* The type checker currently has a special case for a single arg type; if + that is removed, then remove the next case. *) + | P_tup pats, [_] -> [pat], identity | P_tup pats, _ -> pats, identity | _, _ -> [pat], identity -- cgit v1.2.3 From 71020c2f460e6031776df17cf8f2f71df5bb9730 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Tue, 20 Nov 2018 15:16:55 +0000 Subject: Add messages for assert failures without user defined messages Also fix some C optimisations --- src/c_backend.ml | 10 +++------- src/reporting.ml | 35 ++++++++++++++++++++++++++--------- src/reporting.mli | 3 ++- src/type_check.ml | 14 ++++++++++++-- 4 files changed, 43 insertions(+), 19 deletions(-) (limited to 'src') diff --git a/src/c_backend.ml b/src/c_backend.ml index b198c340..d3bb7c2a 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -429,11 +429,9 @@ let analyze_primop' ctx id args typ = | _ -> no_change end - (* | "vector_subrange", [AV_C_fragment (vec, _); AV_C_fragment (f, _); AV_C_fragment (t, _)] when is_stack_typ ctx typ -> let len = F_op (f, "-", F_op (t, "-", v_one)) in AE_val (AV_C_fragment (F_op (F_call ("safe_rshift", [F_raw "UINT64_MAX"; F_op (v_int 64, "-", len)]), "&", F_op (vec, ">>", t)), typ)) - *) | "vector_access", [AV_C_fragment (vec, _); AV_C_fragment (n, _)] -> AE_val (AV_C_fragment (F_op (v_one, "&", F_op (vec, ">>", n)), typ)) @@ -2946,7 +2944,6 @@ let sgen_finish = function Printf.sprintf " finish_%s();" (sgen_id id) | _ -> assert false - (* let instrument_tracing ctx = let module StringSet = Set.Make(String) in let traceable = StringSet.of_list ["mach_bits"; "sail_string"; "sail_bits"; "sail_int"; "unit"; "bool"] in @@ -2969,12 +2966,14 @@ let instrument_tracing ctx = trace_arg cval :: iraw "trace_argsep();" :: trace_args cvals in let trace_end = iraw "trace_end();" in - let trace_ret = + let trace_ret = iraw "trace_unknown();" + (* let ctyp_name = sgen_ctyp_name ctyp in if StringSet.mem ctyp_name traceable then iraw (Printf.sprintf "trace_%s(%s);" (sgen_ctyp_name ctyp) (sgen_clexp_pure clexp)) else iraw "trace_unknown();" + *) in [trace_start] @ trace_args args @@ -2997,7 +2996,6 @@ let instrument_tracing ctx = | CDEF_fundef (function_id, heap_return, args, body) -> CDEF_fundef (function_id, heap_return, args, instrument body) | cdef -> cdef - *) let bytecode_ast ctx rewrites (Defs defs) = let assert_vs = Initial_check.extern_of_string dec_ord (mk_id "sail_assert") "(bool, string) -> unit effect {escape}" in @@ -3050,9 +3048,7 @@ let compile_ast ctx c_includes (Defs defs) = let cdefs, ctx = specialize_variants ctx [] cdefs in let cdefs = sort_ctype_defs cdefs in let cdefs = optimize ctx cdefs in - (* let cdefs = if !opt_trace then List.map (instrument_tracing ctx) cdefs else cdefs in - *) let docs = List.map (codegen_def ctx) cdefs in let preamble = separate hardline diff --git a/src/reporting.ml b/src/reporting.ml index 3f5f1627..858e5c41 100644 --- a/src/reporting.ml +++ b/src/reporting.ml @@ -169,6 +169,14 @@ let format_pos2 ff p1 p2 = Format.pp_print_flush ff () end +let format_just_pos ff p1 p2 = + let open Lexing in + Format.fprintf ff "file \"%s\", line %d, character %d to line %d, character %d" + p1.pos_fname + p1.pos_lnum (p1.pos_cnum - p1.pos_bol + 1) + p2.pos_lnum (p2.pos_cnum - p2.pos_bol); + Format.pp_print_flush ff () + (* reads the part between p1 and p2 from the file *) let read_from_file_pos2 p1 p2 = @@ -187,12 +195,21 @@ let read_from_file_pos2 p1 p2 = let _ = close_in ic in (buf, not (multi = None)) -let rec format_loc_aux ff = function - | Parse_ast.Unknown -> Format.fprintf ff "no location information available" - | Parse_ast.Generated l -> Format.fprintf ff "code generated: original nearby source is "; (format_loc_aux ff l) - | Parse_ast.Unique (n, l) -> Format.fprintf ff "code unique (%d): original nearby source is " n; (format_loc_aux ff l) - | Parse_ast.Range (p1,p2) -> format_pos2 ff p1 p2 - | Parse_ast.Documented (_, l) -> format_loc_aux ff l +let rec format_loc_aux ?code:(code=true) ff = function + | Parse_ast.Unknown -> + Format.fprintf ff "no location information available" + | Parse_ast.Generated l -> + Format.fprintf ff "code generated: original nearby source is "; + format_loc_aux ~code:code ff l + | Parse_ast.Unique (n, l) -> + Format.fprintf ff "code unique (%d): original nearby source is " n; + format_loc_aux ~code:code ff l + | Parse_ast.Range (p1, p2) when code -> + format_pos2 ff p1 p2 + | Parse_ast.Range (p1, p2) -> + format_just_pos ff p1 p2 + | Parse_ast.Documented (_, l) -> + format_loc_aux ~code:code ff l let format_loc_source ff = function | Parse_ast.Range (p1, p2) -> @@ -215,9 +232,9 @@ let print_err_loc l = let print_pos p = format_pos Format.std_formatter p let print_err_pos p = format_pos Format.err_formatter p -let loc_to_string l = +let loc_to_string ?code:(code=true) l = let _ = Format.flush_str_formatter () in - let _ = format_loc_aux Format.str_formatter l in + let _ = format_loc_aux ~code:code Format.str_formatter l in let s = Format.flush_str_formatter () in s @@ -254,7 +271,7 @@ let issues = "\n\nPlease report this as an issue on GitHub at https://github.com let dest_err = function | Err_general (l, m) -> ("Error", false, Loc l, m) | Err_unreachable (l, (file, line, _, _), m) -> - ((Printf.sprintf "Internal error: Unreachable code (at \"%s\" line %d)\n" file line), false, Loc l, m ^ issues) + ((Printf.sprintf "Internal error: Unreachable code (at \"%s\" line %d)" file line), false, Loc l, m ^ issues) | Err_todo (l, m) -> ("Todo" ^ m, false, Loc l, "") | Err_syntax (p, m) -> ("Syntax error", false, Pos p, m) | Err_syntax_locn (l, m) -> ("Syntax error", false, Loc l, m) diff --git a/src/reporting.mli b/src/reporting.mli index a6878d6a..63ed3eee 100644 --- a/src/reporting.mli +++ b/src/reporting.mli @@ -62,7 +62,8 @@ (** {2 Auxiliary Functions } *) -val loc_to_string : Parse_ast.l -> string +(** [loc_to_string] includes code from file if code optional argument is true (default) *) +val loc_to_string : ?code:bool -> Parse_ast.l -> string (** [print_err fatal print_loc_source l head mes] prints an error / warning message to std-err. It starts with printing location information stored in [l] diff --git a/src/type_check.ml b/src/type_check.ml index 0079d59f..23629b51 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -2247,6 +2247,14 @@ let irule r env exp = with | Type_error (l, err) -> decr depth; typ_raise l err + +(* This function adds useful assertion messages to asserts missing them *) +let assert_msg test = function + | E_aux (E_lit (L_aux (L_string "", _)), (l, _)) -> + let open Reporting in + locate (fun _ -> l) (mk_lit_exp (L_string (loc_to_string ~code:false l ^ ": " ^ string_of_exp test))) + | msg -> msg + let strip_exp : 'a exp -> unit exp = function exp -> map_exp_annot (fun (l, _) -> (l, ())) exp let strip_pat : 'a pat -> unit pat = function pat -> map_pat_annot (fun (l, _) -> (l, ())) pat let strip_pexp : 'a pexp -> unit pexp = function pexp -> map_pexp_annot (fun (l, _) -> (l, ())) pexp @@ -2281,9 +2289,10 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ | (E_aux (E_assign (lexp, bind), _) :: exps) -> let texp, env = bind_assignment env lexp bind in texp :: check_block l env exps typ - | ((E_aux (E_assert (constr_exp, assert_msg), _) as exp) :: exps) -> + | ((E_aux (E_assert (constr_exp, msg), _) as exp) :: exps) -> + let msg = assert_msg constr_exp msg in let constr_exp = crule check_exp env constr_exp bool_typ in - let checked_msg = crule check_exp env assert_msg string_typ in + let checked_msg = crule check_exp env msg string_typ in let env = match assert_constraint env true constr_exp with | Some nc -> typ_print (lazy (adding ^ "constraint " ^ string_of_n_constraint nc ^ " for assert")); @@ -3291,6 +3300,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = let vec_typ = dvector_typ env (nint (List.length vec)) (typ_of inferred_item) in annot_exp (E_vector (inferred_item :: checked_items)) vec_typ | E_assert (test, msg) -> + let msg = assert_msg test msg in let checked_test = crule check_exp env test bool_typ in let checked_msg = crule check_exp env msg string_typ in annot_exp_effect (E_assert (checked_test, checked_msg)) unit_typ (mk_effect [BE_escape]) -- cgit v1.2.3 From f4affce812cdc1762ac2617682f813f1f34ab6b4 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Wed, 21 Nov 2018 11:29:33 +0000 Subject: Escape strings literals in lem pretty printer. --- src/pretty_print_lem.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index 1afc0e50..779d81f8 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -391,7 +391,7 @@ let doc_lit_lem (L_aux(lit,l)) = | L_bin n -> failwith "Shouldn't happen" (*"(num_to_vec " ^ ("0b" ^ n) ^ ")" (*shouldn't happen*)*) | L_undef -> utf8string "(return (failwith \"undefined value of unsupported type\"))" - | L_string s -> utf8string ("\"" ^ s ^ "\"") + | L_string s -> utf8string ("\"" ^ (String.escaped s) ^ "\"") | L_real s -> (* Lem does not support decimal syntax, so we translate a string of the form "x.y" into the ratio (x * 10^len(y) + y) / 10^len(y). -- cgit v1.2.3 From 05c68ff053485e9d5089969303e73045fb6cab6c Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Wed, 21 Nov 2018 12:31:07 +0000 Subject: Escape string literals in coq backend. Note that 71020c2f460e6031776df17cf8f2f71df5bb9730 introduced assert error messages containing " revealing unescaped string literals in generated lem and prompting review of other backends. --- src/pretty_print_coq.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 2e62188d..163cd183 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -556,6 +556,10 @@ let doc_tannot ctxt env eff typ = else string " : " ^^ ta in of_typ typ +(* Only double-quotes need escaped - by doubling them. *) +let coq_escape_string s = + Str.global_replace (Str.regexp "\"") "\"\"" s + let doc_lit (L_aux(lit,l)) = match lit with | L_unit -> utf8string "tt" @@ -570,7 +574,7 @@ let doc_lit (L_aux(lit,l)) = | L_bin n -> failwith "Shouldn't happen" (*"(num_to_vec " ^ ("0b" ^ n) ^ ")" (*shouldn't happen*)*) | L_undef -> utf8string "(Fail \"undefined value of unsupported type\")" - | L_string s -> utf8string ("\"" ^ s ^ "\"") + | L_string s -> utf8string ("\"" ^ (coq_escape_string s) ^ "\"") | L_real s -> (* Lem does not support decimal syntax, so we translate a string of the form "x.y" into the ratio (x * 10^len(y) + y) / 10^len(y). -- cgit v1.2.3 From 9b68baa58c1c6a3fc28df961624c522cca74cf8c Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Wed, 21 Nov 2018 13:58:26 +0000 Subject: Coq: add equality for records and polymorphic vectors --- src/pretty_print_coq.ml | 56 +++++++++++++++++++------------------------------ 1 file changed, 22 insertions(+), 34 deletions(-) (limited to 'src') diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 163cd183..5c4dfab4 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -1690,41 +1690,29 @@ let doc_typdef (TD_aux(td, (l, annot))) = match td with space ^^ string "|})." in let updates_pp = separate hardline (List.map doc_update_field fs) in - (* let doc_field (ftyp, fid) = - let reftyp = - mk_typ (Typ_app (Id_aux (Id "field_ref", Parse_ast.Unknown), - [mk_typ_arg (Typ_arg_typ rectyp); - mk_typ_arg (Typ_arg_typ ftyp)])) in - let rfannot = doc_tannot empty_ctxt env false reftyp in - let get, set = - string "rec_val" ^^ dot ^^ fname fid, - anglebars (space ^^ string "rec_val with " ^^ - (doc_op equals (fname fid) (string "v")) ^^ space) in - let base_ftyp = match annot with - | Some (env, _, _) -> Env.base_typ_of env ftyp - | _ -> ftyp in - let (start, is_inc) = - try - let start, (_, ord, _) = vector_start_index base_ftyp, vector_typ_args_of base_ftyp in - match nexp_simp start with - | Nexp_aux (Nexp_constant i, _) -> (i, is_order_inc ord) - | _ -> - raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ - ("register " ^ string_of_id id ^ " has non-constant start index " ^ string_of_nexp start)) - with - | _ -> (Big_int.zero, true) in - doc_op equals - (concat [string "let "; parens (concat [doc_id id; underscore; doc_id fid; rfannot])]) - (anglebars (concat [space; - doc_op equals (string "field_name") (string_lit (doc_id fid)); semi_sp; - doc_op equals (string "field_start") (string (Big_int.to_string start)); semi_sp; - doc_op equals (string "field_is_inc") (string (if is_inc then "true" else "false")); semi_sp; - doc_op equals (string "get_field") (parens (doc_op arrow (string "fun rec_val") get)); semi_sp; - doc_op equals (string "set_field") (parens (doc_op arrow (string "fun rec_val v") set)); space])) in *) + let id_pp = doc_id_type id in + let numfields = List.length fs in + let intros_pp s = + string " intros [" ^^ + separate space (List.init numfields (fun n -> string (s ^ string_of_int n))) ^^ + string "]." ^^ hardline + in + let eq_pp = + string "Instance Decidable_eq_" ^^ id_pp ^^ space ^^ colon ^/^ + string "forall (x y : " ^^ id_pp ^^ string "), Decidable (x = y)." ^^ + hardline ^^ intros_pp "x" ^^ intros_pp "y" ^^ + separate hardline (List.init numfields + (fun n -> + let ns = string_of_int n in + string ("cmp_record_field x" ^ ns ^ " y" ^ ns ^ "."))) ^^ + hardline ^^ + string "refine (Build_Decidable _ true _). subst. split; reflexivity." ^^ hardline ^^ + string "Defined." ^^ hardline + in doc_op coloneq - (separate space [string "Record"; doc_id_type id; doc_typquant_items empty_ctxt parens typq]) + (separate space [string "Record"; id_pp; doc_typquant_items empty_ctxt parens typq]) ((*doc_typquant typq*) (braces (space ^^ align fs_doc ^^ space))) ^^ - dot ^^ hardline ^^ updates_pp + dot ^^ hardline ^^ eq_pp ^^ updates_pp | TD_variant(id,nm,typq,ar,_) -> (match id with | Id_aux ((Id "read_kind"),_) -> empty @@ -1766,7 +1754,7 @@ let doc_typdef (TD_aux(td, (l, annot))) = match td with (concat [string "Inductive"; space; id_pp]) (enums_doc) in let eq1_pp = string "Scheme Equality for" ^^ space ^^ id_pp ^^ dot in - let eq2_pp = string "Instance Decidable_eq_" ^^ id_pp ^^ space ^^ colon ^^ space ^^ + let eq2_pp = string "Instance Decidable_eq_" ^^ id_pp ^^ space ^^ colon ^/^ string "forall (x y : " ^^ id_pp ^^ string "), Decidable (x = y) :=" ^/^ string "Decidable_eq_from_dec " ^^ id_pp ^^ string "_eq_dec." in typ_pp ^^ dot ^^ hardline ^^ eq1_pp ^^ hardline ^^ eq2_pp ^^ hardline) -- cgit v1.2.3 From b5cdd319822f9b2836a3bccf827121cb7ab0a105 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Wed, 21 Nov 2018 16:25:26 +0000 Subject: Coq: only generate equality functions for records where we need it because >100 field records slow everything down --- src/pretty_print_coq.ml | 90 ++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 74 insertions(+), 16 deletions(-) (limited to 'src') diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 5c4dfab4..841f21e6 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -1645,6 +1645,60 @@ let doc_exp, doc_let = (* expose doc_exp and doc_let *) in top_exp, let_exp +let types_used_with_generic_eq defs = + let rec add_typ idset (Typ_aux (typ,_)) = + match typ with + | Typ_id id -> IdSet.add id idset + | Typ_app (id,args) -> + List.fold_left add_typ_arg (IdSet.add id idset) args + | Typ_tup ts -> List.fold_left add_typ idset ts + | _ -> idset + and add_typ_arg idset (Typ_arg_aux (ta,_)) = + match ta with + | Typ_arg_typ typ -> add_typ idset typ + | _ -> idset + in + let alg = + { (Rewriter.compute_exp_alg IdSet.empty IdSet.union) with + Rewriter.e_aux = fun ((typs,exp),annot) -> + let typs' = + match exp with + | E_app (f,[arg1;_]) -> + if Env.is_extern f (env_of_annot annot) "coq" then + let f' = Env.get_extern f (env_of_annot annot) "coq" in + if f' = "generic_eq" || f' = "generic_neq" then + add_typ typs (Env.expand_synonyms (env_of arg1) (typ_of arg1)) + else typs + else typs + | _ -> typs + in typs', E_aux (exp,annot) } + in + let typs_req_funcl (FCL_aux (FCL_Funcl (_,pexp), _)) = + fst (Rewriter.fold_pexp alg pexp) + in + let typs_req_def = function + | DEF_kind _ + | DEF_type _ + | DEF_spec _ + | DEF_fixity _ + | DEF_overload _ + | DEF_default _ + | DEF_constraint _ + | DEF_pragma _ + | DEF_reg_dec _ + -> IdSet.empty + | DEF_fundef (FD_aux (FD_function (_,_,_,fcls),_)) -> + List.fold_left IdSet.union IdSet.empty (List.map typs_req_funcl fcls) + | DEF_mapdef (MD_aux (_,(l,_))) + | DEF_scattered (SD_aux (_,(l,_))) + -> unreachable l __POS__ "Internal definition found in the Coq back-end" + | DEF_internal_mutrec _ + -> unreachable Unknown __POS__ "Internal definition found in the Coq back-end" + | DEF_val lb -> + fst (Rewriter.fold_letbind alg lb) + in + List.fold_left IdSet.union IdSet.empty (List.map typs_req_def defs) + let doc_type_union ctxt typ_name (Tu_aux(Tu_ty_id(typ,id),_)) = separate space [doc_id_ctor id; colon; doc_typ ctxt typ; arrow; typ_name] @@ -1654,7 +1708,7 @@ let rec doc_range (BF_aux(r,_)) = match r with | BF_range(i1,i2) -> parens (doc_op comma (doc_int i1) (doc_int i2)) | BF_concat(ir1,ir2) -> (doc_range ir1) ^^ comma ^^ (doc_range ir2) -let doc_typdef (TD_aux(td, (l, annot))) = match td with +let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = match td with | TD_abbrev(id,nm,(TypSchm_aux (TypSchm_ts (typq, _), _) as typschm)) -> doc_op coloneq (separate space [string "Definition"; doc_id_type id; @@ -1698,16 +1752,18 @@ let doc_typdef (TD_aux(td, (l, annot))) = match td with string "]." ^^ hardline in let eq_pp = - string "Instance Decidable_eq_" ^^ id_pp ^^ space ^^ colon ^/^ - string "forall (x y : " ^^ id_pp ^^ string "), Decidable (x = y)." ^^ - hardline ^^ intros_pp "x" ^^ intros_pp "y" ^^ - separate hardline (List.init numfields - (fun n -> - let ns = string_of_int n in - string ("cmp_record_field x" ^ ns ^ " y" ^ ns ^ "."))) ^^ - hardline ^^ - string "refine (Build_Decidable _ true _). subst. split; reflexivity." ^^ hardline ^^ - string "Defined." ^^ hardline + if IdSet.mem id generic_eq_types then + string "Instance Decidable_eq_" ^^ id_pp ^^ space ^^ colon ^/^ + string "forall (x y : " ^^ id_pp ^^ string "), Decidable (x = y)." ^^ + hardline ^^ intros_pp "x" ^^ intros_pp "y" ^^ + separate hardline (List.init numfields + (fun n -> + let ns = string_of_int n in + string ("cmp_record_field x" ^ ns ^ " y" ^ ns ^ "."))) ^^ + hardline ^^ + string "refine (Build_Decidable _ true _). subst. split; reflexivity." ^^ hardline ^^ + string "Defined." ^^ hardline + else empty in doc_op coloneq (separate space [string "Record"; id_pp; doc_typquant_items empty_ctxt parens typq]) @@ -2209,13 +2265,13 @@ let doc_val pat exp = group (string "Definition" ^^ space ^^ idpp ^^ typpp ^^ space ^^ coloneq ^/^ base_pp) ^^ hardline ^^ group (separate space [string "Hint Unfold"; idpp; colon; string "sail."]) ^^ hardline -let rec doc_def unimplemented def = +let rec doc_def unimplemented generic_eq_types def = (* let _ = Pretty_print_sail.pp_defs stderr (Defs [def]) in *) match def with | DEF_spec v_spec -> doc_val_spec unimplemented v_spec | DEF_fixity _ -> empty | DEF_overload _ -> empty - | DEF_type t_def -> group (doc_typdef t_def) ^/^ hardline + | DEF_type t_def -> group (doc_typdef generic_eq_types t_def) ^/^ hardline | DEF_reg_dec dec -> group (doc_dec dec) | DEF_default df -> empty @@ -2270,6 +2326,8 @@ try let statedefs, defs = List.partition is_state_def defs in let register_refs = State.register_refs_coq (State.find_registers defs) in let unimplemented = find_unimplemented defs in + let generic_eq_types = types_used_with_generic_eq defs in + let doc_def = doc_def unimplemented generic_eq_types in let () = if !opt_undef_axioms || IdSet.is_empty unimplemented then () else Reporting.print_err false false Parse_ast.Unknown "Warning" ("The following functions were declared but are undefined:\n" ^ @@ -2280,9 +2338,9 @@ try [string "(*" ^^ (string top_line) ^^ string "*)";hardline; (separate_map hardline) (fun lib -> separate space [string "Require Import";string lib] ^^ dot) types_modules;hardline; - separate empty (List.map (doc_def unimplemented) typdefs); hardline; + separate empty (List.map doc_def typdefs); hardline; hardline; - separate empty (List.map (doc_def unimplemented) statedefs); hardline; + separate empty (List.map doc_def statedefs); hardline; hardline; register_refs; hardline; concat [ @@ -2304,7 +2362,7 @@ try string "Section Content."; hardline; hardline; - separate empty (List.map (doc_def unimplemented) defs); + separate empty (List.map doc_def defs); hardline; string "End Content."; hardline]) -- cgit v1.2.3 From ea177d95766789b0500317f12fe0939d1508e19c Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Fri, 23 Nov 2018 17:55:54 +0000 Subject: C backend improvements - Propagate types more accurately to improve optimization on ANF representation. - Add a generic optimization pass to remove redundant variables that simply alias other variables. - Modify Sail interactive mode, so it can compile a specification with the :compile command, view generated intermediate representation via the :ir command, and step-through the IR with :exec (although this is very incomplete) - Introduce a third bitvector representation, between fast fixed-precision bitvectors, and variable length large bitvectors. The bitvector types are now from most efficient to least * CT_fbits for fixed precision, 64-bit or less bitvectors * CT_sbits for 64-bit or less, variable length bitvectors * CT_lbits for arbitrary variable length bitvectors - Support for generating C code using CT_sbits is currently incomplete, it just exists in the intermediate representation right now. - Include ctyp in AV_C_fragment, so we don't have to recompute it --- src/anf.ml | 7 +- src/anf.mli | 2 +- src/bytecode_interpreter.ml | 162 +++++++++++++++ src/bytecode_util.ml | 133 ++++++++++-- src/c_backend.ml | 496 ++++++++++++++++++++++++++------------------ src/c_backend.mli | 10 +- src/constant_fold.ml | 1 + src/isail.ml | 138 ++++++++---- src/sail.ml | 3 +- 9 files changed, 678 insertions(+), 274 deletions(-) create mode 100644 src/bytecode_interpreter.ml (limited to 'src') diff --git a/src/anf.ml b/src/anf.ml index 50f3ccba..1f93e00f 100644 --- a/src/anf.ml +++ b/src/anf.ml @@ -127,7 +127,7 @@ and 'a aval = | AV_list of ('a aval) list * 'a | AV_vector of ('a aval) list * 'a | AV_record of ('a aval) Bindings.t * 'a - | AV_C_fragment of fragment * 'a + | AV_C_fragment of fragment * 'a * ctyp (* Renaming variables in ANF expressions *) @@ -183,7 +183,7 @@ let rec aval_rename from_id to_id = function | AV_list (avals, typ) -> AV_list (List.map (aval_rename from_id to_id) avals, typ) | AV_vector (avals, typ) -> AV_vector (List.map (aval_rename from_id to_id) avals, typ) | AV_record (avals, typ) -> AV_record (Bindings.map (aval_rename from_id to_id) avals, typ) - | AV_C_fragment (fragment, typ) -> AV_C_fragment (frag_rename from_id to_id fragment, typ) + | AV_C_fragment (fragment, typ, ctyp) -> AV_C_fragment (frag_rename from_id to_id fragment, typ, ctyp) let rec aexp_rename from_id to_id (AE_aux (aexp, env, l)) = let recur = aexp_rename from_id to_id in @@ -423,7 +423,8 @@ and pp_aval = function | AV_id (id, lvar) -> pp_lvar lvar (pp_id id) | AV_tuple avals -> parens (separate_map (comma ^^ space) pp_aval avals) | AV_ref (id, lvar) -> string "ref" ^^ space ^^ pp_lvar lvar (pp_id id) - | AV_C_fragment (frag, typ) -> pp_annot typ (string (string_of_fragment frag |> Util.cyan |> Util.clear)) + | AV_C_fragment (frag, typ, ctyp) -> + pp_annot typ (string ("(" ^ string_of_ctyp ctyp ^ ")" ^ string_of_fragment frag |> Util.cyan |> Util.clear)) | AV_vector (avals, typ) -> pp_annot typ (string "[" ^^ separate_map (comma ^^ space) pp_aval avals ^^ string "]") | AV_list (avals, typ) -> diff --git a/src/anf.mli b/src/anf.mli index 9854b04c..5e162b7c 100644 --- a/src/anf.mli +++ b/src/anf.mli @@ -96,7 +96,7 @@ and 'a aval = | AV_list of ('a aval) list * 'a | AV_vector of ('a aval) list * 'a | AV_record of ('a aval) Bindings.t * 'a - | AV_C_fragment of fragment * 'a + | AV_C_fragment of fragment * 'a * ctyp val gensym : unit -> id diff --git a/src/bytecode_interpreter.ml b/src/bytecode_interpreter.ml new file mode 100644 index 00000000..398e0c9d --- /dev/null +++ b/src/bytecode_interpreter.ml @@ -0,0 +1,162 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Ast_util +open Bytecode +open Bytecode_util + +module StringMap = Map.Make(String) + +type 'a frame = { + jump_table : int StringMap.t; + locals : 'a Bindings.t; + pc : int; + instrs : instr array + } + +type 'a gstate = { + globals : 'a Bindings.t; + cdefs : cdef list + } + +type 'a stack = { + top : 'a frame; + ret : ('a -> 'a frame) list + } + +let make_jump_table instrs = + let rec aux n = function + | I_aux (I_label label, _) :: instrs -> StringMap.add label n (aux (n + 1) instrs) + | _ :: instrs -> aux (n + 1) instrs + | [] -> StringMap.empty + in + aux 0 instrs + +let new_gstate cdefs = { + globals = Bindings.empty; + cdefs = cdefs + } + +let new_stack instrs = { + top = { + jump_table = make_jump_table instrs; + locals = Bindings.empty; + pc = 0; + instrs = Array.of_list instrs + }; + ret = [] + } + +let with_top stack f = + { stack with top = f (stack.top) } + +let eval_fragment gstate locals = function + | F_id id -> + begin match Bindings.find_opt id locals with + | Some vl -> vl + | None -> + begin match Bindings.find_opt id gstate.globals with + | Some vl -> vl + | None -> failwith "Identifier not found" + end + end + | F_lit vl -> vl + | _ -> failwith "Cannot eval fragment" + +let is_function id = function + | CDEF_fundef (id', _, _, _) when Id.compare id id' = 0 -> true + | _ -> false + +let step (gstate, stack) = + let I_aux (instr_aux, (_, l)) = stack.top.instrs.(stack.top.pc) in + match instr_aux with + | I_decl _ -> + gstate, with_top stack (fun frame -> { frame with pc = frame.pc + 1 }) + + | I_init (_, id, (fragment, _)) -> + let vl = eval_fragment gstate stack.top.locals fragment in + gstate, + with_top stack (fun frame -> { frame with pc = frame.pc + 1; locals = Bindings.add id vl frame.locals }) + + | I_jump ((fragment, _), label) -> + let vl = eval_fragment gstate stack.top.locals fragment in + gstate, + begin match vl with + | V_bool true -> + with_top stack (fun frame -> { frame with pc = StringMap.find label frame.jump_table }) + | V_bool false -> + with_top stack (fun frame -> { frame with pc = frame.pc + 1 }) + | _ -> + failwith "Type error" + end + + | I_funcall (clexp, _, id, cvals) -> + let args = List.map (fun (fragment, _) -> eval_fragment gstate stack.top.locals fragment) cvals in + let params, instrs = + match List.find_opt (is_function id) gstate.cdefs with + | Some (CDEF_fundef (_, _, params, instrs)) -> params, instrs + | _ -> failwith "Function not found" + in + gstate, + { + top = { + jump_table = make_jump_table instrs; + locals = List.fold_left2 (fun locals param arg -> Bindings.add param arg locals) Bindings.empty params args; + pc = 0; + instrs = Array.of_list instrs; + }; + ret = (fun vl -> { stack.top with pc = stack.top.pc + 1 }) :: stack.ret + } + + | I_goto label -> + gstate, with_top stack (fun frame -> { frame with pc = StringMap.find label frame.jump_table }) + + | _ -> raise (Reporting.err_unreachable l __POS__ "Unhandled instruction") diff --git a/src/bytecode_util.ml b/src/bytecode_util.ml index 6334210e..783f6793 100644 --- a/src/bytecode_util.ml +++ b/src/bytecode_util.ml @@ -131,6 +131,73 @@ let rec frag_rename from_id to_id = function | F_raw raw -> F_raw raw | F_poly f -> F_poly (frag_rename from_id to_id f) +let cval_rename from_id to_id (frag, ctyp) = (frag_rename from_id to_id frag, ctyp) + +let rec clexp_rename from_id to_id = function + | CL_id (id, ctyp) when Id.compare id from_id = 0 -> CL_id (to_id, ctyp) + | CL_id (id, ctyp) -> CL_id (id, ctyp) + | CL_field (clexp, field) -> + CL_field (clexp_rename from_id to_id clexp, field) + | CL_addr clexp -> + CL_addr (clexp_rename from_id to_id clexp) + | CL_tuple (clexp, n) -> + CL_tuple (clexp_rename from_id to_id clexp, n) + | CL_current_exception ctyp -> CL_current_exception ctyp + | CL_have_exception -> CL_have_exception + +let rec instr_rename from_id to_id (I_aux (instr, aux)) = + let instr = match instr with + | I_decl (ctyp, id) when Id.compare id from_id = 0 -> I_decl (ctyp, to_id) + | I_decl (ctyp, id) -> I_decl (ctyp, id) + + | I_init (ctyp, id, cval) when Id.compare id from_id = 0 -> + I_init (ctyp, to_id, cval_rename from_id to_id cval) + | I_init (ctyp, id, cval) -> + I_init (ctyp, id, cval_rename from_id to_id cval) + + | I_if ((frag, ctyp1), then_instrs, else_instrs, ctyp2) -> + I_if ((frag_rename from_id to_id frag, ctyp1), then_instrs, else_instrs, ctyp2) + + | I_jump (cval, label) -> I_jump (cval_rename from_id to_id cval, label) + + | I_funcall (clexp, extern, id, args) -> + I_funcall (clexp_rename from_id to_id clexp, extern, id, List.map (cval_rename from_id to_id) args) + + | I_copy (clexp, cval) -> I_copy (clexp_rename from_id to_id clexp, cval_rename from_id to_id cval) + + | I_clear (ctyp, id) when Id.compare id from_id = 0 -> I_clear (ctyp, to_id) + | I_clear (ctyp, id) -> I_clear (ctyp, id) + + | I_return cval -> I_return (cval_rename from_id to_id cval) + + | I_block instrs -> I_block (List.map (instr_rename from_id to_id) instrs) + + | I_try_block instrs -> I_try_block (List.map (instr_rename from_id to_id) instrs) + + | I_throw cval -> I_throw (cval_rename from_id to_id cval) + + | I_comment str -> I_comment str + + | I_raw str -> I_raw str + + | I_label label -> I_label label + + | I_goto label -> I_goto label + + | I_undefined ctyp -> I_undefined ctyp + + | I_match_failure -> I_match_failure + + | I_reset (ctyp, id) when Id.compare id from_id = 0 -> I_reset (ctyp, to_id) + | I_reset (ctyp, id) -> I_reset (ctyp, id) + + | I_reinit (ctyp, id, cval) when Id.compare id from_id = 0 -> + I_reinit (ctyp, to_id, cval_rename from_id to_id cval) + | I_reinit (ctyp, id, cval) -> + I_reinit (ctyp, id, cval_rename from_id to_id cval) + in + I_aux (instr, aux) + (**************************************************************************) (* 1. Instruction pretty printer *) (**************************************************************************) @@ -175,12 +242,14 @@ and string_of_fragment' ?zencode:(zencode=true) f = (* String representation of ctyps here is only for debugging and intermediate language pretty-printer. *) and string_of_ctyp = function - | CT_int -> "mpz_t" - | CT_bits true -> "bv_t(dec)" - | CT_bits false -> "bv_t(inc)" - | CT_bits64 (n, true) -> "uint64_t(" ^ string_of_int n ^ ", dec)" - | CT_bits64 (n, false) -> "uint64_t(" ^ string_of_int n ^ ", int)" - | CT_int64 -> "int64_t" + | CT_int -> "int" + | CT_lbits true -> "lbits(dec)" + | CT_lbits false -> "lbits(inc)" + | CT_fbits (n, true) -> "fbits(" ^ string_of_int n ^ ", dec)" + | CT_fbits (n, false) -> "fbits(" ^ string_of_int n ^ ", int)" + | CT_sbits true -> "sbits(dec)" + | CT_sbits false -> "sbits(inc)" + | CT_int64 -> "int64" | CT_bit -> "bit" | CT_unit -> "unit" | CT_bool -> "bool" @@ -197,12 +266,14 @@ and string_of_ctyp = function (** This function is like string_of_ctyp, but recursively prints all constructors in variants and structs. Used for debug output. *) and full_string_of_ctyp = function - | CT_int -> "mpz_t" - | CT_bits true -> "bv_t(dec)" - | CT_bits false -> "bv_t(inc)" - | CT_bits64 (n, true) -> "uint64_t(" ^ string_of_int n ^ ", dec)" - | CT_bits64 (n, false) -> "uint64_t(" ^ string_of_int n ^ ", int)" - | CT_int64 -> "int64_t" + | CT_int -> "int" + | CT_lbits true -> "lbits(dec)" + | CT_lbits false -> "lbits(inc)" + | CT_fbits (n, true) -> "fbits(" ^ string_of_int n ^ ", dec)" + | CT_fbits (n, false) -> "fbits(" ^ string_of_int n ^ ", int)" + | CT_sbits true -> "sbits(dec)" + | CT_sbits false -> "sbits(inc)" + | CT_int64 -> "int64" | CT_bit -> "bit" | CT_unit -> "unit" | CT_bool -> "bool" @@ -222,7 +293,8 @@ and full_string_of_ctyp = function | CT_poly -> "*" let rec map_ctyp f = function - | (CT_int | CT_int64 | CT_bits _ | CT_bits64 _ | CT_bit | CT_unit | CT_bool | CT_real | CT_string | CT_poly | CT_enum _) as ctyp -> f ctyp + | (CT_int | CT_int64 | CT_lbits _ | CT_fbits _ | CT_sbits _ + | CT_bit | CT_unit | CT_bool | CT_real | CT_string | CT_poly | CT_enum _) as ctyp -> f ctyp | CT_tup ctyps -> f (CT_tup (List.map (map_ctyp f) ctyps)) | CT_ref ctyp -> f (CT_ref (map_ctyp f ctyp)) | CT_vector (direction, ctyp) -> f (CT_vector (direction, map_ctyp f ctyp)) @@ -233,8 +305,9 @@ let rec map_ctyp f = function let rec ctyp_equal ctyp1 ctyp2 = match ctyp1, ctyp2 with | CT_int, CT_int -> true - | CT_bits d1, CT_bits d2 -> d1 = d2 - | CT_bits64 (m1, d1), CT_bits64 (m2, d2) -> m1 = m2 && d1 = d2 + | CT_lbits d1, CT_lbits d2 -> d1 = d2 + | CT_sbits d1, CT_sbits d2 -> d1 = d2 + | CT_fbits (m1, d1), CT_fbits (m2, d2) -> m1 = m2 && d1 = d2 | CT_bit, CT_bit -> true | CT_int64, CT_int64 -> true | CT_unit, CT_unit -> true @@ -271,8 +344,9 @@ let rec ctyp_unify ctyp1 ctyp2 = let rec ctyp_suprema = function | CT_int -> CT_int - | CT_bits d -> CT_bits d - | CT_bits64 (_, d) -> CT_bits d + | CT_lbits d -> CT_lbits d + | CT_fbits (_, d) -> CT_lbits d + | CT_sbits d -> CT_lbits d | CT_int64 -> CT_int | CT_unit -> CT_unit | CT_bool -> CT_bool @@ -298,7 +372,7 @@ let rec ctyp_ids = function IdSet.add id (List.fold_left (fun ids (_, ctyp) -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctors) | CT_tup ctyps -> List.fold_left (fun ids ctyp -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctyps | CT_vector (_, ctyp) | CT_list ctyp | CT_ref ctyp -> ctyp_ids ctyp - | CT_int | CT_int64 | CT_bits _ | CT_bits64 _ | CT_unit + | CT_int | CT_int64 | CT_lbits _ | CT_fbits _ | CT_sbits _ | CT_unit | CT_bool | CT_real | CT_bit | CT_string | CT_poly -> IdSet.empty let rec unpoly = function @@ -310,7 +384,7 @@ let rec unpoly = function | f -> f let rec is_polymorphic = function - | CT_int | CT_int64 | CT_bits _ | CT_bits64 _ | CT_bit | CT_unit | CT_bool | CT_real | CT_string -> false + | CT_int | CT_int64 | CT_lbits _ | CT_fbits _ | CT_sbits _ | CT_bit | CT_unit | CT_bool | CT_real | CT_string -> false | CT_tup ctyps -> List.exists is_polymorphic ctyps | CT_enum _ -> false | CT_struct (_, ctors) | CT_variant (_, ctors) -> List.exists (fun (_, ctyp) -> is_polymorphic ctyp) ctors @@ -685,3 +759,24 @@ let rec map_instrs f (I_aux (instr, aux)) = | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure | I_undefined _ -> instr in I_aux (instr, aux) + +let rec instr_ids (I_aux (instr, _)) = + let reads, writes = instr_deps instr in + let get_id = function + | G_id id -> Some id + | _ -> None + in + NS.elements reads @ NS.elements writes + |> List.map get_id + |> Util.option_these + |> IdSet.of_list + +let rec filter_instrs f instrs = + let filter_instrs' = function + | I_aux (I_block instrs, aux) -> I_aux (I_block (filter_instrs f instrs), aux) + | I_aux (I_try_block instrs, aux) -> I_aux (I_try_block (filter_instrs f instrs), aux) + | I_aux (I_if (cval, instrs1, instrs2, ctyp), aux) -> + I_aux (I_if (cval, filter_instrs f instrs1, filter_instrs f instrs2, ctyp), aux) + | instr -> instr + in + List.filter f (List.map filter_instrs' instrs) diff --git a/src/c_backend.ml b/src/c_backend.ml index d3bb7c2a..2bac9945 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -71,6 +71,7 @@ let opt_no_main = ref false let optimize_primops = ref false let optimize_hoist_allocations = ref false let optimize_struct_updates = ref false +let optimize_alias = ref false let c_debug str = if !c_verbosity > 0 then prerr_endline (Lazy.force str) else () @@ -89,6 +90,13 @@ let zencode_id = function let max_int64 = Big_int.of_int64 Int64.max_int let min_int64 = Big_int.of_int64 Int64.min_int +(** The context type contains two type-checking + environments. ctx.local_env contains the closest typechecking + environment, usually from the expression we are compiling, whereas + ctx.tc_env is the global type checking environment from + type-checking the entire AST. We also keep track of local variables + in ctx.locals, so we know when their type changes due to flow + typing. *) type ctx = { records : (ctyp Bindings.t) Bindings.t; enums : IdSet.t Bindings.t; @@ -115,50 +123,55 @@ let initial_ctx env = optimize_z3 = true; } -(** Convert a sail type into a C-type **) +(** Convert a sail type into a C-type. This function can be quite + slow, because it uses ctx.local_env and Z3 to analyse the Sail + types and attempts to fit them into the smallest possible C + types, provided ctx.optimize_z3 is true (default) **) let rec ctyp_of_typ ctx typ = let Typ_aux (typ_aux, l) as typ = Env.expand_synonyms ctx.tc_env typ in match typ_aux with - | Typ_id id when string_of_id id = "bit" -> CT_bit - | Typ_id id when string_of_id id = "bool" -> CT_bool - | Typ_id id when string_of_id id = "int" -> CT_int - | Typ_id id when string_of_id id = "nat" -> CT_int + | Typ_id id when string_of_id id = "bit" -> CT_bit + | Typ_id id when string_of_id id = "bool" -> CT_bool + | Typ_id id when string_of_id id = "int" -> CT_int + | Typ_id id when string_of_id id = "nat" -> CT_int + | Typ_id id when string_of_id id = "unit" -> CT_unit + | Typ_id id when string_of_id id = "string" -> CT_string + | Typ_id id when string_of_id id = "real" -> CT_real + | Typ_app (id, _) when string_of_id id = "range" || string_of_id id = "atom" -> - begin - match destruct_range Env.empty typ with - | None -> assert false (* Checked if range type in guard *) - | Some (kids, constr, n, m) -> - match nexp_simp n, nexp_simp m with - | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) - when Big_int.less_equal min_int64 n && Big_int.less_equal m max_int64 -> + begin match destruct_range Env.empty typ with + | None -> assert false (* Checked if range type in guard *) + | Some (kids, constr, n, m) -> + match nexp_simp n, nexp_simp m with + | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) + when Big_int.less_equal min_int64 n && Big_int.less_equal m max_int64 -> + CT_int64 + | n, m when ctx.optimize_z3 -> + if prove ctx.local_env (nc_lteq (nconstant min_int64) n) && prove ctx.local_env (nc_lteq m (nconstant max_int64)) then CT_int64 - | n, m when ctx.optimize_z3 -> - if prove ctx.local_env (nc_lteq (nconstant min_int64) n) && prove ctx.local_env (nc_lteq m (nconstant max_int64)) then - CT_int64 - else - CT_int - | _ -> CT_int + else + CT_int + | _ -> CT_int end | Typ_app (id, [Typ_arg_aux (Typ_arg_typ typ, _)]) when string_of_id id = "list" -> CT_list (ctyp_of_typ ctx typ) + (* When converting a sail bitvector type into C, we have three options in order of efficiency: + - If the length is obviously static and smaller than 64, use the fixed bits type (aka uint64_t), fbits. + - If the length is less than 64, then use a small bits type, sbits. + - If the length may be larger than 64, use a large bits type lbits. *) | Typ_app (id, [Typ_arg_aux (Typ_arg_nexp n, _); Typ_arg_aux (Typ_arg_order ord, _); Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id vtyp_id, _)), _)]) when string_of_id id = "vector" && string_of_id vtyp_id = "bit" -> - begin - let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in - match nexp_simp n with - | Nexp_aux (Nexp_constant n, _) when Big_int.less_equal n (Big_int.of_int 64) -> CT_bits64 (Big_int.to_int n, direction) - | _ when not ctx.optimize_z3 -> CT_bits direction - | _ -> CT_bits direction - (* This is extremely slow :( - match solve ctx.local_env n with - | Some n when Big_int.less_equal n (Big_int.of_int 64) -> CT_bits64 (Big_int.to_int n, direction) - | _ -> CT_bits direction - *) + let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in + begin match nexp_simp n with + | Nexp_aux (Nexp_constant n, _) when Big_int.less_equal n (Big_int.of_int 64) -> CT_fbits (Big_int.to_int n, direction) + | n when ctx.optimize_z3 && prove ctx.local_env (nc_lteq n (nint 64)) -> CT_lbits direction (* TODO: CT_sbits direction *) + | _ -> CT_lbits direction end + | Typ_app (id, [Typ_arg_aux (Typ_arg_nexp n, _); Typ_arg_aux (Typ_arg_order ord, _); Typ_arg_aux (Typ_arg_typ typ, _)]) @@ -166,46 +179,54 @@ let rec ctyp_of_typ ctx typ = let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in CT_vector (direction, ctyp_of_typ ctx typ) - | Typ_id id when string_of_id id = "unit" -> CT_unit - | Typ_id id when string_of_id id = "string" -> CT_string - | Typ_id id when string_of_id id = "real" -> CT_real - | Typ_app (id, [Typ_arg_aux (Typ_arg_typ typ, _)]) when string_of_id id = "register" -> CT_ref (ctyp_of_typ ctx typ) - | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.records -> CT_struct (id, Bindings.find id ctx.records |> Bindings.bindings) + | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.records -> CT_struct (id, Bindings.find id ctx.records |> Bindings.bindings) | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.variants -> CT_variant (id, Bindings.find id ctx.variants |> Bindings.bindings) | Typ_id id when Bindings.mem id ctx.enums -> CT_enum (id, Bindings.find id ctx.enums |> IdSet.elements) | Typ_tup typs -> CT_tup (List.map (ctyp_of_typ ctx) typs) | Typ_exist _ when ctx.optimize_z3 -> - (* Use Type_check.destruct_exist when optimising with z3, to ensure that we - don't cause any type variable clashes in local_env. *) + (* Use Type_check.destruct_exist when optimising with z3, to + ensure that we don't cause any type variable clashes in + local_env, and that we can optimize the existential based upon + it's constraints. *) begin match destruct_exist ctx.local_env typ with | Some (kids, nc, typ) -> let env = add_existential l kids nc ctx.local_env in ctyp_of_typ { ctx with local_env = env } typ - | None -> c_error "Existential cannot be destructured. This should be impossible!" + | None -> raise (Reporting.err_unreachable l __POS__ "Existential cannot be destructured!") end | Typ_exist (_, _, typ) -> ctyp_of_typ ctx typ - | Typ_var kid -> CT_poly (* c_error ~loc:l ("Polymorphic type encountered " ^ string_of_kid kid) *) + | Typ_var kid -> CT_poly | _ -> c_error ~loc:l ("No C type for type " ^ string_of_typ typ) let rec is_stack_ctyp ctyp = match ctyp with - | CT_bits64 _ | CT_int64 | CT_bit | CT_unit | CT_bool | CT_enum _ -> true - | CT_bits _ | CT_int | CT_real | CT_string | CT_list _ | CT_vector _ -> false + | CT_fbits _ | CT_sbits _ | CT_int64 | CT_bit | CT_unit | CT_bool | CT_enum _ -> true + | CT_lbits _ | CT_int | CT_real | CT_string | CT_list _ | CT_vector _ -> false | CT_struct (_, fields) -> List.for_all (fun (_, ctyp) -> is_stack_ctyp ctyp) fields - | CT_variant (_, ctors) -> false (* List.for_all (fun (_, ctyp) -> is_stack_ctyp ctyp) ctors *) (*FIXME*) + | CT_variant (_, ctors) -> false (* List.for_all (fun (_, ctyp) -> is_stack_ctyp ctyp) ctors *) (* FIXME *) | CT_tup ctyps -> List.for_all is_stack_ctyp ctyps | CT_ref ctyp -> true | CT_poly -> true let is_stack_typ ctx typ = is_stack_ctyp (ctyp_of_typ ctx typ) +let is_fbits_typ ctx typ = + match ctyp_of_typ ctx typ with + | CT_fbits _ -> true + | _ -> false + +let is_sbits_typ ctx typ = + match ctyp_of_typ ctx typ with + | CT_sbits _ -> true + | _ -> false + let ctor_bindings = List.fold_left (fun map (id, ctyp) -> Bindings.add id ctyp map) Bindings.empty (**************************************************************************) @@ -236,15 +257,15 @@ let hex_char = let literal_to_fragment (L_aux (l_aux, _) as lit) = match l_aux with | L_num n when Big_int.less_equal min_int64 n && Big_int.less_equal n max_int64 -> - Some (F_lit (V_int n)) + Some (F_lit (V_int n), CT_int64) | L_hex str when String.length str <= 16 -> let padding = 16 - String.length str in let padding = Util.list_init padding (fun _ -> Sail2_values.B0) in let content = Util.string_to_list str |> List.map hex_char |> List.concat in - Some (F_lit (V_bits (padding @ content))) - | L_unit -> Some (F_lit V_unit) - | L_true -> Some (F_lit (V_bool true)) - | L_false -> Some (F_lit (V_bool false)) + Some (F_lit (V_bits (padding @ content)), CT_fbits (String.length str * 4, true)) + | L_unit -> Some (F_lit V_unit, CT_unit) + | L_true -> Some (F_lit (V_bool true), CT_bool) + | L_false -> Some (F_lit (V_bool false), CT_bool) | _ -> None let c_literals ctx = @@ -252,7 +273,7 @@ let c_literals ctx = | AV_lit (lit, typ) as v when is_stack_ctyp (ctyp_of_typ { ctx with local_env = env } typ) -> begin match literal_to_fragment lit with - | Some frag -> AV_C_fragment (frag, typ) + | Some (frag, ctyp) -> AV_C_fragment (frag, typ, ctyp) | None -> v end | AV_tuple avals -> AV_tuple (List.map (c_literal env l) avals) @@ -287,36 +308,45 @@ let rec c_aval ctx = function | AV_lit (lit, typ) as v -> begin match literal_to_fragment lit with - | Some frag -> AV_C_fragment (frag, typ) + | Some (frag, ctyp) -> AV_C_fragment (frag, typ, ctyp) | None -> v end - | AV_C_fragment (str, typ) -> AV_C_fragment (str, typ) + | AV_C_fragment (str, typ, ctyp) -> AV_C_fragment (str, typ, ctyp) (* An id can be converted to a C fragment if it's type can be stack-allocated. *) | AV_id (id, lvar) as v -> begin match lvar with - | Local (_, typ) when is_stack_typ ctx typ -> - begin - try - (* We need to check that id's type hasn't changed due to flow typing *) - let _, ctyp = Bindings.find id ctx.locals in - if is_stack_ctyp ctyp then - AV_C_fragment (F_id id, typ) - else - v (* id's type went from heap -> stack due to flow typing, so it's really still heap allocated! *) - with - (* Hack: Assuming global letbindings don't change from flow typing... *) - Not_found -> AV_C_fragment (F_id id, typ) - (* failwith ("could not find " ^ string_of_id id ^ " in local variables") *) - end + | Local (_, typ) -> + let ctyp = ctyp_of_typ ctx typ in + if is_stack_ctyp ctyp then + begin + try + (* We need to check that id's type hasn't changed due to flow typing *) + let _, ctyp' = Bindings.find id ctx.locals in + if ctyp_equal ctyp ctyp' then + AV_C_fragment (F_id id, typ, ctyp) + else + (* id's type changed due to flow + typing, so it's really still heap allocated! *) + v + with + (* Hack: Assuming global letbindings don't change from flow typing... *) + Not_found -> AV_C_fragment (F_id id, typ, ctyp) + end + else + v | Register (_, _, typ) when is_stack_typ ctx typ -> - AV_C_fragment (F_id id, typ) + let ctyp = ctyp_of_typ ctx typ in + if is_stack_ctyp ctyp then + AV_C_fragment (F_id id, typ, ctyp) + else + v | _ -> v end | AV_vector (v, typ) when is_bitvector v && List.length v <= 64 -> let bitstring = F_lit (V_bits (List.map value_of_aval_bit v)) in - AV_C_fragment (bitstring, typ) + AV_C_fragment (bitstring, typ, CT_fbits (List.length v, true)) | AV_tuple avals -> AV_tuple (List.map (c_aval ctx) avals) | aval -> aval @@ -325,7 +355,7 @@ let is_c_fragment = function | _ -> false let c_fragment = function - | AV_C_fragment (frag, _) -> frag + | AV_C_fragment (frag, _, _) -> frag | _ -> assert false let v_mask_lower i = F_lit (V_bits (Util.list_init i (fun _ -> Sail2_values.B1))) @@ -365,8 +395,9 @@ let rec analyze_functions ctx f (AE_aux (aexp, env, l)) = AE_for (id, aexp1, aexp2, aexp3, order, aexp4) | AE_case (aval, cases, typ) -> - let analyze_case (pat, aexp1, aexp2) = + let analyze_case (AP_aux (_, env, _) as pat, aexp1, aexp2) = let pat_bindings = Bindings.bindings (apat_types pat) in + let ctx = { ctx with local_env = env } in let ctx = List.fold_left (fun ctx (id, typ) -> { ctx with locals = Bindings.add id (Immutable, ctyp_of_typ ctx typ) ctx.locals }) ctx pat_bindings in @@ -392,85 +423,108 @@ let analyze_primop' ctx id args typ = c_debug (lazy ("Analyzing primop " ^ extern ^ "(" ^ Util.string_of_list ", " (fun aval -> Pretty_print_sail.to_string (pp_aval aval)) args ^ ")")); match extern, args with - | "eq_bits", [AV_C_fragment (v1, typ1); AV_C_fragment (v2, typ2)] -> - AE_val (AV_C_fragment (F_op (v1, "==", v2), typ)) - + | "eq_bits", [AV_C_fragment (v1, typ1, _); AV_C_fragment (v2, typ2, _)] -> + AE_val (AV_C_fragment (F_op (v1, "==", v2), typ, CT_bool)) +(* | "neq_bits", [AV_C_fragment (v1, typ1); AV_C_fragment (v2, typ2)] -> AE_val (AV_C_fragment (F_op (v1, "!=", v2), typ)) + *) - | "eq_int", [AV_C_fragment (v1, typ1); AV_C_fragment (v2, typ2)] -> - AE_val (AV_C_fragment (F_op (v1, "==", v2), typ)) + | "eq_int", [AV_C_fragment (v1, typ1, _); AV_C_fragment (v2, typ2, _)] -> + AE_val (AV_C_fragment (F_op (v1, "==", v2), typ, CT_bool)) | "zeros", [_] -> begin match destruct_vector ctx.tc_env typ with | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> - AE_val (AV_C_fragment (F_raw "0x0", typ)) + AE_val (AV_C_fragment (F_raw "0x0", typ, CT_fbits (Big_int.to_int n, true))) | _ -> no_change end - | "gteq", [AV_C_fragment (v1, _); AV_C_fragment (v2, _)] -> - AE_val (AV_C_fragment (F_op (v1, ">=", v2), typ)) + | "gteq", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_op (v1, ">=", v2), typ, CT_bool)) - | "xor_bits", [AV_C_fragment (v1, typ1); AV_C_fragment (v2, typ2)] -> - AE_val (AV_C_fragment (F_op (v1, "^", v2), typ)) + | "xor_bits", [AV_C_fragment (v1, typ1, ctyp); AV_C_fragment (v2, typ2, _)] -> + AE_val (AV_C_fragment (F_op (v1, "^", v2), typ, ctyp)) - | "or_bits", [AV_C_fragment (v1, typ1); AV_C_fragment (v2, typ2)] -> - AE_val (AV_C_fragment (F_op (v1, "|", v2), typ)) + | "or_bits", [AV_C_fragment (v1, typ1, ctyp); AV_C_fragment (v2, typ2, _)] -> + AE_val (AV_C_fragment (F_op (v1, "|", v2), typ, ctyp)) - | "and_bits", [AV_C_fragment (v1, typ1); AV_C_fragment (v2, typ2)] -> - AE_val (AV_C_fragment (F_op (v1, "&", v2), typ)) + | "and_bits", [AV_C_fragment (v1, typ1, ctyp); AV_C_fragment (v2, typ2, _)] -> + AE_val (AV_C_fragment (F_op (v1, "&", v2), typ, ctyp)) - | "not_bits", [AV_C_fragment (v, _)] -> + | "not_bits", [AV_C_fragment (v, _, ctyp)] -> begin match destruct_vector ctx.tc_env typ with | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> - AE_val (AV_C_fragment (F_op (F_unary ("~", v), "&", v_mask_lower (Big_int.to_int n)), typ)) + AE_val (AV_C_fragment (F_op (F_unary ("~", v), "&", v_mask_lower (Big_int.to_int n)), typ, ctyp)) | _ -> no_change end - | "vector_subrange", [AV_C_fragment (vec, _); AV_C_fragment (f, _); AV_C_fragment (t, _)] when is_stack_typ ctx typ -> + | "vector_subrange", [AV_C_fragment (vec, _, _); AV_C_fragment (f, _, _); AV_C_fragment (t, _, _)] + when is_fbits_typ ctx typ -> let len = F_op (f, "-", F_op (t, "-", v_one)) in - AE_val (AV_C_fragment (F_op (F_call ("safe_rshift", [F_raw "UINT64_MAX"; F_op (v_int 64, "-", len)]), "&", F_op (vec, ">>", t)), typ)) + AE_val (AV_C_fragment (F_op (F_call ("safe_rshift", [F_raw "UINT64_MAX"; F_op (v_int 64, "-", len)]), "&", F_op (vec, ">>", t)), + typ, + ctyp_of_typ ctx typ)) - | "vector_access", [AV_C_fragment (vec, _); AV_C_fragment (n, _)] -> - AE_val (AV_C_fragment (F_op (v_one, "&", F_op (vec, ">>", n)), typ)) + | "vector_access", [AV_C_fragment (vec, _, _); AV_C_fragment (n, _, _)] -> + AE_val (AV_C_fragment (F_op (v_one, "&", F_op (vec, ">>", n)), typ, CT_bit)) - | "eq_bit", [AV_C_fragment (a, _); AV_C_fragment (b, _)] -> - AE_val (AV_C_fragment (F_op (a, "==", b), typ)) + | "eq_bit", [AV_C_fragment (a, _, _); AV_C_fragment (b, _, _)] -> + AE_val (AV_C_fragment (F_op (a, "==", b), typ, CT_bool)) - | "slice", [AV_C_fragment (vec, _); AV_C_fragment (start, _); AV_C_fragment (len, _)] when is_stack_typ ctx typ -> - AE_val (AV_C_fragment (F_op (F_call ("safe_rshift", [F_raw "UINT64_MAX"; F_op (v_int 64, "-", len)]), "&", F_op (vec, ">>", start)), typ)) + | "slice", [AV_C_fragment (vec, _, _); AV_C_fragment (start, _, _); AV_C_fragment (len, _, _)] + when is_fbits_typ ctx typ -> + AE_val (AV_C_fragment (F_op (F_call ("safe_rshift", [F_raw "UINT64_MAX"; F_op (v_int 64, "-", len)]), "&", F_op (vec, ">>", start)), + typ, + ctyp_of_typ ctx typ)) | "undefined_bit", _ -> - AE_val (AV_C_fragment (F_lit (V_bit Sail2_values.B0), typ)) + AE_val (AV_C_fragment (F_lit (V_bit Sail2_values.B0), typ, CT_bit)) - | "undefined_vector", [AV_C_fragment (len, _); _] -> + | "undefined_vector", [AV_C_fragment (len, _, _); _] -> begin match destruct_vector ctx.tc_env typ with | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> - AE_val (AV_C_fragment (F_lit (V_bit Sail2_values.B0), typ)) + AE_val (AV_C_fragment (F_lit (V_bit Sail2_values.B0), typ, ctyp_of_typ ctx typ)) | _ -> no_change end - | "sail_uint", [AV_C_fragment (frag, vtyp)] -> + | "sail_unsigned", [AV_C_fragment (frag, vtyp, _)] -> begin match destruct_vector ctx.tc_env vtyp with | Some (Nexp_aux (Nexp_constant n, _), _, _) when Big_int.less_equal n (Big_int.of_int 63) && is_stack_typ ctx typ -> - AE_val (AV_C_fragment (frag, typ)) + AE_val (AV_C_fragment (F_call ("fast_unsigned", [frag]), typ, ctyp_of_typ ctx typ)) | _ -> no_change end - | "replicate_bits", [AV_C_fragment (vec, vtyp); AV_C_fragment (times, _)] -> + | "add_int", [AV_C_fragment (op1, _, _); AV_C_fragment (op2, _, _)] -> + begin match destruct_range Env.empty typ with + | None -> no_change + | Some (kids, constr, n, m) -> + match nexp_simp n, nexp_simp m with + | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) + when Big_int.less_equal min_int64 n && Big_int.less_equal m max_int64 -> + AE_val (AV_C_fragment (F_op (op1, "+", op2), typ, CT_int64)) + | n, m when prove ctx.local_env (nc_lteq (nconstant min_int64) n) && prove ctx.local_env (nc_lteq m (nconstant max_int64)) -> + AE_val (AV_C_fragment (F_op (op1, "+", op2), typ, CT_int64)) + | _ -> no_change + end + + | "neg_int", [AV_C_fragment (frag, _, _)] -> + AE_val (AV_C_fragment (F_op (v_int 0, "-", frag), typ, CT_int64)) + + | "replicate_bits", [AV_C_fragment (vec, vtyp, _); AV_C_fragment (times, _, _)] -> begin match destruct_vector ctx.tc_env typ, destruct_vector ctx.tc_env vtyp with | Some (Nexp_aux (Nexp_constant n, _), _, _), Some (Nexp_aux (Nexp_constant m, _), _, _) when Big_int.less_equal n (Big_int.of_int 64) -> - AE_val (AV_C_fragment (F_call ("fast_replicate_bits", [F_lit (V_int m); vec; times]), typ)) + AE_val (AV_C_fragment (F_call ("fast_replicate_bits", [F_lit (V_int m); vec; times]), typ, ctyp_of_typ ctx typ)) | _ -> no_change end | "undefined_bool", _ -> - AE_val (AV_C_fragment (F_lit (V_bool false), typ)) + AE_val (AV_C_fragment (F_lit (V_bool false), typ, CT_bool)) | _, _ -> c_debug (lazy ("No optimization routine found")); @@ -622,7 +676,10 @@ let rec chunkify n xs = | xs, ys -> xs :: chunkify n ys let rec compile_aval l ctx = function - | AV_C_fragment (frag, typ) -> + | AV_C_fragment (frag, typ, ctyp) -> + let ctyp' = ctyp_of_typ ctx typ in + if not (ctyp_equal ctyp ctyp') then + raise (Reporting.err_unreachable l __POS__ (string_of_ctyp ctyp ^ " != " ^ string_of_ctyp ctyp')); [], (frag, ctyp_of_typ ctx typ), [] | AV_id (id, typ) -> @@ -665,6 +722,8 @@ let rec compile_aval l ctx = function (F_id gs, CT_real), [iclear CT_real gs] + | AV_lit (L_aux (L_unit, _), _) -> [], (F_lit V_unit, CT_unit), [] + | AV_lit (L_aux (_, l) as lit, _) -> c_error ~loc:l ("Encountered unexpected literal " ^ string_of_lit lit) @@ -706,9 +765,9 @@ let rec compile_aval l ctx = function let len = List.length avals in match destruct_vector ctx.tc_env typ with | Some (_, Ord_aux (Ord_inc, _), _) -> - [], (bitstring, CT_bits64 (len, false)), [] + [], (bitstring, CT_fbits (len, false)), [] | Some (_, Ord_aux (Ord_dec, _), _) -> - [], (bitstring, CT_bits64 (len, true)), [] + [], (bitstring, CT_fbits (len, true)), [] | Some _ -> c_error "Encountered order polymorphic bitvector literal" | None -> @@ -723,12 +782,12 @@ let rec compile_aval l ctx = function let first_chunk = bitstring (Util.take (len mod 64) avals) in let chunks = Util.drop (len mod 64) avals |> chunkify 64 |> List.map bitstring in let gs = gensym () in - [iinit (CT_bits true) gs (first_chunk, CT_bits64 (len mod 64, true))] - @ List.map (fun chunk -> ifuncall (CL_id (gs, CT_bits true)) + [iinit (CT_lbits true) gs (first_chunk, CT_fbits (len mod 64, true))] + @ List.map (fun chunk -> ifuncall (CL_id (gs, CT_lbits true)) (mk_id "append_64") - [(F_id gs, CT_bits true); (chunk, CT_bits64 (64, true))]) chunks, - (F_id gs, CT_bits true), - [iclear (CT_bits true) gs] + [(F_id gs, CT_lbits true); (chunk, CT_fbits (64, true))]) chunks, + (F_id gs, CT_lbits true), + [iclear (CT_lbits true) gs] (* If we have a bitvector value, that isn't a literal then we need to set bits individually. *) | AV_vector (avals, Typ_aux (Typ_app (id, [_; Typ_arg_aux (Typ_arg_order ord, _); Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id bit_id, _)), _)]), _)) @@ -740,7 +799,7 @@ let rec compile_aval l ctx = function | Ord_aux (Ord_var _, _) -> c_error "Polymorphic vector direction found" in let gs = gensym () in - let ctyp = CT_bits64 (len, direction) in + let ctyp = CT_fbits (len, direction) in let mask i = V_bits (Util.list_init (63 - i) (fun _ -> Sail2_values.B0) @ [Sail2_values.B1] @ Util.list_init i (fun _ -> Sail2_values.B0)) in let aval_mask i aval = let setup, cval, cleanup = compile_aval l ctx aval in @@ -988,7 +1047,7 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = let compile_case (apat, guard, body) = let trivial_guard = match guard with | AE_aux (AE_val (AV_lit (L_aux (L_true, _), _)), _, _) - | AE_aux (AE_val (AV_C_fragment (F_lit (V_bool true), _)), _, _) -> true + | AE_aux (AE_val (AV_C_fragment (F_lit (V_bool true), _, _)), _, _) -> true | _ -> false in let case_label = label "case_" in @@ -1029,7 +1088,7 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = let compile_case (apat, guard, body) = let trivial_guard = match guard with | AE_aux (AE_val (AV_lit (L_aux (L_true, _), _)), _, _) - | AE_aux (AE_val (AV_C_fragment (F_lit (V_bool true), _)), _, _) -> true + | AE_aux (AE_val (AV_C_fragment (F_lit (V_bool true), _, _)), _, _) -> true | _ -> false in let try_label = label "try_" in @@ -1736,7 +1795,7 @@ let rec instrs_rename from_id to_id = | [] -> [] let hoist_ctyp = function - | CT_int | CT_bits _ | CT_struct _ -> true + | CT_int | CT_lbits _ | CT_struct _ -> true | _ -> false let hoist_counter = ref 0 @@ -1797,39 +1856,39 @@ let flat_id () = incr flat_counter; id -let flatten_instrs = - let rec flatten = function - | I_aux (I_decl (ctyp, decl_id), aux) :: instrs -> - let fid = flat_id () in - I_aux (I_decl (ctyp, fid), aux) :: flatten (instrs_rename decl_id fid instrs) - - | I_aux ((I_block block | I_try_block block), _) :: instrs -> - flatten block @ flatten instrs - - | I_aux (I_if (cval, then_instrs, else_instrs, _), _) :: instrs -> - let then_label = label "then_" in - let endif_label = label "endif_" in - [ijump cval then_label] - @ flatten else_instrs - @ [igoto endif_label] - @ [ilabel then_label] - @ flatten then_instrs - @ [ilabel endif_label] - @ flatten instrs - - | I_aux (I_comment _, _) :: instrs -> flatten instrs - - | instr :: instrs -> instr :: flatten instrs - | [] -> [] - in +let rec flatten_instrs = function + | I_aux (I_decl (ctyp, decl_id), aux) :: instrs -> + let fid = flat_id () in + I_aux (I_decl (ctyp, fid), aux) :: flatten_instrs (instrs_rename decl_id fid instrs) + + | I_aux ((I_block block | I_try_block block), _) :: instrs -> + flatten_instrs block @ flatten_instrs instrs + + | I_aux (I_if (cval, then_instrs, else_instrs, _), _) :: instrs -> + let then_label = label "then_" in + let endif_label = label "endif_" in + [ijump cval then_label] + @ flatten_instrs else_instrs + @ [igoto endif_label] + @ [ilabel then_label] + @ flatten_instrs then_instrs + @ [ilabel endif_label] + @ flatten_instrs instrs + + | I_aux (I_comment _, _) :: instrs -> flatten_instrs instrs + + | instr :: instrs -> instr :: flatten_instrs instrs + | [] -> [] + +let flatten_cdef = function | CDEF_fundef (function_id, heap_return, args, body) -> flat_counter := 0; - CDEF_fundef (function_id, heap_return, args, flatten body) + CDEF_fundef (function_id, heap_return, args, flatten_instrs body) | CDEF_let (n, bindings, instrs) -> flat_counter := 0; - CDEF_let (n, bindings, flatten instrs) + CDEF_let (n, bindings, flatten_instrs instrs) | cdef -> cdef @@ -1960,75 +2019,98 @@ let sort_ctype_defs cdefs = ctype_defs @ cdefs - (* -(* When this optimization fires we know we have bytecode of the form - - recreate x : S; x = y; ... - - when this continues with x.A = a, x.B = b etc until y = x. Then - provided there are no further references to x we can eliminate - the variable x. - - Must be called after hoist_allocations, otherwise does nothing. *) -let fix_struct_updates ctx = - (* FIXME need to check no remaining references *) - let rec fix_updates struct_id id = function - | I_aux (I_copy (CL_field (struct_id', field, ctyp), cval), aux) :: instrs - when Id.compare struct_id struct_id' = 0 -> - Util.option_map (fun instrs -> I_aux (I_copy (CL_field (id, field, ctyp), cval), aux) :: instrs) (fix_updates struct_id id instrs) - | I_aux (I_copy (CL_id id', (F_id struct_id', ctyp)), aux) :: instrs - when Id.compare struct_id struct_id' = 0 && Id.compare id id' = 0-> - Some instrs - | _ -> None +let removed = icomment "REMOVED" + +let is_not_removed = function + | I_aux (I_comment "REMOVED", _) -> false + | _ -> true + +(** This optimization looks for patterns of the form: + + create x : t; + x = y; + // modifications to x, and no changes to y + y = x; + // no further changes to x + kill x; + + If found, we can remove the variable x, and directly modify y instead. *) +let remove_alias ctx = + let pattern ctyp id = + let alias = ref None in + let rec scan ctyp id n instrs = + match n, !alias, instrs with + | 0, None, I_aux (I_copy (CL_id (id', ctyp'), (F_id a, ctyp'')), _) :: instrs + when Id.compare id id' = 0 && ctyp_equal ctyp ctyp' && ctyp_equal ctyp' ctyp'' -> + alias := Some a; + scan ctyp id 1 instrs + + | 1, Some a, I_aux (I_copy (CL_id (a', ctyp'), (F_id id', ctyp'')), _) :: instrs + when Id.compare a a' = 0 && Id.compare id id' = 0 && ctyp_equal ctyp ctyp' && ctyp_equal ctyp' ctyp'' -> + scan ctyp id 2 instrs + + | 1, Some a, instr :: instrs -> + if IdSet.mem a (instr_ids instr) then + None + else + scan ctyp id 1 instrs + + | 2, Some a, I_aux (I_clear (ctyp', id'), _) :: instrs + when Id.compare id id' = 0 && ctyp_equal ctyp ctyp' -> + scan ctyp id 2 instrs + + | 2, Some a, instr :: instrs -> + if IdSet.mem id (instr_ids instr) then + None + else + scan ctyp id 2 instrs + + | 2, Some a, [] -> !alias + + | n, _, _ :: instrs when n = 0 || n > 2 -> scan ctyp id n instrs + | _, _, I_aux (_, (_, l)) :: instrs -> raise (Reporting.err_unreachable l __POS__ "optimize_alias") + | _, _, [] -> None + in + scan ctyp id 0 in - let rec fix_updates_ret struct_id id = function - | I_aux (I_copy (CL_field (struct_id', field, ctyp), cval), aux) :: instrs - when Id.compare struct_id struct_id' = 0 -> - Util.option_map (fun instrs -> I_aux (I_copy (CL_addr_field (id, field, ctyp), cval), aux) :: instrs) (fix_updates_ret struct_id id instrs) - | I_aux (I_copy (CL_addr id', (F_id struct_id', ctyp)), aux) :: instrs - when Id.compare struct_id struct_id' = 0 && Id.compare id id' = 0-> - Some instrs - | _ -> None + let remove_alias id alias = function + | I_aux (I_copy (CL_id (id', _), (F_id alias', _)), _) + when Id.compare id id' = 0 && Id.compare alias alias' = 0 -> removed + | I_aux (I_copy (CL_id (alias', _), (F_id id', _)), _) + when Id.compare id id' = 0 && Id.compare alias alias' = 0 -> removed + | I_aux (I_clear (_, id'), _) -> removed + | instr -> instr in - let rec opt hr = function - | (I_aux (I_reset (ctyp, struct_id), _) as instr1) - :: (I_aux (I_copy (CL_id (struct_id', _), (F_id id, ctyp')), _) as instr2) - :: instrs - when is_ct_struct ctyp && ctyp_equal ctyp ctyp' && Id.compare struct_id struct_id' = 0 -> - begin match fix_updates struct_id id instrs with - | None -> instr1 :: instr2 :: opt hr instrs - | Some updated -> opt hr updated + let rec opt = function + | I_aux (I_decl (ctyp, id), _) as instr :: instrs -> + begin match pattern ctyp id instrs with + | None -> instr :: opt instrs + | Some alias -> + let instrs = List.map (map_instr (remove_alias id alias)) instrs in + filter_instrs is_not_removed (List.map (instr_rename id alias) instrs) end - | (I_aux (I_reset (ctyp, struct_id), _) as instr) :: instrs - when is_ct_struct ctyp && Util.is_some hr -> - let id = match hr with Some id -> id | None -> assert false in - begin match fix_updates_ret struct_id id instrs with - | None -> instr :: opt hr instrs - | Some updated -> opt hr updated - end - - | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (opt hr block), aux) :: opt hr instrs - | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (opt hr block), aux) :: opt hr instrs + | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (opt block), aux) :: opt instrs + | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (opt block), aux) :: opt instrs | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> - I_aux (I_if (cval, opt hr then_instrs, opt hr else_instrs, ctyp), aux) :: opt hr instrs + I_aux (I_if (cval, opt then_instrs, opt else_instrs, ctyp), aux) :: opt instrs - | instr :: instrs -> instr :: opt hr instrs + | instr :: instrs -> + instr :: opt instrs | [] -> [] in function | CDEF_fundef (function_id, heap_return, args, body) -> - [CDEF_fundef (function_id, heap_return, args, opt heap_return body)] + [CDEF_fundef (function_id, heap_return, args, opt body)] | cdef -> [cdef] - *) let concatMap f xs = List.concat (List.map f xs) let optimize ctx cdefs = let nothing cdefs = cdefs in cdefs + |> (if !optimize_alias then concatMap (remove_alias ctx) else nothing) |> (if !optimize_hoist_allocations then concatMap (hoist_allocations ctx) else nothing) -(* |> (if !optimize_struct_updates then concatMap (fix_struct_updates ctx) else nothing) *) (**************************************************************************) (* 6. Code generation *) @@ -2041,10 +2123,11 @@ let rec sgen_ctyp = function | CT_unit -> "unit" | CT_bit -> "mach_bits" | CT_bool -> "bool" - | CT_bits64 _ -> "mach_bits" + | CT_fbits _ -> "mach_bits" + | CT_sbits _ -> "sbits" | CT_int64 -> "mach_int" | CT_int -> "sail_int" - | CT_bits _ -> "sail_bits" + | CT_lbits _ -> "sail_bits" | CT_tup _ as tup -> "struct " ^ Util.zencode_string ("tuple_" ^ string_of_ctyp tup) | CT_struct (id, _) -> "struct " ^ sgen_id id | CT_enum (id, _) -> "enum " ^ sgen_id id @@ -2060,10 +2143,11 @@ let rec sgen_ctyp_name = function | CT_unit -> "unit" | CT_bit -> "mach_bits" | CT_bool -> "bool" - | CT_bits64 _ -> "mach_bits" + | CT_fbits _ -> "mach_bits" + | CT_sbits _ -> "sbits" | CT_int64 -> "mach_int" | CT_int -> "sail_int" - | CT_bits _ -> "sail_bits" + | CT_lbits _ -> "sail_bits" | CT_tup _ as tup -> Util.zencode_string ("tuple_" ^ string_of_ctyp tup) | CT_struct (id, _) -> sgen_id id | CT_enum (id, _) -> sgen_id id @@ -2077,9 +2161,11 @@ let rec sgen_ctyp_name = function let sgen_cval_param (frag, ctyp) = match ctyp with - | CT_bits direction -> + | CT_lbits direction -> + string_of_fragment frag ^ ", " ^ string_of_bool direction + | CT_sbits direction -> string_of_fragment frag ^ ", " ^ string_of_bool direction - | CT_bits64 (len, direction) -> + | CT_fbits (len, direction) -> string_of_fragment frag ^ ", UINT64_C(" ^ string_of_int len ^ ") , " ^ string_of_bool direction | _ -> string_of_fragment frag @@ -2208,25 +2294,25 @@ let rec codegen_instr fid ctx (I_aux (instr, (_, l))) = end | "vector_update_subrange", _ -> Printf.sprintf "vector_update_subrange_%s" (sgen_ctyp_name ctyp) | "vector_subrange", _ -> Printf.sprintf "vector_subrange_%s" (sgen_ctyp_name ctyp) - | "vector_update", CT_bits64 _ -> "update_mach_bits" - | "vector_update", CT_bits _ -> "update_sail_bits" + | "vector_update", CT_fbits _ -> "update_mach_bits" + | "vector_update", CT_lbits _ -> "update_sail_bits" | "vector_update", _ -> Printf.sprintf "vector_update_%s" (sgen_ctyp_name ctyp) | "string_of_bits", _ -> begin match cval_ctyp (List.nth args 0) with - | CT_bits64 _ -> "string_of_mach_bits" - | CT_bits _ -> "string_of_sail_bits" + | CT_fbits _ -> "string_of_mach_bits" + | CT_lbits _ -> "string_of_sail_bits" | _ -> assert false end | "decimal_string_of_bits", _ -> begin match cval_ctyp (List.nth args 0) with - | CT_bits64 _ -> "decimal_string_of_mach_bits" - | CT_bits _ -> "decimal_string_of_sail_bits" + | CT_fbits _ -> "decimal_string_of_mach_bits" + | CT_lbits _ -> "decimal_string_of_sail_bits" | _ -> assert false end | "internal_vector_update", _ -> Printf.sprintf "internal_vector_update_%s" (sgen_ctyp_name ctyp) | "internal_vector_init", _ -> Printf.sprintf "internal_vector_init_%s" (sgen_ctyp_name ctyp) - | "undefined_vector", CT_bits64 _ -> "UNDEFINED(mach_bits)" - | "undefined_vector", CT_bits _ -> "UNDEFINED(sail_bits)" + | "undefined_vector", CT_fbits _ -> "UNDEFINED(mach_bits)" + | "undefined_vector", CT_lbits _ -> "UNDEFINED(sail_bits)" | "undefined_bit", _ -> "UNDEFINED(mach_bits)" | "undefined_vector", _ -> Printf.sprintf "UNDEFINED(vector_%s)" (sgen_ctyp_name ctyp) | fname, _ -> fname @@ -2285,7 +2371,7 @@ let rec codegen_instr fid ctx (I_aux (instr, (_, l))) = | CT_unit -> "UNIT", [] | CT_bit -> "UINT64_C(0)", [] | CT_int64 -> "INT64_C(0xdeadc0de)", [] - | CT_bits64 _ -> "UINT64_C(0xdeadc0de)", [] + | CT_fbits _ -> "UINT64_C(0xdeadc0de)", [] | CT_bool -> "false", [] | CT_enum (_, ctor :: _) -> sgen_id ctor, [] | CT_tup ctyps when is_stack_ctyp ctyp -> @@ -2901,7 +2987,7 @@ let rec ctyp_dependencies = function | CT_ref ctyp -> ctyp_dependencies ctyp | CT_struct (_, ctors) -> List.concat (List.map (fun (_, ctyp) -> ctyp_dependencies ctyp) ctors) | CT_variant (_, ctors) -> List.concat (List.map (fun (_, ctyp) -> ctyp_dependencies ctyp) ctors) - | CT_int | CT_int64 | CT_bits _ | CT_bits64 _ | CT_unit | CT_bool | CT_real | CT_bit | CT_string | CT_enum _ | CT_poly -> [] + | CT_int | CT_int64 | CT_lbits _ | CT_fbits _ | CT_sbits _ | CT_unit | CT_bool | CT_real | CT_bit | CT_string | CT_enum _ | CT_poly -> [] let codegen_ctg ctx = function | CTG_vector (direction, ctyp) -> codegen_vector ctx (direction, ctyp) diff --git a/src/c_backend.mli b/src/c_backend.mli index 6048f6b6..b39f58e2 100644 --- a/src/c_backend.mli +++ b/src/c_backend.mli @@ -64,17 +64,25 @@ val opt_no_main : bool ref val optimize_primops : bool ref val optimize_hoist_allocations : bool ref val optimize_struct_updates : bool ref +val optimize_alias : bool ref (** The compilation context. *) type ctx +(** Convert a typ to a IR ctyp *) +val ctyp_of_typ : ctx -> Ast.typ -> ctyp + (** Create a context from a typechecking environment. This environment should be the environment returned by typechecking the full AST. *) val initial_ctx : Env.t -> ctx +val compile_aexp : ctx -> Ast.typ Anf.aexp -> instr list * (clexp -> instr) * instr list + val compile_ast : ctx -> string list -> tannot Ast.defs -> unit val bytecode_ast : ctx -> (cdef list -> cdef list) -> tannot Ast.defs -> cdef list (** Rewriting steps for compiled ASTs *) -val flatten_instrs : cdef -> cdef +val flatten_instrs : instr list -> instr list + +val flatten_cdef : cdef -> cdef diff --git a/src/constant_fold.ml b/src/constant_fold.ml index 407bd69a..f22b48de 100644 --- a/src/constant_fold.ml +++ b/src/constant_fold.ml @@ -100,6 +100,7 @@ let safe_primops = "prerr_string"; "read_ram"; "write_ram"; + "get_time_ns"; "Elf_loader.elf_entry"; "Elf_loader.elf_tohost" ] diff --git a/src/isail.ml b/src/isail.ml index 55f08f17..83bff3f3 100644 --- a/src/isail.ml +++ b/src/isail.ml @@ -57,6 +57,7 @@ open Pretty_print_sail type mode = | Evaluation of frame + | Bytecode of Value2.vl Bytecode_interpreter.gstate * Value2.vl Bytecode_interpreter.stack | Normal let current_mode = ref Normal @@ -65,6 +66,7 @@ let prompt () = match !current_mode with | Normal -> "sail> " | Evaluation _ -> "eval> " + | Bytecode _ -> "ir> " let eval_clear = ref true @@ -72,6 +74,7 @@ let mode_clear () = match !current_mode with | Normal -> () | Evaluation _ -> if !eval_clear then LNoise.clear_screen () else () + | Bytecode _ -> () (* if !eval_clear then LNoise.clear_screen () else () *) let rec user_input callback = match LNoise.linenoise (prompt ()) with @@ -105,16 +108,35 @@ let vs_ids = ref (Initial_check.val_spec_ids !interactive_ast) let interactive_state = ref (initial_state !interactive_ast Value.primops) +let interactive_bytecode = ref [] + +let sep = "-----------------------------------------------------" |> Util.blue |> Util.clear + let print_program () = match !current_mode with | Normal -> () | Evaluation (Step (out, _, _, stack)) -> - let sep = "-----------------------------------------------------" |> Util.blue |> Util.clear in List.map stack_string stack |> List.rev |> List.iter (fun code -> print_endline (Lazy.force code); print_endline sep); print_endline (Lazy.force out) | Evaluation (Done (_, v)) -> print_endline (Value.string_of_value v |> Util.green |> Util.clear) | Evaluation _ -> () + | Bytecode (_, stack) -> + let open Bytecode_interpreter in + let open Bytecode_util in + let pc = stack.top.pc in + let instrs = stack.top.instrs in + for i = 0 to stack.top.pc - 1 do + print_endline (" " ^ Pretty_print_sail.to_string (pp_instr instrs.(i))) + done; + print_endline (">> " ^ Pretty_print_sail.to_string (pp_instr instrs.(stack.top.pc))); + for i = stack.top.pc + 1 to Array.length instrs - 1 do + print_endline (" " ^ Pretty_print_sail.to_string (pp_instr instrs.(i))) + done; + print_endline sep; + print_endline (Util.string_of_list ", " + (fun (id, vl) -> Printf.sprintf "%s = %s" (string_of_id id) (string_of_value vl)) + (Bindings.bindings stack.top.locals)) let rec run () = match !current_mode with @@ -138,6 +160,7 @@ let rec run () = print_endline "Breakpoint"; current_mode := Evaluation frame end + | Bytecode _ -> () let rec run_steps n = print_endline ("step " ^ string_of_int n); @@ -163,6 +186,7 @@ let rec run_steps n = print_endline "Breakpoint"; current_mode := Evaluation frame end + | Bytecode _ -> () let help = function | ":t" | ":type" -> @@ -232,6 +256,8 @@ let handle_input' input = | Command (cmd, arg) -> begin match cmd with + | ":n" | ":normal" -> + current_mode := Normal | ":t" | ":type" -> let typq, typ = Type_check.Env.get_val_spec (mk_id arg) !interactive_env in pretty_sail stdout (doc_binding (typq, typ)); @@ -286,18 +312,25 @@ let handle_input' input = interactive_state := initial_state !interactive_ast Value.primops | ":pretty" -> print_endline (Pretty_print_sail.to_string (Latex.defs !interactive_ast)) - | ":bytecode" -> + | ":compile" -> let open PPrint in let open C_backend in let ast = Process_file.rewrite_ast_c !interactive_ast in let ast, env = Specialize.specialize ast !interactive_env in let ctx = initial_ctx env in - let byte_ast = bytecode_ast ctx (List.map flatten_instrs) ast in - let chan = open_out arg in - Util.opt_colors := false; - Pretty_print_sail.pretty_sail chan (separate_map hardline Bytecode_util.pp_cdef byte_ast); - Util.opt_colors := true; - close_out chan + interactive_bytecode := bytecode_ast ctx (List.map flatten_cdef) ast + | ":ir" -> + print_endline arg; + let open Bytecode in + let open Bytecode_util in + let open PPrint in + let is_cdef = function + | CDEF_fundef (id, _, _, _) when Id.compare id (mk_id arg) = 0 -> true + | CDEF_spec (id, _, _) when Id.compare id (mk_id arg) = 0 -> true + | _ -> false + in + let cdefs = List.filter is_cdef !interactive_bytecode in + print_endline (Pretty_print_sail.to_string (separate_map hardline pp_cdef cdefs)) | ":ast" -> let chan = open_out arg in Pretty_print_sail.pp_defs chan !interactive_ast; @@ -335,6 +368,16 @@ let handle_input' input = vs_ids := Initial_check.val_spec_ids !interactive_ast; (* See initial_check.mli for an explanation of why we need this. *) Initial_check.have_undefined_builtins := false + | ":exec" -> + let open Bytecode_interpreter in + let exp = Type_check.infer_exp !interactive_env (Initial_check.exp_of_string Ast_util.dec_ord arg) in + let anf = Anf.anf exp in + let ctx = C_backend.initial_ctx !interactive_env in + let ctyp = C_backend.ctyp_of_typ ctx (Type_check.typ_of exp) in + let setup, call, cleanup = C_backend.compile_aexp ctx anf in + let instrs = C_backend.flatten_instrs (setup @ [call (CL_id (mk_id "interactive#", ctyp))] @ cleanup) in + current_mode := Bytecode (new_gstate !interactive_bytecode, new_stack instrs); + print_program () | _ -> unrecognised_command cmd end | Expression str -> @@ -346,44 +389,51 @@ let handle_input' input = | Empty -> () end | Evaluation frame -> - begin - match input with - | Command (cmd, arg) -> - (* Evaluation mode commands *) - begin - match cmd with - | ":r" | ":run" -> - run () - | ":s" | ":step" -> - run_steps (int_of_string arg) - | ":n" | ":normal" -> - current_mode := Normal - | _ -> unrecognised_command cmd - end - | Expression str -> - print_endline "Already evaluating expression" - | Empty -> - (* Empty input will evaluate one step, or switch back to + begin match input with + | Command (cmd, arg) -> + (* Evaluation mode commands *) + begin + match cmd with + | ":r" | ":run" -> + run () + | ":s" | ":step" -> + run_steps (int_of_string arg) + | _ -> unrecognised_command cmd + end + | Expression str -> + print_endline "Already evaluating expression" + | Empty -> + (* Empty input will evaluate one step, or switch back to normal mode when evaluation is completed. *) - begin - match frame with - | Done (state, v) -> + begin match frame with + | Done (state, v) -> + interactive_state := state; + print_endline ("Result = " ^ Value.string_of_value v); + current_mode := Normal + | Step (out, state, _, stack) -> + begin + try interactive_state := state; - print_endline ("Result = " ^ Value.string_of_value v); - current_mode := Normal - | Step (out, state, _, stack) -> - begin - try - interactive_state := state; - current_mode := Evaluation (eval_frame frame); - print_program () - with - | Failure str -> print_endline str; current_mode := Normal - end - | Break frame -> - print_endline "Breakpoint"; - current_mode := Evaluation frame - end + current_mode := Evaluation (eval_frame frame); + print_program () + with + | Failure str -> print_endline str; current_mode := Normal + end + | Break frame -> + print_endline "Breakpoint"; + current_mode := Evaluation frame + end + end + | Bytecode (gstate, stack) -> + begin match input with + | Command (cmd, arg) -> + () + | Expression str -> + print_endline "Evaluating IR, cannot evaluate expression" + | Empty -> + let gstate, stack = Bytecode_interpreter.step (gstate, stack) in + current_mode := Bytecode (gstate, stack); + print_program () end let handle_input input = diff --git a/src/sail.ml b/src/sail.ml index c9cead2a..44766926 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -128,7 +128,8 @@ let options = Arg.align ([ Arg.Set C_backend.optimize_hoist_allocations; Arg.Set Initial_check.opt_fast_undefined; Arg.Set Type_check.opt_no_effects; - Arg.Set C_backend.optimize_struct_updates ], + Arg.Set C_backend.optimize_struct_updates; + Arg.Set C_backend.optimize_alias], " turn on optimizations for C compilation"); ( "-Oconstant_fold", Arg.Set Constant_fold.optimize_constant_fold, -- cgit v1.2.3 From 2e271d91c58a2d4db4adbb4c47d34bcbe1a6992e Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Fri, 23 Nov 2018 22:05:24 +0000 Subject: Introduce intermediate bitvector representation in C Bitvectors that aren't fixed size, but can still be shown to fit within 64-bits, now have a specialised representation. Still need to introduce more optimized functions, as right now we mostly have to convert them into large bitvectors to pass them into most functions. Nevertheless, this doubles the performance of the TLBLookup function in ARMv8. --- src/c_backend.ml | 87 +++++++++++++++++++++++++++++++++----------------------- 1 file changed, 51 insertions(+), 36 deletions(-) (limited to 'src') diff --git a/src/c_backend.ml b/src/c_backend.ml index 2bac9945..3d281337 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -168,7 +168,7 @@ let rec ctyp_of_typ ctx typ = let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in begin match nexp_simp n with | Nexp_aux (Nexp_constant n, _) when Big_int.less_equal n (Big_int.of_int 64) -> CT_fbits (Big_int.to_int n, direction) - | n when ctx.optimize_z3 && prove ctx.local_env (nc_lteq n (nint 64)) -> CT_lbits direction (* TODO: CT_sbits direction *) + | n when ctx.optimize_z3 && prove ctx.local_env (nc_lteq n (nint 64)) -> CT_sbits direction | _ -> CT_lbits direction end @@ -372,9 +372,10 @@ let rec analyze_functions ctx f (AE_aux (aexp, env, l)) = | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, aval, analyze_functions ctx f aexp) - | AE_let (mut, id, typ1, aexp1, aexp2, typ2) -> + | AE_let (mut, id, typ1, aexp1, (AE_aux (_, env2, _) as aexp2), typ2) -> let aexp1 = analyze_functions ctx f aexp1 in - let ctyp1 = ctyp_of_typ ctx typ1 in + (* Use aexp2's environment because it will contain constraints for id *) + let ctyp1 = ctyp_of_typ { ctx with local_env = env2 } typ1 in let ctx = { ctx with locals = Bindings.add id (mut, ctyp1) ctx.locals } in AE_let (mut, id, typ1, aexp1, analyze_functions ctx f aexp2, typ2) @@ -423,12 +424,15 @@ let analyze_primop' ctx id args typ = c_debug (lazy ("Analyzing primop " ^ extern ^ "(" ^ Util.string_of_list ", " (fun aval -> Pretty_print_sail.to_string (pp_aval aval)) args ^ ")")); match extern, args with - | "eq_bits", [AV_C_fragment (v1, typ1, _); AV_C_fragment (v2, typ2, _)] -> + | "eq_bits", [AV_C_fragment (v1, _, CT_fbits _); AV_C_fragment (v2, _, _)] -> AE_val (AV_C_fragment (F_op (v1, "==", v2), typ, CT_bool)) -(* - | "neq_bits", [AV_C_fragment (v1, typ1); AV_C_fragment (v2, typ2)] -> - AE_val (AV_C_fragment (F_op (v1, "!=", v2), typ)) - *) + | "eq_bits", [AV_C_fragment (v1, _, CT_sbits _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_call ("eq_sbits", [v1; v2]), typ, CT_bool)) + + | "neq_bits", [AV_C_fragment (v1, _, CT_fbits _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_op (v1, "!=", v2), typ, CT_bool)) + | "neq_bits", [AV_C_fragment (v1, _, CT_sbits _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_call ("neq_sbits", [v1; v2]), typ, CT_bool)) | "eq_int", [AV_C_fragment (v1, typ1, _); AV_C_fragment (v2, typ2, _)] -> AE_val (AV_C_fragment (F_op (v1, "==", v2), typ, CT_bool)) @@ -444,13 +448,15 @@ let analyze_primop' ctx id args typ = | "gteq", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> AE_val (AV_C_fragment (F_op (v1, ">=", v2), typ, CT_bool)) - | "xor_bits", [AV_C_fragment (v1, typ1, ctyp); AV_C_fragment (v2, typ2, _)] -> + | "xor_bits", [AV_C_fragment (v1, _, (CT_fbits _ as ctyp)); AV_C_fragment (v2, _, CT_fbits _)] -> AE_val (AV_C_fragment (F_op (v1, "^", v2), typ, ctyp)) + | "xor_bits", [AV_C_fragment (v1, _, (CT_sbits _ as ctyp)); AV_C_fragment (v2, _, CT_sbits _)] -> + AE_val (AV_C_fragment (F_call ("xor_sbits", [v1; v2]), typ, ctyp)) - | "or_bits", [AV_C_fragment (v1, typ1, ctyp); AV_C_fragment (v2, typ2, _)] -> + | "or_bits", [AV_C_fragment (v1, _, (CT_fbits _ as ctyp)); AV_C_fragment (v2, _, CT_fbits _)] -> AE_val (AV_C_fragment (F_op (v1, "|", v2), typ, ctyp)) - | "and_bits", [AV_C_fragment (v1, typ1, ctyp); AV_C_fragment (v2, typ2, _)] -> + | "and_bits", [AV_C_fragment (v1, _, (CT_fbits _ as ctyp)); AV_C_fragment (v2, _, CT_fbits _)] -> AE_val (AV_C_fragment (F_op (v1, "&", v2), typ, ctyp)) | "not_bits", [AV_C_fragment (v, _, ctyp)] -> @@ -461,25 +467,29 @@ let analyze_primop' ctx id args typ = | _ -> no_change end - | "vector_subrange", [AV_C_fragment (vec, _, _); AV_C_fragment (f, _, _); AV_C_fragment (t, _, _)] + | "vector_subrange", [AV_C_fragment (vec, _, CT_fbits _); AV_C_fragment (f, _, _); AV_C_fragment (t, _, _)] when is_fbits_typ ctx typ -> let len = F_op (f, "-", F_op (t, "-", v_one)) in AE_val (AV_C_fragment (F_op (F_call ("safe_rshift", [F_raw "UINT64_MAX"; F_op (v_int 64, "-", len)]), "&", F_op (vec, ">>", t)), typ, ctyp_of_typ ctx typ)) - | "vector_access", [AV_C_fragment (vec, _, _); AV_C_fragment (n, _, _)] -> + | "vector_access", [AV_C_fragment (vec, _, CT_fbits _); AV_C_fragment (n, _, _)] -> AE_val (AV_C_fragment (F_op (v_one, "&", F_op (vec, ">>", n)), typ, CT_bit)) | "eq_bit", [AV_C_fragment (a, _, _); AV_C_fragment (b, _, _)] -> AE_val (AV_C_fragment (F_op (a, "==", b), typ, CT_bool)) - | "slice", [AV_C_fragment (vec, _, _); AV_C_fragment (start, _, _); AV_C_fragment (len, _, _)] + | "slice", [AV_C_fragment (vec, _, CT_fbits _); AV_C_fragment (start, _, _); AV_C_fragment (len, _, _)] when is_fbits_typ ctx typ -> AE_val (AV_C_fragment (F_op (F_call ("safe_rshift", [F_raw "UINT64_MAX"; F_op (v_int 64, "-", len)]), "&", F_op (vec, ">>", start)), typ, ctyp_of_typ ctx typ)) + | "slice", [AV_C_fragment (vec, _, CT_fbits _); AV_C_fragment (start, _, _); AV_C_fragment (len, _, _)] + when is_sbits_typ ctx typ -> + AE_val (AV_C_fragment (F_call ("sslice", [vec; start; len]), typ, ctyp_of_typ ctx typ)) + | "undefined_bit", _ -> AE_val (AV_C_fragment (F_lit (V_bit Sail2_values.B0), typ, CT_bit)) @@ -1021,8 +1031,8 @@ let pointer_assign ctyp1 ctyp2 = let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = let ctx = { ctx with local_env = env } in match aexp_aux with - | AE_let (mut, id, binding_typ, binding, body, body_typ) -> - let binding_ctyp = ctyp_of_typ ctx binding_typ in + | AE_let (mut, id, binding_typ, binding, (AE_aux (_, body_env, _) as body), body_typ) -> + let binding_ctyp = ctyp_of_typ { ctx with local_env = body_env } binding_typ in let setup, call, cleanup = compile_aexp ctx binding in let letb_setup, letb_cleanup = [idecl binding_ctyp id; iblock (setup @ [call (CL_id (id, binding_ctyp))] @ cleanup)], [iclear binding_ctyp id] @@ -1201,7 +1211,11 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = [] | AE_assign (id, assign_typ, aexp) -> - let assign_ctyp = ctyp_of_typ ctx assign_typ in + let assign_ctyp = + match Bindings.find_opt id ctx.locals with + | Some (_, ctyp) -> ctyp + | None -> ctyp_of_typ ctx assign_typ + in let setup, call, cleanup = compile_aexp ctx aexp in setup @ [call (CL_id (id, assign_ctyp))], (fun clexp -> icopy l clexp unit_fragment), cleanup @@ -2121,13 +2135,13 @@ let codegen_id id = string (sgen_id id) let rec sgen_ctyp = function | CT_unit -> "unit" - | CT_bit -> "mach_bits" + | CT_bit -> "fbits" | CT_bool -> "bool" - | CT_fbits _ -> "mach_bits" + | CT_fbits _ -> "fbits" | CT_sbits _ -> "sbits" | CT_int64 -> "mach_int" | CT_int -> "sail_int" - | CT_lbits _ -> "sail_bits" + | CT_lbits _ -> "lbits" | CT_tup _ as tup -> "struct " ^ Util.zencode_string ("tuple_" ^ string_of_ctyp tup) | CT_struct (id, _) -> "struct " ^ sgen_id id | CT_enum (id, _) -> "enum " ^ sgen_id id @@ -2141,13 +2155,13 @@ let rec sgen_ctyp = function let rec sgen_ctyp_name = function | CT_unit -> "unit" - | CT_bit -> "mach_bits" + | CT_bit -> "fbits" | CT_bool -> "bool" - | CT_fbits _ -> "mach_bits" + | CT_fbits _ -> "fbits" | CT_sbits _ -> "sbits" | CT_int64 -> "mach_int" | CT_int -> "sail_int" - | CT_lbits _ -> "sail_bits" + | CT_lbits _ -> "lbits" | CT_tup _ as tup -> Util.zencode_string ("tuple_" ^ string_of_ctyp tup) | CT_struct (id, _) -> sgen_id id | CT_enum (id, _) -> sgen_id id @@ -2176,7 +2190,7 @@ let rec sgen_clexp = function | CL_id (id, _) -> "&" ^ sgen_id id | CL_field (clexp, field) -> "&((" ^ sgen_clexp clexp ^ ")->" ^ Util.zencode_string field ^ ")" | CL_tuple (clexp, n) -> "&((" ^ sgen_clexp clexp ^ ")->ztup" ^ string_of_int n ^ ")" - | CL_addr clexp -> "*(" ^ sgen_clexp clexp ^ ")" + | CL_addr clexp -> "(*(" ^ sgen_clexp clexp ^ "))" | CL_have_exception -> "have_exception" | CL_current_exception _ -> "current_exception" @@ -2184,7 +2198,7 @@ let rec sgen_clexp_pure = function | CL_id (id, _) -> sgen_id id | CL_field (clexp, field) -> sgen_clexp_pure clexp ^ "." ^ Util.zencode_string field | CL_tuple (clexp, n) -> sgen_clexp_pure clexp ^ ".ztup" ^ string_of_int n - | CL_addr clexp -> "*(" ^ sgen_clexp_pure clexp ^ ")" + | CL_addr clexp -> "(*(" ^ sgen_clexp_pure clexp ^ "))" | CL_have_exception -> "have_exception" | CL_current_exception _ -> "current_exception" @@ -2294,26 +2308,26 @@ let rec codegen_instr fid ctx (I_aux (instr, (_, l))) = end | "vector_update_subrange", _ -> Printf.sprintf "vector_update_subrange_%s" (sgen_ctyp_name ctyp) | "vector_subrange", _ -> Printf.sprintf "vector_subrange_%s" (sgen_ctyp_name ctyp) - | "vector_update", CT_fbits _ -> "update_mach_bits" - | "vector_update", CT_lbits _ -> "update_sail_bits" + | "vector_update", CT_fbits _ -> "update_fbits" + | "vector_update", CT_lbits _ -> "update_lbits" | "vector_update", _ -> Printf.sprintf "vector_update_%s" (sgen_ctyp_name ctyp) | "string_of_bits", _ -> begin match cval_ctyp (List.nth args 0) with - | CT_fbits _ -> "string_of_mach_bits" - | CT_lbits _ -> "string_of_sail_bits" + | CT_fbits _ -> "string_of_fbits" + | CT_lbits _ -> "string_of_lbits" | _ -> assert false end | "decimal_string_of_bits", _ -> begin match cval_ctyp (List.nth args 0) with - | CT_fbits _ -> "decimal_string_of_mach_bits" - | CT_lbits _ -> "decimal_string_of_sail_bits" + | CT_fbits _ -> "decimal_string_of_fbits" + | CT_lbits _ -> "decimal_string_of_lbits" | _ -> assert false end | "internal_vector_update", _ -> Printf.sprintf "internal_vector_update_%s" (sgen_ctyp_name ctyp) | "internal_vector_init", _ -> Printf.sprintf "internal_vector_init_%s" (sgen_ctyp_name ctyp) - | "undefined_vector", CT_fbits _ -> "UNDEFINED(mach_bits)" - | "undefined_vector", CT_lbits _ -> "UNDEFINED(sail_bits)" - | "undefined_bit", _ -> "UNDEFINED(mach_bits)" + | "undefined_vector", CT_fbits _ -> "UNDEFINED(fbits)" + | "undefined_vector", CT_lbits _ -> "UNDEFINED(lbits)" + | "undefined_bit", _ -> "UNDEFINED(fbits)" | "undefined_vector", _ -> Printf.sprintf "UNDEFINED(vector_%s)" (sgen_ctyp_name ctyp) | fname, _ -> fname in @@ -2338,7 +2352,7 @@ let rec codegen_instr fid ctx (I_aux (instr, (_, l))) = ksprintf string " %s %s = %s;" (sgen_ctyp ctyp) (sgen_id id) (sgen_cval cval) else ksprintf string " %s %s = CREATE_OF(%s, %s)(%s);" - (sgen_ctyp ctyp) (sgen_id id) (sgen_ctyp_name ctyp) (sgen_ctyp_name (cval_ctyp cval)) (sgen_cval cval) + (sgen_ctyp ctyp) (sgen_id id) (sgen_ctyp_name ctyp) (sgen_ctyp_name (cval_ctyp cval)) (sgen_cval_param cval) | I_init (ctyp, id, cval) -> ksprintf string " %s %s;" (sgen_ctyp ctyp) (sgen_id id) ^^ hardline ^^ ksprintf string " CREATE_OF(%s, %s)(&%s, %s);" @@ -2372,6 +2386,7 @@ let rec codegen_instr fid ctx (I_aux (instr, (_, l))) = | CT_bit -> "UINT64_C(0)", [] | CT_int64 -> "INT64_C(0xdeadc0de)", [] | CT_fbits _ -> "UINT64_C(0xdeadc0de)", [] + | CT_sbits _ -> "undefined_sbits()", [] | CT_bool -> "false", [] | CT_enum (_, ctor :: _) -> sgen_id ctor, [] | CT_tup ctyps when is_stack_ctyp ctyp -> @@ -3032,7 +3047,7 @@ let sgen_finish = function let instrument_tracing ctx = let module StringSet = Set.Make(String) in - let traceable = StringSet.of_list ["mach_bits"; "sail_string"; "sail_bits"; "sail_int"; "unit"; "bool"] in + let traceable = StringSet.of_list ["fbits"; "sail_string"; "lbits"; "sail_int"; "unit"; "bool"] in let rec instrument = function | (I_aux (I_funcall (clexp, _, id, args), _) as instr) :: instrs -> let trace_start = -- cgit v1.2.3 From 20ed809845c4b62235d3cbe203ecaefead943ac8 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Mon, 26 Nov 2018 17:32:29 +0000 Subject: Add random generators for record types --- src/ocaml_backend.ml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index 9a48421a..cf681ae5 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -830,6 +830,9 @@ let ocaml_pp_generators ctx defs orig_types required = separate space [bar; dquotes (string (string_of_id id)); string "->"; zencode_upper ctx id] in + let rand_field (typ,id) = + zencode ctx id ^^ space ^^ equals ^^ space ^^ make_subgen typ + in let make_args tqs = string "g" ^^ match quant_kopts tqs with @@ -859,8 +862,10 @@ let ocaml_pp_generators ctx defs orig_types required = string "]", Some (separate_map (string ";" ^^ break 1) enum_constructor variants), Some (separate_map (break 1) build_enum_constructor variants) + | TD_record (_,_,tqs,fields,_) -> + tqs, braces (separate_map (string ";" ^^ break 1) rand_field fields), None, None | _ -> - raise (Reporting.err_todo l "Generators for records and bitfields not yet supported") + raise (Reporting.err_todo l "Generators for bitfields not yet supported") in let name = type_name id in let constructors_pp = match constructors with -- cgit v1.2.3 From d48ccd801b4d99c160f289b2efdde10aa36e7bdd Mon Sep 17 00:00:00 2001 From: Prashanth Mundkur Date: Mon, 26 Nov 2018 15:50:37 -0800 Subject: Use a temporary definition of List.init until 4.06 is more standard. --- src/pretty_print_coq.ml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 841f21e6..cfffb8c9 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -1645,6 +1645,9 @@ let doc_exp, doc_let = (* expose doc_exp and doc_let *) in top_exp, let_exp +(* FIXME: A temporary definition of List.init until 4.06 is more standard *) +let list_init n f = Array.to_list (Array.init n f) + let types_used_with_generic_eq defs = let rec add_typ idset (Typ_aux (typ,_)) = match typ with @@ -1748,7 +1751,7 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = match td with let numfields = List.length fs in let intros_pp s = string " intros [" ^^ - separate space (List.init numfields (fun n -> string (s ^ string_of_int n))) ^^ + separate space (list_init numfields (fun n -> string (s ^ string_of_int n))) ^^ string "]." ^^ hardline in let eq_pp = @@ -1756,7 +1759,7 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = match td with string "Instance Decidable_eq_" ^^ id_pp ^^ space ^^ colon ^/^ string "forall (x y : " ^^ id_pp ^^ string "), Decidable (x = y)." ^^ hardline ^^ intros_pp "x" ^^ intros_pp "y" ^^ - separate hardline (List.init numfields + separate hardline (list_init numfields (fun n -> let ns = string_of_int n in string ("cmp_record_field x" ^ ns ^ " y" ^ ns ^ "."))) ^^ -- cgit v1.2.3 From 6b67c91583da5eedc02a3942ef864d1fd64a48aa Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Tue, 27 Nov 2018 18:01:23 +0000 Subject: Add an optimisation pass to combine variables if possible This optimisation re-uses variables if possible, rather than allocating new ones. --- src/bytecode_util.ml | 7 ++- src/c_backend.ml | 150 +++++++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 152 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/bytecode_util.ml b/src/bytecode_util.ml index 783f6793..aeb1daf1 100644 --- a/src/bytecode_util.ml +++ b/src/bytecode_util.ml @@ -155,8 +155,11 @@ let rec instr_rename from_id to_id (I_aux (instr, aux)) = | I_init (ctyp, id, cval) -> I_init (ctyp, id, cval_rename from_id to_id cval) - | I_if ((frag, ctyp1), then_instrs, else_instrs, ctyp2) -> - I_if ((frag_rename from_id to_id frag, ctyp1), then_instrs, else_instrs, ctyp2) + | I_if (cval, then_instrs, else_instrs, ctyp2) -> + I_if (cval_rename from_id to_id cval, + List.map (instr_rename from_id to_id) then_instrs, + List.map (instr_rename from_id to_id) else_instrs, + ctyp2) | I_jump (cval, label) -> I_jump (cval_rename from_id to_id cval, label) diff --git a/src/c_backend.ml b/src/c_backend.ml index 3d281337..31a989f8 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -2118,12 +2118,156 @@ let remove_alias ctx = [CDEF_fundef (function_id, heap_return, args, opt body)] | cdef -> [cdef] + +(** This pass ensures that all variables created by I_decl have unique names *) +let unique_names = + let unique_counter = ref 0 in + let unique_id () = + let id = mk_id ("u#" ^ string_of_int !unique_counter) in + incr unique_counter; + id + in + + let rec opt seen = function + | I_aux (I_decl (ctyp, id), aux) :: instrs when IdSet.mem id seen -> + let id' = unique_id () in + let instrs', seen = opt seen instrs in + I_aux (I_decl (ctyp, id'), aux) :: instrs_rename id id' instrs', seen + + | I_aux (I_decl (ctyp, id), aux) :: instrs -> + let instrs', seen = opt (IdSet.add id seen) instrs in + I_aux (I_decl (ctyp, id), aux) :: instrs', seen + + | I_aux (I_block block, aux) :: instrs -> + let block', seen = opt seen block in + let instrs', seen = opt seen instrs in + I_aux (I_block block', aux) :: instrs', seen + + | I_aux (I_try_block block, aux) :: instrs -> + let block', seen = opt seen block in + let instrs', seen = opt seen instrs in + I_aux (I_try_block block', aux) :: instrs', seen + + | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> + let then_instrs', seen = opt seen then_instrs in + let else_instrs', seen = opt seen else_instrs in + let instrs', seen = opt seen instrs in + I_aux (I_if (cval, then_instrs', else_instrs', ctyp), aux) :: instrs', seen + + | instr :: instrs -> + let instrs', seen = opt seen instrs in + instr :: instrs', seen + + | [] -> [], seen + in + function + | CDEF_fundef (function_id, heap_return, args, body) -> + [CDEF_fundef (function_id, heap_return, args, fst (opt IdSet.empty body))] + | CDEF_reg_dec (id, ctyp, instrs) -> + [CDEF_reg_dec (id, ctyp, fst (opt IdSet.empty instrs))] + | CDEF_let (n, bindings, instrs) -> + [CDEF_let (n, bindings, fst (opt IdSet.empty instrs))] + | cdef -> [cdef] + +(** This optimization looks for patterns of the form + + create x : t; + create y : t; + // modifications to y, no changes to x + x = y; + kill y; + + If found we can replace y by x *) +let combine_variables ctx = + let pattern ctyp id = + let combine = ref None in + let rec scan id n instrs = + match n, !combine, instrs with + | 0, None, I_aux (I_block block, _) :: instrs -> + begin match scan id 0 block with + | Some combine -> Some combine + | None -> scan id 0 instrs + end + + | 0, None, I_aux (I_decl (ctyp', id'), _) :: instrs when ctyp_equal ctyp ctyp' -> + combine := Some id'; + scan id 1 instrs + + | 1, Some c, I_aux (I_copy (CL_id (id', ctyp'), (F_id c', ctyp'')), _) :: instrs + when Id.compare c c' = 0 && Id.compare id id' = 0 && ctyp_equal ctyp ctyp' && ctyp_equal ctyp' ctyp'' -> + scan id 2 instrs + + (* Ignore seemingly early clears of x, as this can happen along exception paths *) + | 1, Some c, I_aux (I_clear (_, id'), _) :: instrs + when Id.compare id id' = 0 -> + scan id 1 instrs + + | 1, Some c, instr :: instrs -> + if IdSet.mem id (instr_ids instr) then + None + else + scan id 1 instrs + + | 2, Some c, I_aux (I_clear (ctyp', c'), _) :: instrs + when Id.compare c c' = 0 && ctyp_equal ctyp ctyp' -> + !combine + + | 2, Some c, instr :: instrs -> + if IdSet.mem c (instr_ids instr) then + None + else + scan id 2 instrs + + | 2, Some c, [] -> !combine + + | n, _, _ :: instrs -> scan id n instrs + | _, _, [] -> None + in + scan id 0 + in + let remove_variable id = function + | I_aux (I_decl (_, id'), _) when Id.compare id id' = 0 -> removed + | I_aux (I_clear (_, id'), _) when Id.compare id id' = 0 -> removed + | instr -> instr + in + let is_not_self_assignment = function + | I_aux (I_copy (CL_id (id, _), (F_id id', _)), _) when Id.compare id id' = 0 -> false + | _ -> true + in + let rec opt = function + | (I_aux (I_decl (ctyp, id), _) as instr) :: instrs -> + begin match pattern ctyp id instrs with + | None -> instr :: opt instrs + | Some combine -> + let instrs = List.map (map_instr (remove_variable combine)) instrs in + let instrs = filter_instrs (fun i -> is_not_removed i && is_not_self_assignment i) + (List.map (instr_rename combine id) instrs) in + opt (instr :: instrs) + end + + | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (opt block), aux) :: opt instrs + | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (opt block), aux) :: opt instrs + | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> + I_aux (I_if (cval, opt then_instrs, opt else_instrs, ctyp), aux) :: opt instrs + + | instr :: instrs -> + instr :: opt instrs + | [] -> [] + in + function + | CDEF_fundef (function_id, heap_return, args, body) -> + [CDEF_fundef (function_id, heap_return, args, opt body)] + | cdef -> [cdef] + + let concatMap f xs = List.concat (List.map f xs) let optimize ctx cdefs = let nothing cdefs = cdefs in cdefs + |> (if !optimize_alias then concatMap unique_names else nothing) |> (if !optimize_alias then concatMap (remove_alias ctx) else nothing) + |> (if !optimize_alias then concatMap (combine_variables ctx) else nothing) |> (if !optimize_hoist_allocations then concatMap (hoist_allocations ctx) else nothing) (**************************************************************************) @@ -2259,12 +2403,12 @@ let rec codegen_instr fid ctx (I_aux (instr, (_, l))) = ^^ twice space ^^ codegen_instr fid ctx then_instr | I_if (cval, then_instrs, [], ctyp) -> string " if" ^^ space ^^ parens (string (sgen_cval cval)) ^^ space - ^^ surround 2 0 lbrace (separate_map hardline (codegen_instr fid ctx) then_instrs) (twice space ^^ rbrace) + ^^ surround 0 0 lbrace (separate_map hardline (codegen_instr fid ctx) then_instrs) (twice space ^^ rbrace) | I_if (cval, then_instrs, else_instrs, ctyp) -> string " if" ^^ space ^^ parens (string (sgen_cval cval)) ^^ space - ^^ surround 2 0 lbrace (separate_map hardline (codegen_instr fid ctx) then_instrs) (twice space ^^ rbrace) + ^^ surround 0 0 lbrace (separate_map hardline (codegen_instr fid ctx) then_instrs) (twice space ^^ rbrace) ^^ space ^^ string "else" ^^ space - ^^ surround 2 0 lbrace (separate_map hardline (codegen_instr fid ctx) else_instrs) (twice space ^^ rbrace) + ^^ surround 0 0 lbrace (separate_map hardline (codegen_instr fid ctx) else_instrs) (twice space ^^ rbrace) | I_block instrs -> string " {" -- cgit v1.2.3 From 134ceff00b6a4837b133cb49b6d775161420dc62 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Tue, 27 Nov 2018 21:23:48 +0000 Subject: Fix memory leak in string_of_bits Should hopefully fix memory leak in RISC-V. Also adds an optimization pass that removes copying structs and allows some structs to simply alias each other and avoid copying their contents. This requires knowing certain things about the lifetimes of the structs involved, as can't free the struct if another variable is referencing it - therefore we conservatively only apply this optimization for variables that are lifted outside function definitions, and should therefore never get freed until the model exits - however this may cause issues outside ARMv8, as there may be cases where a struct can exist within a variant type (which are not yet subject to this lifting optimisation), that would break these assumptions - therefore this optimisation is only enabled with the -Oexperimental flag. --- src/bytecode_util.ml | 34 +++++++++++++++++++++++++-- src/c_backend.ml | 66 ++++++++++++++++++++++++++++++++++++++++++++++++++-- src/c_backend.mli | 1 + src/sail.ml | 3 +++ 4 files changed, 100 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/bytecode_util.ml b/src/bytecode_util.ml index aeb1daf1..c7fdc62d 100644 --- a/src/bytecode_util.ml +++ b/src/bytecode_util.ml @@ -82,6 +82,9 @@ let iextern ?loc:(l=Parse_ast.Unknown) clexp id cvals = let icopy l clexp cval = I_aux (I_copy (clexp, cval), (instr_number (), l)) +let ialias l clexp cval = + I_aux (I_alias (clexp, cval), (instr_number (), l)) + let iclear ?loc:(l=Parse_ast.Unknown) ctyp id = I_aux (I_clear (ctyp, id), (instr_number (), l)) @@ -167,6 +170,7 @@ let rec instr_rename from_id to_id (I_aux (instr, aux)) = I_funcall (clexp_rename from_id to_id clexp, extern, id, List.map (cval_rename from_id to_id) args) | I_copy (clexp, cval) -> I_copy (clexp_rename from_id to_id clexp, cval_rename from_id to_id cval) + | I_alias (clexp, cval) -> I_alias (clexp_rename from_id to_id clexp, cval_rename from_id to_id cval) | I_clear (ctyp, id) when Id.compare id from_id = 0 -> I_clear (ctyp, to_id) | I_clear (ctyp, id) -> I_clear (ctyp, id) @@ -447,6 +451,8 @@ let rec pp_instr ?short:(short=false) (I_aux (instr, aux)) = string (string_of_id f |> Util.green |> Util.clear) ^^ parens (separate_map (string ", ") pp_cval args) ] | I_copy (clexp, cval) -> separate space [pp_clexp clexp; string "="; pp_cval cval] + | I_alias (clexp, cval) -> + pp_keyword "alias" ^^ separate space [pp_clexp clexp; string "="; pp_cval cval] | I_clear (ctyp, id) -> pp_keyword "kill" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp | I_return cval -> @@ -574,6 +580,7 @@ let instr_deps = function | I_jump (cval, label) -> cval_deps cval, NS.singleton (G_label label) | I_funcall (clexp, _, _, cvals) -> List.fold_left NS.union NS.empty (List.map cval_deps cvals), clexp_deps clexp | I_copy (clexp, cval) -> cval_deps cval, clexp_deps clexp + | I_alias (clexp, cval) -> cval_deps cval, clexp_deps clexp | I_clear (_, id) -> NS.singleton (G_id id), NS.singleton (G_id id) | I_throw cval | I_return cval -> cval_deps cval, NS.empty | I_block _ | I_try_block _ -> NS.empty, NS.empty @@ -698,6 +705,7 @@ let rec map_instr_ctyp f (I_aux (instr, aux)) = | I_funcall (clexp, extern, id, cvals) -> I_funcall (map_clexp_ctyp f clexp, extern, id, List.map (fun (frag, ctyp) -> frag, f ctyp) cvals) | I_copy (clexp, (frag, ctyp)) -> I_copy (map_clexp_ctyp f clexp, (frag, f ctyp)) + | I_alias (clexp, (frag, ctyp)) -> I_alias (map_clexp_ctyp f clexp, (frag, f ctyp)) | I_clear (ctyp, id) -> I_clear (f ctyp, id) | I_return (frag, ctyp) -> I_return (frag, f ctyp) | I_block instrs -> I_block (List.map (map_instr_ctyp f) instrs) @@ -714,7 +722,7 @@ let rec map_instr_ctyp f (I_aux (instr, aux)) = let rec map_instr f (I_aux (instr, aux)) = let instr = match instr with | I_decl _ | I_init _ | I_reset _ | I_reinit _ - | I_funcall _ | I_copy _ | I_clear _ | I_jump _ | I_throw _ | I_return _ + | I_funcall _ | I_copy _ | I_alias _ | I_clear _ | I_jump _ | I_throw _ | I_return _ | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure | I_undefined _ -> instr | I_if (cval, instrs1, instrs2, ctyp) -> I_if (cval, List.map (map_instr f) instrs1, List.map (map_instr f) instrs2, ctyp) @@ -756,7 +764,7 @@ let rec map_instrs f (I_aux (instr, aux)) = | I_decl _ | I_init _ | I_reset _ | I_reinit _ -> instr | I_if (cval, instrs1, instrs2, ctyp) -> I_if (cval, f (List.map (map_instrs f) instrs1), f (List.map (map_instrs f) instrs2), ctyp) - | I_funcall _ | I_copy _ | I_clear _ | I_jump _ | I_throw _ | I_return _ -> instr + | I_funcall _ | I_copy _ | I_alias _ | I_clear _ | I_jump _ | I_throw _ | I_return _ -> instr | I_block instrs -> I_block (f (List.map (map_instrs f) instrs)) | I_try_block instrs -> I_try_block (f (List.map (map_instrs f) instrs)) | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure | I_undefined _ -> instr @@ -774,6 +782,28 @@ let rec instr_ids (I_aux (instr, _)) = |> Util.option_these |> IdSet.of_list +let rec instr_reads (I_aux (instr, _)) = + let reads, _ = instr_deps instr in + let get_id = function + | G_id id -> Some id + | _ -> None + in + NS.elements reads + |> List.map get_id + |> Util.option_these + |> IdSet.of_list + +let rec instr_writes (I_aux (instr, _)) = + let _, writes = instr_deps instr in + let get_id = function + | G_id id -> Some id + | _ -> None + in + NS.elements writes + |> List.map get_id + |> Util.option_these + |> IdSet.of_list + let rec filter_instrs f instrs = let filter_instrs' = function | I_aux (I_block instrs, aux) -> I_aux (I_block (filter_instrs f instrs), aux) diff --git a/src/c_backend.ml b/src/c_backend.ml index 31a989f8..5003e432 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -72,6 +72,7 @@ let optimize_primops = ref false let optimize_hoist_allocations = ref false let optimize_struct_updates = ref false let optimize_alias = ref false +let optimize_experimental = ref false let c_debug str = if !c_verbosity > 0 then prerr_endline (Lazy.force str) else () @@ -621,7 +622,7 @@ let rec instr_ctyps (I_aux (instr, aux)) = ctyp :: cval_ctyp cval :: List.concat (List.map instr_ctyps instrs1 @ List.map instr_ctyps instrs2) | I_funcall (clexp, _, _, cvals) -> clexp_ctyp clexp :: List.map cval_ctyp cvals - | I_copy (clexp, cval) -> [clexp_ctyp clexp; cval_ctyp cval] + | I_copy (clexp, cval) | I_alias (clexp, cval) -> [clexp_ctyp clexp; cval_ctyp cval] | I_block instrs | I_try_block instrs -> List.concat (List.map instr_ctyps instrs) | I_throw cval | I_jump (cval, _) | I_return cval -> [cval_ctyp cval] | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure -> [] @@ -1546,7 +1547,7 @@ let rec map_try_block f (I_aux (instr, aux)) = | I_decl _ | I_reset _ | I_init _ | I_reinit _ -> instr | I_if (cval, instrs1, instrs2, ctyp) -> I_if (cval, List.map (map_try_block f) instrs1, List.map (map_try_block f) instrs2, ctyp) - | I_funcall _ | I_copy _ | I_clear _ | I_throw _ | I_return _ -> instr + | I_funcall _ | I_copy _ | I_alias _ | I_clear _ | I_throw _ | I_return _ -> instr | I_block instrs -> I_block (List.map (map_try_block f) instrs) | I_try_block instrs -> I_try_block (f (List.map (map_try_block f) instrs)) | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_jump _ | I_match_failure | I_undefined _ -> instr @@ -1800,6 +1801,7 @@ let rec instrs_rename from_id to_id = | I_aux (I_funcall (clexp, extern, id, cvals), aux) :: instrs -> I_aux (I_funcall (lrename clexp, extern, rename id, List.map crename cvals), aux) :: irename instrs | I_aux (I_copy (clexp, cval), aux) :: instrs -> I_aux (I_copy (lrename clexp, crename cval), aux) :: irename instrs + | I_aux (I_alias (clexp, cval), aux) :: instrs -> I_aux (I_alias (lrename clexp, crename cval), aux) :: irename instrs | I_aux (I_clear (ctyp, id), aux) :: instrs -> I_aux (I_clear (ctyp, rename id), aux) :: irename instrs | I_aux (I_return cval, aux) :: instrs -> I_aux (I_return (crename cval), aux) :: irename instrs | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (irename block), aux) :: irename instrs @@ -2259,6 +2261,62 @@ let combine_variables ctx = [CDEF_fundef (function_id, heap_return, args, opt body)] | cdef -> [cdef] +(** hoist_alias looks for patterns like + + recreate x; y = x; // no furthner mentions of x + + Provided x has a certain type, then we can make y an alias to x + (denoted in the IR as 'alias y = x'). This only works if y also has + a lifespan that also spans the entire function body. It's possible + we may need to do a more thorough lifetime evaluation to get this + to be 100% correct - so it's behind the -Oexperimental flag + for now. Some benchmarking shows that this kind of optimization + is very valuable however! *) +let hoist_alias ctx = + (* Must return true for a subset of the types hoist_ctyp would return true for. *) + let is_struct = function + | CT_struct _ -> true + | _ -> false + in + let pattern heap_return id ctyp instrs = + let rec scan instrs = + match instrs with + (* The only thing that has a longer lifetime than id is the + function return, so we want to make sure we avoid that + case. *) + | (I_aux (I_copy (clexp, (F_id id', ctyp')), aux) as instr) :: instrs + when not (IdSet.mem heap_return (instr_writes instr)) && Id.compare id id' = 0 + && ctyp_equal (clexp_ctyp clexp) ctyp && ctyp_equal ctyp ctyp' -> + if List.exists (IdSet.mem id) (List.map instr_ids instrs) then + instr :: scan instrs + else + I_aux (I_alias (clexp, (F_id id', ctyp')), aux) :: instrs + + | instr :: instrs -> instr :: scan instrs + | [] -> [] + in + scan instrs + in + let optimize heap_return = + let rec opt = function + | (I_aux (I_reset (ctyp, id), _) as instr) :: instrs when not (is_stack_ctyp ctyp) && is_struct ctyp -> + instr :: opt (pattern heap_return id ctyp instrs) + + | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (opt block), aux) :: opt instrs + | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (opt block), aux) :: opt instrs + | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> + I_aux (I_if (cval, opt then_instrs, opt else_instrs, ctyp), aux) :: opt instrs + + | instr :: instrs -> + instr :: opt instrs + | [] -> [] + in + opt + in + function + | CDEF_fundef (function_id, Some heap_return, args, body) -> + [CDEF_fundef (function_id, Some heap_return, args, optimize heap_return body)] + | cdef -> [cdef] let concatMap f xs = List.concat (List.map f xs) @@ -2269,6 +2327,7 @@ let optimize ctx cdefs = |> (if !optimize_alias then concatMap (remove_alias ctx) else nothing) |> (if !optimize_alias then concatMap (combine_variables ctx) else nothing) |> (if !optimize_hoist_allocations then concatMap (hoist_allocations ctx) else nothing) + |> (if !optimize_hoist_allocations && !optimize_experimental then concatMap (hoist_alias ctx) else nothing) (**************************************************************************) (* 6. Code generation *) @@ -2395,6 +2454,9 @@ let rec codegen_instr fid ctx (I_aux (instr, (_, l))) = | I_copy (clexp, cval) -> codegen_conversion l clexp cval + | I_alias (clexp, cval) -> + ksprintf string " %s = %s;" (sgen_clexp_pure clexp) (sgen_cval cval) + | I_jump (cval, label) -> ksprintf string " if (%s) goto %s;" (sgen_cval cval) label diff --git a/src/c_backend.mli b/src/c_backend.mli index b39f58e2..24f6e03b 100644 --- a/src/c_backend.mli +++ b/src/c_backend.mli @@ -65,6 +65,7 @@ val optimize_primops : bool ref val optimize_hoist_allocations : bool ref val optimize_struct_updates : bool ref val optimize_alias : bool ref +val optimize_experimental : bool ref (** The compilation context. *) type ctx diff --git a/src/sail.ml b/src/sail.ml index 44766926..417d3ef4 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -134,6 +134,9 @@ let options = Arg.align ([ ( "-Oconstant_fold", Arg.Set Constant_fold.optimize_constant_fold, " Apply constant folding optimizations"); + ( "-Oexperimental", + Arg.Set C_backend.optimize_experimental, + " turn on additional, experimental optimisations"); ( "-static", Arg.Set C_backend.opt_static, " Make generated C functions static"); -- cgit v1.2.3 From 3a0bcd6e7f1dd565fb41574285c9c09bbbe14697 Mon Sep 17 00:00:00 2001 From: Alasdair Date: Wed, 28 Nov 2018 00:29:10 +0000 Subject: Allow folding constant expressions into single register reads Essentially all we have to do to make this work is introduce a member of the Value type, V_attempted_read , which is returned whenever we try to read a register value with allow_registers disabled. This defers the failure from reading the register to the point where the register value is used (simply because nothing knows how to deal with V_attempted_read). However, if V_attempted_read is returned directly as the result of evaluating an expression, then we can replace the expression with a single direct register read. This optimises some indirection in the ARM specification. --- src/constant_fold.ml | 1 + src/interpreter.ml | 4 +++- src/value.ml | 7 +++++++ 3 files changed, 11 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/constant_fold.ml b/src/constant_fold.ml index f22b48de..0e34ed5b 100644 --- a/src/constant_fold.ml +++ b/src/constant_fold.ml @@ -78,6 +78,7 @@ and exp_of_value = | V_tuple vs -> mk_exp (E_tuple (List.map exp_of_value vs)) | V_unit -> mk_lit_exp L_unit + | V_attempted_read str -> mk_exp (E_id (mk_id str)) | _ -> failwith "No expression for value" (* We want to avoid evaluating things like print statements at compile diff --git a/src/interpreter.ml b/src/interpreter.ml index 07a4b4ae..03877600 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -390,13 +390,15 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = Type_check.check_exp (env_of_annot annot) exp (typ_of orig_exp) in return exp + | Register _ when not gstate.allow_registers -> + return (exp_of_value (V_attempted_read (string_of_id id))) | Local (Mutable, _) -> return (local_variable id lstate gstate) | Local (Immutable, _) -> let chain = build_letchain id gstate.letbinds orig_exp in return chain | Enum _ -> return (exp_of_value (V_ctor (string_of_id id, []))) - | _ -> failwith ("Coudln't find id " ^ string_of_id id) + | _ -> failwith ("Couldn't find id " ^ string_of_id id) end | E_record (FES_aux (FES_Fexps (fexps, flag), fes_annot)) -> diff --git a/src/value.ml b/src/value.ml index 157c16fc..589e956a 100644 --- a/src/value.ml +++ b/src/value.ml @@ -86,6 +86,12 @@ type value = | V_ref of string | V_ctor of string * value list | V_record of value StringMap.t + (* When constant folding we disable reading registers, so a register + read will return a V_attempted_read value. If we try to do + anything with this value, we'll get an exception - but if all we + do is return it then we can replace the expression we are folding + with a direct register read. *) + | V_attempted_read of string let rec eq_value v1 v2 = match v1, v2 with @@ -386,6 +392,7 @@ let rec string_of_value = function | V_ctor (str, vals) -> str ^ "(" ^ Util.string_of_list ", " string_of_value vals ^ ")" | V_record record -> "{" ^ Util.string_of_list ", " (fun (field, v) -> field ^ "=" ^ string_of_value v) (StringMap.bindings record) ^ "}" + | V_attempted_read _ -> assert false let value_sign_extend = function | [v1; v2] -> mk_vector (Sail_lib.sign_extend (coerce_bv v1, coerce_int v2)) -- cgit v1.2.3 From 4fd0c147e6c53ec64b7e4a8cd0324f6e8e56714f Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Fri, 30 Nov 2018 16:30:47 +0000 Subject: Improvements for ASL parser - Fix pretty printing nested constraints - Add flow typing for if condition then { throw exn }; ... blocks - Add optimisations for bitvector concatenation in C --- src/c_backend.ml | 22 +++++++++++++++++++++- src/initial_check.ml | 26 ++++++-------------------- src/lexer.mll | 1 + src/parse_ast.ml | 2 +- src/parser.mly | 6 +++++- src/pretty_print_sail.ml | 38 ++++++++++++++++---------------------- src/type_check.ml | 12 +++++------- src/type_error.ml | 18 ++++++++++++++++++ 8 files changed, 73 insertions(+), 52 deletions(-) (limited to 'src') diff --git a/src/c_backend.ml b/src/c_backend.ml index 5003e432..326f742a 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -494,6 +494,24 @@ let analyze_primop' ctx id args typ = | "undefined_bit", _ -> AE_val (AV_C_fragment (F_lit (V_bit Sail2_values.B0), typ, CT_bit)) + (* Optimized routines for all combinations of fixed and small bits + appends, where the result is guaranteed to be smaller than 64. *) + | "append", [AV_C_fragment (vec1, _, CT_fbits (n1, ord1)); AV_C_fragment (vec2, _, CT_fbits (n2, ord2))] + when ord1 = ord2 && n1 + n2 <= 64 -> + AE_val (AV_C_fragment (F_op (F_op (vec1, "<<", v_int n2), "|", vec2), typ, CT_fbits (n1 + n2, ord1))) + + | "append", [AV_C_fragment (vec1, _, CT_sbits ord1); AV_C_fragment (vec2, _, CT_fbits (n2, ord2))] + when ord1 = ord2 && is_sbits_typ ctx typ -> + AE_val (AV_C_fragment (F_call ("append_sf", [vec1; vec2; v_int n2]), typ, ctyp_of_typ ctx typ)) + + | "append", [AV_C_fragment (vec1, _, CT_fbits (n1, ord1)); AV_C_fragment (vec2, _, CT_sbits ord2)] + when ord1 = ord2 && is_sbits_typ ctx typ -> + AE_val (AV_C_fragment (F_call ("append_fs", [vec1; v_int n1; vec2]), typ, ctyp_of_typ ctx typ)) + + | "append", [AV_C_fragment (vec1, _, CT_sbits ord1); AV_C_fragment (vec2, _, CT_sbits ord2)] + when ord1 = ord2 && is_sbits_typ ctx typ -> + AE_val (AV_C_fragment (F_call ("append_ss", [vec1; vec2]), typ, ctyp_of_typ ctx typ)) + | "undefined_vector", [AV_C_fragment (len, _, _); _] -> begin match destruct_vector ctx.tc_env typ with | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) @@ -2537,7 +2555,9 @@ let rec codegen_instr fid ctx (I_aux (instr, (_, l))) = | "undefined_vector", _ -> Printf.sprintf "UNDEFINED(vector_%s)" (sgen_ctyp_name ctyp) | fname, _ -> fname in - if fname = "reg_deref" then + if fname = "sail_assert" && !optimize_experimental then + empty + else if fname = "reg_deref" then if is_stack_ctyp ctyp then string (Printf.sprintf " %s = *(%s);" (sgen_clexp_pure x) c_args) else diff --git a/src/initial_check.ml b/src/initial_check.ml index 4dd72980..bd32a8e3 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -731,26 +731,12 @@ let to_ast_typedef (names,k_env,def_ord) (td:Parse_ast.type_def) : (unit type_de let ranges = List.map (fun (id, range) -> (to_ast_id id, to_ast_range range)) ranges in TD_aux(TD_bitfield(id,typ,ranges),(l,())), (names,Envmap.insert k_env (key, {k=K_Typ}),def_ord)) -let to_ast_kdef (names,k_env,def_ord) (td:Parse_ast.kind_def) : (unit kind_def) envs_out = +let to_ast_kdef (names, k_env, def_ord) (td:Parse_ast.kind_def) : unit kind_def = match td with - | Parse_ast.KD_aux(td,l) -> - (match td with - | Parse_ast.KD_abbrev(kind,id,name_scm_opt,typschm) -> - let id = to_ast_id id in - let key = id_to_string id in - let (kind,k) = to_ast_kind k_env kind in - (match k.k with - | K_Nat -> - let kd_nabrv = - (match typschm with - | Parse_ast.TypSchm_aux(Parse_ast.TypSchm_ts(Parse_ast.TypQ_aux(tq,_),atyp),_) -> - (match tq with - | Parse_ast.TypQ_no_forall -> - KD_aux(KD_nabbrev(kind,id,to_ast_namescm name_scm_opt, to_ast_nexp k_env atyp), (l,())) - | _ -> typ_error l "Def with kind Nat cannot have universal quantification" None None None)) in - kd_nabrv,(names,Envmap.insert k_env (key, k),def_ord) - | _ -> assert false - )) + | Parse_ast.KD_aux (Parse_ast.KD_nabbrev (kind, id, name_scm_opt, atyp), l) -> + let id = to_ast_id id in + let (kind, k) = to_ast_kind k_env kind in + KD_aux (KD_nabbrev (kind, id, to_ast_namescm name_scm_opt, to_ast_nexp k_env atyp), (l, ())) let to_ast_rec (Parse_ast.Rec_aux(r,l): Parse_ast.rec_opt) : rec_opt = Rec_aux((match r with @@ -892,7 +878,7 @@ let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out | Parse_ast.DEF_fixity (prec, n, op) -> ((Finished(DEF_fixity (to_ast_prec prec, n, to_ast_id op)),envs),partial_defs) | Parse_ast.DEF_kind(k_def) -> - let kd,envs = to_ast_kdef envs k_def in + let kd = to_ast_kdef envs k_def in ((Finished(DEF_kind(kd))),envs),partial_defs | Parse_ast.DEF_type(t_def) -> let td,envs = to_ast_typedef envs t_def in diff --git a/src/lexer.mll b/src/lexer.mll index de8eed7f..f5a982eb 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -145,6 +145,7 @@ let kw_table = ("return", (fun x -> Return)); ("scattered", (fun x -> Scattered)); ("sizeof", (fun x -> Sizeof)); + ("constant", (fun x -> Constant)); ("constraint", (fun x -> Constraint)); ("struct", (fun x -> Struct)); ("then", (fun x -> Then)); diff --git a/src/parse_ast.ml b/src/parse_ast.ml index 30f87bc3..ddff51ea 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -494,7 +494,7 @@ val_spec_aux = (* Value type specification *) type kind_def_aux = (* Definition body for elements of kind; many are shorthands for type\_defs *) - KD_abbrev of kind * id * name_scm_opt * typschm (* type abbreviation *) + KD_nabbrev of kind * id * name_scm_opt * atyp (* type abbreviation *) type dec_spec_aux = (* Register declarations *) diff --git a/src/parser.mly b/src/parser.mly index 12286e13..fec38669 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -178,7 +178,7 @@ let rec desugar_rchain chain s e = %token And As Assert Bitzero Bitone By Match Clause Dec Default Effect End Op Where %token Enum Else False Forall Foreach Overload Function_ Mapping If_ In Inc Let_ Int Order Cast %token Pure Register Return Scattered Sizeof Struct Then True TwoCaret TYPE Typedef -%token Undefined Union Newtype With Val Constraint Throw Try Catch Exit Bitfield +%token Undefined Union Newtype With Val Constant Constraint Throw Try Catch Exit Bitfield %token Barr Depend Rreg Wreg Rmem Rmemt Wmem Wmv Wmvt Eamem Exmem Undef Unspec Nondet Escape %token Repeat Until While Do Mutual Var Ref Configuration @@ -1446,6 +1446,10 @@ def: { DEF_scattered (mk_sd (SD_scattered_end $2) $startpos $endpos) } | default_def { DEF_default $1 } + | Constant id Eq typ + { DEF_kind (KD_aux (KD_nabbrev (K_aux (K_kind [BK_aux (BK_int, loc $startpos($1) $endpos($1))], + loc $startpos($1) $endpos($1)), $2, mk_namesectn, $4), + loc $startpos $endpos)) } | Constraint id Lparen kid_list Rparen Eq nc { DEF_constraint ($2, $4, $7) } | Mutual Lcurly fun_def_list Rcurly diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index 792c3d23..a2771ae1 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -151,7 +151,7 @@ let doc_nc nc = | NC_and (c1, c2) -> separate space [nc1 c1; string "&"; atomic_nc c2] | _ -> atomic_nc nc in - nc0 (constraint_simp nc) + nc0 ~parenthesize:true (constraint_simp nc) let rec doc_typ ?(simple=false) (Typ_aux (typ_aux, l)) = match typ_aux with @@ -159,16 +159,15 @@ let rec doc_typ ?(simple=false) (Typ_aux (typ_aux, l)) = | Typ_app (id, []) -> doc_id id | Typ_app (Id_aux (DeIid str, _), [x; y]) -> separate space [doc_typ_arg x; doc_typ_arg y] - (* - | Typ_app (id, [_; len; _; Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id tid, _)), _)]) when Id.compare (mk_id "vector") id == 0 && Id.compare (mk_id "bit") tid == 0-> - string "bits" ^^ parens (doc_typ_arg len) - *) - | Typ_app (id, typs) when Id.compare id (mk_id "atom") = 0 -> string "int" ^^ parens (separate_map (string ", ") doc_typ_arg typs) + | Typ_app (id, typs) when Id.compare id (mk_id "atom") = 0 -> + string "int" ^^ parens (separate_map (string ", ") doc_typ_arg typs) | Typ_app (id, typs) -> doc_id id ^^ parens (separate_map (string ", ") doc_typ_arg typs) | Typ_tup typs -> parens (separate_map (string ", ") doc_typ typs) | Typ_var kid -> doc_kid kid (* Resugar set types like {|1, 2, 3|} *) - | Typ_exist ([kid1], NC_aux (NC_set (kid2, ints), _), Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid3, _)), _)]), _)) + | Typ_exist ([kid1], + NC_aux (NC_set (kid2, ints), _), + Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid3, _)), _)]), _)) when Kid.compare kid1 kid2 == 0 && Kid.compare kid2 kid3 == 0 && Id.compare (mk_id "atom") id == 0 -> enclose (string "{|") (string "|}") (separate_map (string ", ") doc_int ints) | Typ_exist (kids, nc, typ) -> @@ -371,21 +370,16 @@ let rec doc_exp (E_aux (e_aux, _) as exp) = | E_assign (lexp, exp) -> separate space [doc_lexp lexp; equals; doc_exp exp] | E_for (id, exp1, exp2, exp3, order, exp4) -> - begin - let header = - string "foreach" ^^ space ^^ - group (parens (separate (break 1) - [ doc_id id; - string "from " ^^ doc_atomic_exp exp1; - string "to " ^^ doc_atomic_exp exp2; - string "by " ^^ doc_atomic_exp exp3; - string "in " ^^ doc_ord order ])) - in - match exp4 with - | E_aux (E_block [_], _) -> header ^//^ doc_exp exp4 - | E_aux (E_block _, _) -> header ^^ space ^^ doc_exp exp4 - | _ -> header ^//^ doc_exp exp4 - end + let header = + string "foreach" ^^ space ^^ + group (parens (separate (break 1) + [ doc_id id; + string "from " ^^ doc_atomic_exp exp1; + string "to " ^^ doc_atomic_exp exp2; + string "by " ^^ doc_atomic_exp exp3; + string "in " ^^ doc_ord order ])) + in + header ^^ space ^^ doc_exp exp4 (* Resugar an assert with an empty message *) | E_throw exp -> string "throw" ^^ parens (doc_exp exp) | E_try (exp, pexps) -> diff --git a/src/type_check.ml b/src/type_check.ml index 23629b51..81f5fe6d 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -2301,6 +2301,11 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ in let texp = annot_exp_effect (E_assert (constr_exp, checked_msg)) unit_typ (mk_effect [BE_escape]) (Some unit_typ) in texp :: check_block l env exps typ + | ((E_aux (E_if (cond, (E_aux (E_throw _, _) | E_aux (E_block [E_aux (E_throw _, _)], _)), _), _) as exp) :: exps) -> + let texp = crule check_exp env exp (mk_typ (Typ_id (mk_id "unit"))) in + let cond' = crule check_exp env cond (mk_typ (Typ_id (mk_id "bool"))) in + let env = add_opt_constraint (option_map nc_negate (assert_constraint env false cond')) env in + texp :: check_block l env exps typ | (exp :: exps) -> let texp = crule check_exp env exp (mk_typ (Typ_id (mk_id "unit"))) in texp :: check_block l env exps typ @@ -3400,13 +3405,6 @@ and infer_funapp' l env f (typq, f_typ) xs ret_ctx_typ = let iuargs = List.map2 (fun utyp (n, uarg) -> (n, crule check_exp env uarg utyp)) utyps uargs in (iuargs, ret_typ, env) else typ_raise l (Err_unresolved_quants (f, quants, Env.get_locals env, Env.get_constraints env)) -(* - typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants - ^ " not resolved during application of " ^ string_of_id f - ^ " unresolved args: " ^ string_of_list ", " (fun (_, exp) -> string_of_exp exp) uargs - ^ "\nAll constraints: " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) - ^ "\nLocals: " ^ string_of_list ", " (fun (id, (mut, typ)) -> string_of_id id ^ " : " ^ string_of_typ typ) (Bindings.bindings (Env.get_locals env))) - *) end | (utyps, (typ :: typs)), (uargs, ((n, arg) :: args)) when List.for_all (fun kid -> is_bound kid env) (KidSet.elements (typ_frees typ)) -> diff --git a/src/type_error.ml b/src/type_error.ml index ada8e16b..a49334ac 100644 --- a/src/type_error.ml +++ b/src/type_error.ml @@ -238,6 +238,24 @@ let rec string_of_type_error err = ToBuffer.pretty 1. 400 b (pp_type_error err); "\n" ^ Buffer.contents b +let rec collapse_errors = function + | (Err_no_overloading (_, (err :: errs)) as no_collapse) -> + let err = collapse_errors (snd err) in + let errs = List.map (fun (_, err) -> collapse_errors err) errs in + let fold_equal msg err = + match msg, err with + | Some msg, Err_no_overloading _ -> Some msg + | Some msg, Err_other _ -> Some msg + | Some msg, Err_no_casts _ -> Some msg + | Some msg, err when msg = string_of_type_error err -> Some msg + | _, _ -> None + in + begin match List.fold_left fold_equal (Some (string_of_type_error err)) errs with + | Some _ -> err + | None -> no_collapse + end + | err -> err + let check : 'a. Env.t -> 'a defs -> tannot defs * Env.t = fun env defs -> try Type_check.check env defs with -- cgit v1.2.3 From 0363a325ca6c498e086519c4ecaf1f51dbff7f64 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Fri, 30 Nov 2018 18:54:42 +0000 Subject: Parser tweaks and fixes - Completely remove the nexp = nexp syntax in favour of nexp == nexp. All our existing specs have already switched over. As part of this fix every test that used the old syntax, and update the generated aarch64 specs - Remove the `type when constraint` syntax. It just makes changing the parser in any way really awkward. - Change the syntax for declaring new types with multiple type parameters from: type foo('a : Type) ('n : Int), constraint = ... to type foo('a: Type, 'n: Int), constraint = ... This makes type declarations mimic function declarations, and makes the syntax for declaring types match the syntax for using types, as foo is used as foo(type, nexp). None of our specifications use types with multiple type parameters so this change doesn't actually break anything, other than some tests. The brackets around the type parameters are now mandatory. - Experiment with splitting Type/Order type parameters from Int type parameters in the parser. Currently in a type bar(x, y, z) all of x, y, and z could be either numeric expressions, orders, or types. This means that in the parser we are severely restricted in what we can parse in numeric expressions because everything has to be parseable as a type (atyp) - it also means we can't introduce boolean type variables/expressions or other minisail features (like removing ticks from type variables!) because we are heavily constrained by what we can parse unambigiously due to how these different type parameters can be mixed and interleaved. There is now experimental syntax: vector::<'o, 'a>('n) <--> vector('n, 'o, 'a) which splits the type argument list into two between Type/Order-polymorphic arguments and Int-polymorphic arguments. The exact choice of delimiters isn't set in stone - ::< and > match generics in Rust. The obvious choices of < and > / [ and ] are ambigious in various ways. Using this syntax right now triggers a warning. - Fix undefined behaviour in C compilation when concatenating a 0-length vector with a 64-length vector. --- src/c_backend.ml | 3 ++ src/lexer.mll | 1 + src/parser.mly | 94 +++++++++++++++++++++++++----------------------- src/pretty_print_sail.ml | 31 +++++++++++++--- 4 files changed, 79 insertions(+), 50 deletions(-) (limited to 'src') diff --git a/src/c_backend.ml b/src/c_backend.ml index 326f742a..2f57a802 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -496,6 +496,9 @@ let analyze_primop' ctx id args typ = (* Optimized routines for all combinations of fixed and small bits appends, where the result is guaranteed to be smaller than 64. *) + | "append", [AV_C_fragment (vec1, _, CT_fbits (0, ord1)); AV_C_fragment (vec2, _, CT_fbits (n2, ord2)) as v2] + when ord1 = ord2 -> + AE_val v2 | "append", [AV_C_fragment (vec1, _, CT_fbits (n1, ord1)); AV_C_fragment (vec2, _, CT_fbits (n2, ord2))] when ord1 = ord2 && n1 + n2 <= 64 -> AE_val (AV_C_fragment (F_op (F_op (vec1, "<<", v_int n2), "|", vec2), typ, CT_fbits (n1 + n2, ord1))) diff --git a/src/lexer.mll b/src/lexer.mll index f5a982eb..a1f3ace2 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -217,6 +217,7 @@ rule token = parse | "@" { (At "@") } | "2" ws "^" { TwoCaret } | "^" { (Caret(r"^")) } + | "::<" { ColonColonLt } | "::" { ColonColon(r "::") } (* | "^^" { CaretCaret(r "^^") } *) | "~~" { TildeTilde(r "~~") } diff --git a/src/parser.mly b/src/parser.mly index fec38669..8287060c 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -133,6 +133,8 @@ let mk_tannot typq typ n m = Typ_annot_opt_aux(Typ_annot_opt_some (typq, typ), l let mk_eannotn = Effect_opt_aux(Effect_opt_pure,Unknown) let mk_namesectn = Name_sect_aux(Name_sect_none,Unknown) +let mk_typq kopts nc n m = TypQ_aux (TypQ_tq (List.map qi_id_of_kopt kopts @ nc), loc n m) + type lchain = LC_lt | LC_lteq @@ -171,6 +173,8 @@ let rec desugar_rchain chain s e = mk_nc (NC_and (nc1, desugar_rchain (RC_nexp n2 :: chain) s e)) s e | _ -> assert false +let future_syntax l = Util.warn (Reporting.loc_to_string l ^ "\n\nThis syntax is currently experimental") + %} /*Terminals with no content*/ @@ -185,7 +189,7 @@ let rec desugar_rchain chain s e = %nonassoc Then %nonassoc Else -%token Bar Comma Dot Eof Minus Semi Under DotDot +%token Bar Comma Dot Eof Minus Semi Under DotDot ColonColonLt %token Lcurly Rcurly Lparen Rparen Lsquare Rsquare LcurlyBar RcurlyBar LsquareBar RsquareBar %token MinusGt Bidir LtMinus @@ -196,7 +200,7 @@ let rec desugar_rchain chain s e = %token String Bin Hex Real %token Amp At Caret Eq Gt Lt Plus Star EqGt Unit -%token Colon ColonColon (* CaretCaret *) TildeTilde ExclEq +%token Colon ColonColon TildeTilde ExclEq %token EqEq %token GtEq %token LtEq @@ -339,9 +343,6 @@ atomic_nc: { mk_nc NC_true $startpos $endpos } | False { mk_nc NC_false $startpos $endpos } - | typ0 Eq typ0 - { Util.warn ("Deprecated syntax, use == instead at " ^ Reporting.loc_to_string (loc $startpos($2) $endpos($2)) ^ "\n"); - mk_nc (NC_equal ($1, $3)) $startpos $endpos } | typ0 EqEq typ0 { mk_nc (NC_equal ($1, $3)) $startpos $endpos } | typ0 ExclEq typ0 @@ -355,38 +356,6 @@ atomic_nc: | kid In Lcurly num_list Rcurly { mk_nc (NC_set ($1, $4)) $startpos $endpos } -new_nc: - | new_nc Bar new_nc_and - { mk_nc (NC_or ($1, $3)) $startpos $endpos } - | nc_and - { $1 } - -new_nc_and: - | new_nc_and Amp new_atomic_nc - { mk_nc (NC_and ($1, $3)) $startpos $endpos } - | new_atomic_nc - { $1 } - -new_atomic_nc: - | Where id Lparen typ_list Rparen - { mk_nc (NC_app ($2, $4)) $startpos $endpos } - | True - { mk_nc NC_true $startpos $endpos } - | False - { mk_nc NC_false $startpos $endpos } - | typ0 EqEq typ0 - { mk_nc (NC_equal ($1, $3)) $startpos $endpos } - | typ0 ExclEq typ0 - { mk_nc (NC_not_equal ($1, $3)) $startpos $endpos } - | nc_lchain - { desugar_lchain $1 $startpos $endpos } - | nc_rchain - { desugar_rchain $1 $startpos $endpos } - | Lparen new_nc Rparen - { $2 } - | kid In Lcurly num_list Rcurly - { mk_nc (NC_set ($1, $4)) $startpos $endpos } - num_list: | Num { [$1] } @@ -413,11 +382,17 @@ nc_rchain: | typ0 Gt nc_rchain { RC_nexp $1 :: RC_gt :: $3 } +tyarg: + | ColonColonLt typ_list Gt + { future_syntax (loc $startpos($1) $endpos($3)); $2, [] } + | Lparen typ_list Rparen + { [], $2 } + | ColonColonLt typ_list Gt Lparen typ_list Rparen + { future_syntax (loc $startpos($1) $endpos($3)); $2, $5 } + typ: | typ0 { $1 } - | typ0 With new_nc - { mk_typ (ATyp_with ($1, $3)) $startpos $endpos } /* The following implements all nine levels of user-defined precedence for operators in types, with both left, right and non-associative operators */ @@ -587,8 +562,8 @@ atomic_typ: { mk_typ ATyp_dec $startpos $endpos } | Inc { mk_typ ATyp_inc $startpos $endpos } - | id Lparen typ_list Rparen - { mk_typ (ATyp_app ($1, $3)) $startpos $endpos } + | id tyarg + { mk_typ (ATyp_app ($1, snd $2 @ fst $2)) $startpos $endpos } | Register Lparen typ Rparen { let register_id = mk_id (Id "register") $startpos($1) $endpos($1) in mk_typ (ATyp_app (register_id, [$3])) $startpos $endpos } @@ -1193,14 +1168,43 @@ r_def_body: | r_id_def Comma r_def_body { $1 :: $3 } +param_kopt: + | kid Colon kind + { KOpt_aux (KOpt_kind ($3, $1), loc $startpos $endpos) } + | kid + { KOpt_aux (KOpt_none $1, loc $startpos $endpos) } + +param_kopt_list: + | param_kopt + { [$1] } + | param_kopt Comma param_kopt_list + { $1 :: $3 } + +typaram: + | ColonColonLt param_kopt_list Gt Lparen param_kopt_list Rparen Comma nc + { future_syntax (loc $startpos($1) $endpos($3)); + let qi_nc = QI_aux (QI_const $8, loc $startpos($8) $endpos($8)) in + mk_typq ($5 @ $2) [qi_nc] $startpos $endpos } + | ColonColonLt param_kopt_list Gt Lparen param_kopt_list Rparen + { future_syntax (loc $startpos($1) $endpos($3)); + mk_typq ($5 @ $2) [] $startpos $endpos } + | ColonColonLt param_kopt_list Gt + { future_syntax (loc $startpos($1) $endpos($3)); + mk_typq $2 [] $startpos $endpos } + | Lparen param_kopt_list Rparen Comma nc + { let qi_nc = QI_aux (QI_const $5, loc $startpos($5) $endpos($5)) in + mk_typq $2 [qi_nc] $startpos $endpos } + | Lparen param_kopt_list Rparen + { mk_typq $2 [] $startpos $endpos } + type_def: - | Typedef id typquant Eq typ + | Typedef id typaram Eq typ { mk_td (TD_abbrev ($2, mk_namesectn, mk_typschm $3 $5 $startpos($3) $endpos)) $startpos $endpos } | Typedef id Eq typ { mk_td (TD_abbrev ($2, mk_namesectn, mk_typschm mk_typqn $4 $startpos($4) $endpos)) $startpos $endpos } | Struct id Eq Lcurly struct_fields Rcurly { mk_td (TD_record ($2, mk_namesectn, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), $5, false)) $startpos $endpos } - | Struct id typquant Eq Lcurly struct_fields Rcurly + | Struct id typaram Eq Lcurly struct_fields Rcurly { mk_td (TD_record ($2, mk_namesectn, $3, $6, false)) $startpos $endpos } | Enum id Eq enum_bar { mk_td (TD_enum ($2, mk_namesectn, $4, false)) $startpos $endpos } @@ -1208,11 +1212,11 @@ type_def: { mk_td (TD_enum ($2, mk_namesectn, $5, false)) $startpos $endpos } | Newtype id Eq type_union { mk_td (TD_variant ($2, mk_namesectn, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), [$4], false)) $startpos $endpos } - | Newtype id typquant Eq type_union + | Newtype id typaram Eq type_union { mk_td (TD_variant ($2, mk_namesectn, $3, [$5], false)) $startpos $endpos } | Union id Eq Lcurly type_unions Rcurly { mk_td (TD_variant ($2, mk_namesectn, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), $5, false)) $startpos $endpos } - | Union id typquant Eq Lcurly type_unions Rcurly + | Union id typaram Eq Lcurly type_unions Rcurly { mk_td (TD_variant ($2, mk_namesectn, $3, $6, false)) $startpos $endpos } | Bitfield id Colon typ Eq Lcurly r_def_body Rcurly { mk_td (TD_bitfield ($2, $4, $7)) $startpos $endpos } diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index a2771ae1..53e77df2 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -151,7 +151,7 @@ let doc_nc nc = | NC_and (c1, c2) -> separate space [nc1 c1; string "&"; atomic_nc c2] | _ -> atomic_nc nc in - nc0 ~parenthesize:true (constraint_simp nc) + atomic_nc (constraint_simp nc) let rec doc_typ ?(simple=false) (Typ_aux (typ_aux, l)) = match typ_aux with @@ -219,6 +219,27 @@ let doc_quants quants = | [nc] -> kdoc ^^ comma ^^ space ^^ doc_nc nc | nc :: ncs -> kdoc ^^ comma ^^ space ^^ doc_nc (List.fold_left nc_and nc ncs) +let doc_param_quants quants = + let doc_qi_kopt (QI_aux (qi_aux, _)) = + match qi_aux with + | QI_id (KOpt_aux (KOpt_none kid, _)) -> [doc_kid kid] + | QI_id kopt when is_nat_kopt kopt -> [doc_kid (kopt_kid kopt) ^^ colon ^^ space ^^ string "Int"] + | QI_id kopt when is_typ_kopt kopt -> [doc_kid (kopt_kid kopt) ^^ colon ^^ space ^^ string "Type"] + | QI_id kopt -> [doc_kid (kopt_kid kopt) ^^ colon ^^ space ^^ string "Order"] + | QI_const nc -> [] + in + let qi_nc (QI_aux (qi_aux, _)) = + match qi_aux with + | QI_const nc -> [nc] + | _ -> [] + in + let kdoc = separate (comma ^^ space) (List.concat (List.map doc_qi_kopt quants)) in + let ncs = List.concat (List.map qi_nc quants) in + match ncs with + | [] -> parens kdoc + | [nc] -> parens kdoc ^^ comma ^^ space ^^ doc_nc nc + | nc :: ncs -> parens kdoc ^^ comma ^^ space ^^ doc_nc (List.fold_left nc_and nc ncs) + let doc_binding ?(simple=false) ((TypQ_aux (tq_aux, _) as typq), typ) = match tq_aux with | TypQ_no_forall -> doc_typ ~simple:simple typ @@ -244,7 +265,7 @@ let doc_typschm_quants (TypSchm_aux (TypSchm_ts (TypQ_aux (tq_aux, _), typ), _)) match tq_aux with | TypQ_no_forall -> None | TypQ_tq [] -> None - | TypQ_tq qs -> Some (doc_quants qs) + | TypQ_tq qs -> Some (doc_param_quants qs) let doc_lit (L_aux(l,_)) = utf8string (match l with @@ -547,7 +568,7 @@ let doc_typdef (TD_aux(td,_)) = match td with begin match doc_typschm_quants typschm with | Some qdoc -> - doc_op equals (concat [string "type"; space; doc_id id; space; qdoc]) (doc_typschm_typ typschm) + doc_op equals (concat [string "type"; space; doc_id id; qdoc]) (doc_typschm_typ typschm) | None -> doc_op equals (concat [string "type"; space; doc_id id]) (doc_typschm_typ typschm) end @@ -556,12 +577,12 @@ let doc_typdef (TD_aux(td,_)) = match td with | TD_record (id, _, TypQ_aux (TypQ_no_forall, _), fields, _) | TD_record (id, _, TypQ_aux (TypQ_tq [], _), fields, _) -> separate space [string "struct"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_field fields) rbrace] | TD_record (id, _, TypQ_aux (TypQ_tq qs, _), fields, _) -> - separate space [string "struct"; doc_id id; doc_quants qs; equals; + separate space [string "struct"; doc_id id; doc_param_quants qs; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_field fields) rbrace] | TD_variant (id, _, TypQ_aux (TypQ_no_forall, _), unions, _) | TD_variant (id, _, TypQ_aux (TypQ_tq [], _), unions, _) -> separate space [string "union"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_union unions) rbrace] | TD_variant (id, _, TypQ_aux (TypQ_tq qs, _), unions, _) -> - separate space [string "union"; doc_id id; doc_quants qs; equals; + separate space [string "union"; doc_id id; doc_param_quants qs; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_union unions) rbrace] | _ -> string "TYPEDEF" -- cgit v1.2.3 From 666062ce4d97fe48307d1feb5bb4eb32087b177a Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Fri, 30 Nov 2018 19:33:50 +0000 Subject: Remove constraint synonyms They weren't needed for ASL parser like I thought they would be, and they increase the complexity of dealing with constraints throughout Sail, so just remove them. Also fix some compiler warnings --- src/ast_util.ml | 13 +------------ src/initial_check.ml | 8 -------- src/monomorphise.ml | 1 + src/parse_ast.ml | 2 -- src/parser.mly | 4 ---- src/pretty_print_common.ml | 1 - src/pretty_print_coq.ml | 2 +- src/pretty_print_lem.ml | 1 + src/pretty_print_sail.ml | 3 --- src/rewriter.ml | 1 - src/sail.ml | 3 --- src/spec_analysis.ml | 7 +++++-- src/type_check.ml | 45 +-------------------------------------------- src/type_check.mli | 4 ---- src/type_error.ml | 1 - 15 files changed, 10 insertions(+), 86 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index d61c96ed..14638b88 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -387,8 +387,6 @@ let rec nc_negate (NC_aux (nc, l)) = | NC_set (kid, [int]) -> nc_neq (nvar kid) (nconstant int) | NC_set (kid, int :: ints) -> mk_nc (NC_and (nc_neq (nvar kid) (nconstant int), nc_negate (mk_nc (NC_set (kid, ints))))) - | NC_app _ -> - raise (Reporting.err_unreachable l __POS__ "tried to negate constraint with unexpanded synonym") let mk_typschm typq typ = TypSchm_aux (TypSchm_ts (typq, typ), Parse_ast.Unknown) @@ -581,8 +579,8 @@ let def_loc = function | DEF_reg_dec (DEC_aux (_, (l, _))) | DEF_fixity (_, _, Id_aux (_, l)) | DEF_overload (Id_aux (_, l), _) -> l - | DEF_constraint (Id_aux (_, l), _, _) -> l | DEF_internal_mutrec _ -> Parse_ast.Unknown + | DEF_pragma (_, _, l) -> l let string_of_id = function | Id_aux (Id v, _) -> v @@ -696,8 +694,6 @@ and string_of_n_constraint = function "(" ^ string_of_n_constraint nc1 ^ " & " ^ string_of_n_constraint nc2 ^ ")" | NC_aux (NC_set (kid, ns), _) -> string_of_kid kid ^ " in {" ^ string_of_list ", " Big_int.to_string ns ^ "}" - | NC_aux (NC_app (id, nexps), _) -> - "where " ^ string_of_id id ^ "(" ^ Util.string_of_list ", " string_of_nexp nexps ^ ")" | NC_aux (NC_true, _) -> "true" | NC_aux (NC_false, _) -> "false" @@ -954,8 +950,6 @@ module NC = struct | NC_or (nc1,nc2), NC_or (nc3,nc4) | NC_and (nc1,nc2), NC_and (nc3,nc4) -> lex_ord compare compare nc1 nc3 nc2 nc4 - | NC_app (id1, nexps1), NC_app (id2, nexps2) - -> lex_ord (Id.compare) (Util.compare_list Nexp.compare) id1 id2 nexps1 nexps2 | NC_true, NC_true | NC_false, NC_false -> 0 @@ -966,7 +960,6 @@ module NC = struct | NC_set _, _ -> -1 | _, NC_set _ -> 1 | NC_or _, _ -> -1 | _, NC_or _ -> 1 | NC_and _, _ -> -1 | _, NC_and _ -> 1 - | NC_app _, _ -> -1 | _, NC_app _ -> 1 | NC_true, _ -> -1 | _, NC_true -> 1 end @@ -1152,8 +1145,6 @@ let rec tyvars_of_constraint (NC_aux (nc, _)) = | NC_or (nc1, nc2) | NC_and (nc1, nc2) -> KidSet.union (tyvars_of_constraint nc1) (tyvars_of_constraint nc2) - | NC_app (id, nexps) -> - List.fold_left KidSet.union KidSet.empty (List.map tyvars_of_nexp nexps) | NC_true | NC_false -> KidSet.empty @@ -1421,7 +1412,6 @@ let rec locate_nc f (NC_aux (nc_aux, l)) = | NC_set (kid, nums) -> NC_set (locate_kid f kid, nums) | NC_or (nc1, nc2) -> NC_or (locate_nc f nc1, locate_nc f nc2) | NC_and (nc1, nc2) -> NC_and (locate_nc f nc1, locate_nc f nc2) - | NC_app (id, nexps) -> NC_app (id, List.map (locate_nexp f) nexps) | NC_true -> NC_true | NC_false -> NC_false in @@ -1596,7 +1586,6 @@ and nc_subst_nexp_aux l sv subst = function else set_nc | NC_or (nc1, nc2) -> NC_or (nc_subst_nexp sv subst nc1, nc_subst_nexp sv subst nc2) | NC_and (nc1, nc2) -> NC_and (nc_subst_nexp sv subst nc1, nc_subst_nexp sv subst nc2) - | NC_app (id, nexps) -> NC_app (id, List.map (nexp_subst sv subst) nexps) | NC_false -> NC_false | NC_true -> NC_true diff --git a/src/initial_check.ml b/src/initial_check.ml index bd32a8e3..b442ae97 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -375,9 +375,6 @@ and to_ast_nexp_constraint (k_env : kind Envmap.t) (c : Parse_ast.n_constraint) NC_or (to_ast_nexp_constraint k_env nc1, to_ast_nexp_constraint k_env nc2) | Parse_ast.NC_and (nc1, nc2) -> NC_and (to_ast_nexp_constraint k_env nc1, to_ast_nexp_constraint k_env nc2) - | Parse_ast.NC_app (id, typs) -> - let nexps = List.map (to_ast_nexp k_env) typs in - NC_app (to_ast_id id, nexps) | Parse_ast.NC_true -> NC_true | Parse_ast.NC_false -> NC_false ), l) @@ -901,11 +898,6 @@ let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out | Parse_ast.DEF_reg_dec(dec) -> let d = to_ast_dec envs dec in ((Finished(DEF_reg_dec(d))),envs),partial_defs - | Parse_ast.DEF_constraint (id, kids, nc) -> - let id = to_ast_id id in - let kids = List.map to_ast_var kids in - let nc = to_ast_nexp_constraint k_env nc in - ((Finished (DEF_constraint (id, kids, nc))), envs), partial_defs | Parse_ast.DEF_pragma (pragma, arg, l) -> ((Finished(DEF_pragma (pragma, arg, l))), envs), partial_defs | Parse_ast.DEF_internal_mutrec _ -> diff --git a/src/monomorphise.ml b/src/monomorphise.ml index 975e8017..0d7fd6e5 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -2113,6 +2113,7 @@ let split_defs all_errors splits defs = | DEF_reg_dec _ | DEF_overload _ | DEF_fixity _ + | DEF_pragma _ | DEF_internal_mutrec _ -> [d] | DEF_fundef fd -> [DEF_fundef (map_fundef fd)] diff --git a/src/parse_ast.ml b/src/parse_ast.ml index ddff51ea..c50977ed 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -177,7 +177,6 @@ n_constraint_aux = (* constraint over kind $_$ *) | NC_set of kid * (Big_int.num) list | NC_or of n_constraint * n_constraint | NC_and of n_constraint * n_constraint - | NC_app of id * atyp list | NC_true | NC_false @@ -568,7 +567,6 @@ def = (* Top-level definition *) | DEF_scattered of scattered_def (* scattered definition *) | DEF_reg_dec of dec_spec (* register declaration *) | DEF_pragma of string * string * l - | DEF_constraint of id * kid list * n_constraint | DEF_internal_mutrec of fundef list diff --git a/src/parser.mly b/src/parser.mly index 8287060c..cd655217 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -337,8 +337,6 @@ nc_and: { $1 } atomic_nc: - | Where id Lparen typ_list Rparen - { mk_nc (NC_app ($2, $4)) $startpos $endpos } | True { mk_nc NC_true $startpos $endpos } | False @@ -1454,8 +1452,6 @@ def: { DEF_kind (KD_aux (KD_nabbrev (K_aux (K_kind [BK_aux (BK_int, loc $startpos($1) $endpos($1))], loc $startpos($1) $endpos($1)), $2, mk_namesectn, $4), loc $startpos $endpos)) } - | Constraint id Lparen kid_list Rparen Eq nc - { DEF_constraint ($2, $4, $7) } | Mutual Lcurly fun_def_list Rcurly { DEF_internal_mutrec $3 } | Pragma diff --git a/src/pretty_print_common.ml b/src/pretty_print_common.ml index 6825259c..1fb35158 100644 --- a/src/pretty_print_common.ml +++ b/src/pretty_print_common.ml @@ -207,7 +207,6 @@ let doc_typ, doc_atomic_typ, doc_nexp, doc_nexp_constraint = separate space [nexp_constraint nc1; string "&"; nexp_constraint nc2] | NC_true -> string "true" | NC_false -> string "false" - | NC_app (id, args) -> doc_id id ^^ parens (separate_map (comma ^^ space) nexp args) (* expose doc_typ, doc_atomic_typ, doc_nexp and doc_nexp_constraint *) in typ, atomic_typ, nexp, nexp_constraint diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index cfffb8c9..630d5b1e 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -1686,7 +1686,6 @@ let types_used_with_generic_eq defs = | DEF_fixity _ | DEF_overload _ | DEF_default _ - | DEF_constraint _ | DEF_pragma _ | DEF_reg_dec _ -> IdSet.empty @@ -2284,6 +2283,7 @@ let rec doc_def unimplemented generic_eq_types def = | DEF_scattered sdef -> failwith "doc_def: shoulnd't have DEF_scattered at this point" | DEF_mapdef (MD_aux (_, (l,_))) -> unreachable l __POS__ "Coq doesn't support mappings" | DEF_kind _ -> empty + | DEF_pragma _ -> empty let find_exc_typ defs = let is_exc_typ_def = function diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index 779d81f8..53b703bf 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -1420,6 +1420,7 @@ let rec doc_def_lem def = | DEF_kind _ -> empty | DEF_mapdef (MD_aux (_, (l, _))) -> unreachable l __POS__ "Lem doesn't support mappings" + | DEF_pragma _ -> empty let find_exc_typ defs = let is_exc_typ_def = function diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index 53e77df2..fe533f00 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -125,7 +125,6 @@ let doc_nc nc = | NC_bounded_le (n1, n2) -> nc_op "<=" n1 n2 | NC_set (kid, ints) -> separate space [doc_kid kid; string "in"; braces (separate_map (comma ^^ space) doc_int ints)] - | NC_app (id, nexps) -> string "where" ^^ space ^^ doc_id id ^^ parens (separate_map (comma ^^ space) doc_nexp nexps) | _ -> nc0 ~parenthesize:true nc and nc0 ?parenthesize:(parenthesize=false) (NC_aux (nc_aux, _) as nc) = (* Rather than parens (nc0 x) we use nc0 ~parenthesize:true x, because if @@ -640,8 +639,6 @@ let rec doc_def def = group (match def with | DEF_fixity (prec, n, id) -> fixities := Bindings.add id (prec, Big_int.to_int n) !fixities; separate space [doc_prec prec; doc_int n; doc_id id] - | DEF_constraint (id, kids, nc) -> - separate space [string "constraint"; doc_id id; parens (separate_map (comma ^^ space) doc_kid kids); equals; doc_nc nc] | DEF_overload (id, ids) -> separate space [string "overload"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_id ids) rbrace] ) ^^ hardline diff --git a/src/rewriter.ml b/src/rewriter.ml index cf547307..082d9850 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -359,7 +359,6 @@ let rewrite_def rewriters d = match d with | DEF_internal_mutrec fdefs -> DEF_internal_mutrec (List.map (rewriters.rewrite_fun rewriters) fdefs) | DEF_val letbind -> DEF_val (rewriters.rewrite_let rewriters letbind) | DEF_pragma (pragma, arg, l) -> DEF_pragma (pragma, arg, l) - | DEF_constraint _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "DEF_constraint survived to rewritter") | DEF_scattered _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "DEF_scattered survived to rewritter") let rewrite_defs_base rewriters (Defs defs) = diff --git a/src/sail.ml b/src/sail.ml index 417d3ef4..b9a18417 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -247,9 +247,6 @@ let options = Arg.align ([ ( "-dprofile", Arg.Set Profile.opt_profile, " (debug) provides basic profiling information for rewriting passes within Sail"); - ( "-Xconstraint_synonyms", - Arg.Set Type_check.opt_constraint_synonyms, - " (extension) allow constraint synonyms"); ( "-v", Arg.Set opt_print_version, " print version"); diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index c858754e..fa68c6f2 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -282,6 +282,10 @@ and fv_of_lexp consider_var bound used set (LEXP_aux(lexp,(_,tannot))) = (fun e (b,u,s) -> fv_of_exp consider_var b u s e) args (bound,used,set) in bound,Nameset.add (string_of_id id) used,set + | LEXP_vector_concat(args) -> + List.fold_right + (fun e (b,u,s) -> + fv_of_lexp consider_var b u s e) args (bound,used,set) | LEXP_field(lexp,_) -> fv_of_lexp consider_var bound used set lexp | LEXP_vector(lexp,exp) -> let bound_l,used,set = fv_of_lexp consider_var bound used set lexp in @@ -486,8 +490,7 @@ let fv_of_def consider_var consider_scatter_as_one all_defs = function List.fold_left Nameset.union Nameset.empty (List.map snd fvs) | DEF_scattered sdef -> fv_of_scattered consider_var consider_scatter_as_one all_defs sdef | DEF_reg_dec rdec -> fv_of_rd consider_var rdec - | DEF_constraint (id, _, _) -> - raise (Reporting.err_unreachable (id_loc id) __POS__ "Constraint should be re-written") + | DEF_pragma _ -> mt,mt let group_defs consider_scatter_as_one (Ast.Defs defs) = List.map (fun d -> (fv_of_def false consider_scatter_as_one defs d,d)) defs diff --git a/src/type_check.ml b/src/type_check.ml index 81f5fe6d..866aa071 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -69,10 +69,6 @@ let opt_no_effects = ref false assignments in l-expressions *) let opt_no_lexp_bounds_check = ref false -(* opt_constraint_synonyms allows constraint synonyms as toplevel - definitions *) -let opt_constraint_synonyms = ref false - (* opt_expand_valspec expands typedefs in valspecs during type check. We prefer not to do it for latex output but it is otherwise a good idea. *) let opt_expand_valspec = ref true @@ -171,7 +167,6 @@ and strip_n_constraint_aux = function | NC_set (kid, nums) -> NC_set (strip_kid kid, nums) | NC_or (nc1, nc2) -> NC_or (strip_n_constraint nc1, strip_n_constraint nc2) | NC_and (nc1, nc2) -> NC_and (strip_n_constraint nc1, strip_n_constraint nc2) - | NC_app (id, nexps) -> NC_app (strip_id id, List.map strip_nexp nexps) | NC_true -> NC_true | NC_false -> NC_false and strip_n_constraint = function @@ -287,11 +282,7 @@ module Env : sig val polymorphic_undefineds : t -> bool val lookup_id : ?raw:bool -> id -> t -> typ lvar val fresh_kid : ?kid:kid -> t -> kid - val expand_synonyms : t -> typ -> typ - val expand_constraint_synonyms : t -> n_constraint -> n_constraint - val expand_typquant_synonyms : t -> typquant -> typquant - val canonicalize : t -> typ -> typ val base_typ_of : t -> typ -> typ val add_smt_op : id -> string -> t -> t @@ -490,27 +481,6 @@ end = struct then () else typ_error (id_loc id) ("Could not prove " ^ string_of_list ", " string_of_n_constraint ncs ^ " for type constructor " ^ string_of_id id) - let rec expand_constraint_synonyms env (NC_aux (nc_aux, l) as nc) = - let expand = expand_constraint_synonyms env in - match nc_aux with - | NC_app (id, nexps) -> - begin - try - let kids, nc = Bindings.find id env.constraint_synonyms in - let nc = List.fold_left2 (fun nc kid nexp -> nc_subst_nexp kid (unaux_nexp nexp) nc) nc kids nexps in - expand nc - with Not_found -> typ_error l ("Could not expand constraint synonym in " ^ string_of_n_constraint nc) - end - | NC_and (nc1, nc2) -> NC_aux (NC_and (expand nc1, expand nc2), l) - | NC_or (nc1, nc2) -> NC_aux (NC_or (expand nc1, expand nc2), l) - | NC_true | NC_false | NC_set _ | NC_equal _ | NC_not_equal _ | NC_bounded_le _ | NC_bounded_ge _ -> nc - - let expand_quant_item_synonyms env = function - | QI_aux (QI_id kopt, l) -> QI_aux (QI_id kopt, l) - | QI_aux (QI_const nc, l) -> QI_aux (QI_const (expand_constraint_synonyms env nc), l) - - let expand_typquant_synonyms env = quant_map_items (expand_quant_item_synonyms env) - let rec expand_synonyms env (Typ_aux (typ, l) as t) = match typ with | Typ_internal_unknown -> Typ_aux (Typ_internal_unknown, l) @@ -718,11 +688,6 @@ end = struct end | NC_or (nc1, nc2) -> wf_constraint ~exs:exs env nc1; wf_constraint ~exs:exs env nc2 | NC_and (nc1, nc2) -> wf_constraint ~exs:exs env nc1; wf_constraint ~exs:exs env nc2 - | NC_app (id, nexps) -> - if not (Bindings.mem id env.constraint_synonyms) then - typ_error l ("Constraint synonym " ^ string_of_id id ^ " is not defined") - else (); - List.iter (wf_nexp ~exs:exs env) nexps | NC_true | NC_false -> () let counter = ref 0 @@ -783,7 +748,6 @@ end = struct forall 'n, 'n >= 2. (int('n), foo) -> bar this enforces the invariant that all things on the left of functions are 'base types' (i.e. without existentials) *) - let typq = expand_typquant_synonyms env typq in let base_args = List.map (destruct_exist env) arg_typs in let existential_arg typq = function | None -> typq @@ -1063,7 +1027,6 @@ end = struct match nc_aux with | NC_true -> env | _ -> - let constr = expand_constraint_synonyms env constr in typ_print (lazy (adding ^ "constraint " ^ string_of_n_constraint constr)); { env with constraints = constr :: env.constraints } @@ -1162,8 +1125,7 @@ let add_typquant l (quant : typquant) (env : Env.t) : Env.t = | TypQ_aux (TypQ_tq quants, _) -> List.fold_left add_quant_item env quants let expand_bind_synonyms l env (typq, typ) = - Env.expand_typquant_synonyms env typq, Env.expand_synonyms (add_typquant l typq env) typ - + typq, Env.expand_synonyms (add_typquant l typq env) typ (* Create vectors with the default order from the environment *) @@ -1335,7 +1297,6 @@ let rec nc_constraint env var_of (NC_aux (nc, l)) = (List.map (fun i -> Constraint.eq (nexp_constraint env var_of (nvar kid)) (Constraint.constant i)) ints) | NC_or (nc1, nc2) -> Constraint.disj (nc_constraint env var_of nc1) (nc_constraint env var_of nc2) | NC_and (nc1, nc2) -> Constraint.conj (nc_constraint env var_of nc1) (nc_constraint env var_of nc2) - | NC_app (id, nexps) -> raise (Reporting.err_unreachable l __POS__ "constraint synonym reached smt generation") | NC_false -> Constraint.literal false | NC_true -> Constraint.literal true @@ -4527,10 +4488,6 @@ and check_def : 'a. Env.t -> 'a def -> (tannot def) list * Env.t = | DEF_fixity (prec, n, op) -> [DEF_fixity (prec, n, op)], env | DEF_fundef fdef -> check_fundef env fdef | DEF_mapdef mdef -> check_mapdef env mdef - | DEF_constraint (id, kids, nc) when !opt_constraint_synonyms -> - [], Env.add_constraint_synonym id kids nc env - | DEF_constraint (id, _, _) -> - typ_error (id_loc id) "Use -Xconstraint_synonyms to enable constraint synonyms" | DEF_internal_mutrec fdefs -> let defs = List.concat (List.map (fun fdef -> fst (check_fundef env fdef)) fdefs) in let split_fundef (defs, fdefs) def = match def with diff --git a/src/type_check.mli b/src/type_check.mli index dc1cfe97..1081af08 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -67,10 +67,6 @@ val opt_no_effects : bool ref assignments in l-expressions. *) val opt_no_lexp_bounds_check : bool ref -(** [opt_constraint_synonyms] allows constraint synonyms as toplevel - definitions *) -val opt_constraint_synonyms : bool ref - (** opt_expand_valspec expands typedefs in valspecs during type check. We prefer not to do it for latex output but it is otherwise a good idea. *) val opt_expand_valspec : bool ref diff --git a/src/type_error.ml b/src/type_error.ml index a49334ac..7551970f 100644 --- a/src/type_error.ml +++ b/src/type_error.ml @@ -96,7 +96,6 @@ and nc_subst_nexp_aux l sv subst = function else set_nc | NC_or (nc1, nc2) -> NC_or (nc_subst_nexp sv subst nc1, nc_subst_nexp sv subst nc2) | NC_and (nc1, nc2) -> NC_and (nc_subst_nexp sv subst nc1, nc_subst_nexp sv subst nc2) - | NC_app (id, nexps) -> NC_app (id, List.map (nexp_subst sv subst) nexps) | NC_false -> NC_false | NC_true -> NC_true -- cgit v1.2.3 From 945c8b10a9498d0606f4226bc18d03ef806184f2 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Tue, 4 Dec 2018 13:42:01 +0000 Subject: Simplify kinds in the AST Rather than having K_aux (K_kind [BK_aux (BK_int, _)], _) represent the Int kind, we now just have K_aux (K_int, _). Since the language is first order we have no need for fancy kinds in the AST. --- src/ast_util.ml | 24 ++++++------ src/ast_util.mli | 5 +-- src/initial_check.ml | 34 ++++++----------- src/monomorphise.ml | 12 +++--- src/parse_ast.ml | 30 +++++---------- src/parser.mly | 19 ++++------ src/pretty_print_coq.ml | 8 ++-- src/return_analysis.ml | 2 +- src/rewrites.ml | 4 +- src/specialize.ml | 4 +- src/type_check.ml | 98 +++++++++++++++++++++++-------------------------- src/type_check.mli | 6 +-- 12 files changed, 104 insertions(+), 142 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index 14638b88..ffe4c90e 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -106,13 +106,13 @@ let mk_funcl id pat body = FCL_aux (FCL_Funcl (id, Pat_aux (Pat_exp (pat, body), let mk_qi_nc nc = QI_aux (QI_const nc, Parse_ast.Unknown) -let mk_qi_id bk kid = +let mk_qi_id k kid = let kopt = - KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (bk, Parse_ast.Unknown)], Parse_ast.Unknown), kid), Parse_ast.Unknown) + KOpt_aux (KOpt_kind (K_aux (k, Parse_ast.Unknown), kid), Parse_ast.Unknown) in QI_aux (QI_id kopt, Parse_ast.Unknown) -let mk_qi_kopt kopt =QI_aux (QI_id kopt, Parse_ast.Unknown) +let mk_qi_kopt kopt = QI_aux (QI_id kopt, Parse_ast.Unknown) let mk_fundef funcls = let tannot_opt = Typ_annot_opt_aux (Typ_annot_opt_none, Parse_ast.Unknown) in @@ -131,16 +131,16 @@ let kopt_kid (KOpt_aux (kopt_aux, _)) = | KOpt_none kid | KOpt_kind (_, kid) -> kid let is_nat_kopt = function - | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_int, _)], _), _), _) -> true + | KOpt_aux (KOpt_kind (K_aux (K_int, _), _), _) -> true | KOpt_aux (KOpt_none _, _) -> true | _ -> false let is_order_kopt = function - | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_order, _)], _), _), _) -> true + | KOpt_aux (KOpt_kind (K_aux (K_order, _), _), _) -> true | _ -> false let is_typ_kopt = function - | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_type, _)], _), _), _) -> true + | KOpt_aux (KOpt_kind (K_aux (K_type, _), _), _) -> true | _ -> false let string_of_kid = function @@ -625,14 +625,12 @@ let string_of_base_effect_aux = function (*| BE_lset -> "lset" | BE_lret -> "lret"*) -let string_of_base_kind_aux = function - | BK_type -> "Type" - | BK_int -> "Int" - | BK_order -> "Order" +let string_of_kind_aux = function + | K_type -> "Type" + | K_int -> "Int" + | K_order -> "Order" -let string_of_base_kind (BK_aux (bk, _)) = string_of_base_kind_aux bk - -let string_of_kind (K_aux (K_kind bks, _)) = string_of_list " -> " string_of_base_kind bks +let string_of_kind (K_aux (k, _)) = string_of_kind_aux k let string_of_base_effect = function | BE_aux (beff, _) -> string_of_base_effect_aux beff diff --git a/src/ast_util.mli b/src/ast_util.mli index 8f555744..b7979e88 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -85,7 +85,7 @@ val mk_fundef : (unit funcl) list -> unit def val mk_val_spec : val_spec_aux -> unit def val mk_typschm : typquant -> typ -> typschm val mk_typquant : quant_item list -> typquant -val mk_qi_id : base_kind_aux -> kid -> quant_item +val mk_qi_id : kind_aux -> kid -> quant_item val mk_qi_nc : n_constraint -> quant_item val mk_qi_kopt : kinded_id -> quant_item val mk_fexp : id -> unit exp -> unit fexp @@ -207,8 +207,7 @@ val def_loc : 'a def -> Parse_ast.l val string_of_id : id -> string val string_of_kid : kid -> string val string_of_base_effect_aux : base_effect_aux -> string -val string_of_base_kind_aux : base_kind_aux -> string -val string_of_base_kind : base_kind -> string +val string_of_kind_aux : kind_aux -> string val string_of_kind : kind -> string val string_of_base_effect : base_effect -> string val string_of_effect : effect -> string diff --git a/src/initial_check.ml b/src/initial_check.ml index b442ae97..d1efb374 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -149,23 +149,11 @@ let to_ast_id (Parse_ast.Id_aux(id, l)) = let to_ast_var (Parse_ast.Kid_aux(Parse_ast.Var v,l)) = Kid_aux(Var v,l) -let to_ast_base_kind (Parse_ast.BK_aux(k,l')) = +let to_ast_kind (Parse_ast.K_aux(k,l')) = match k with - | Parse_ast.BK_type -> BK_aux(BK_type,l'), { k = K_Typ} - | Parse_ast.BK_int -> BK_aux(BK_int,l'), { k = K_Nat } - | Parse_ast.BK_order -> BK_aux(BK_order,l'), { k = K_Ord } - -let to_ast_kind (k_env : kind Envmap.t) (Parse_ast.K_aux(Parse_ast.K_kind(klst),l)) : (Ast.kind * kind) = - match klst with - | [] -> raise (Reporting.err_unreachable l __POS__ "Kind with empty kindlist encountered") - | [k] -> let k_ast,k_typ = to_ast_base_kind k in - K_aux(K_kind([k_ast]),l), k_typ - | ks -> let k_pairs = List.map to_ast_base_kind ks in - let reverse_typs = List.rev (List.map snd k_pairs) in - let ret,args = List.hd reverse_typs, List.rev (List.tl reverse_typs) in - match ret.k with - | K_Typ -> K_aux(K_kind(List.map fst k_pairs), l), { k = K_Lam(args,ret) } - | _ -> typ_error l "Type constructor must have an -> kind ending in Type" None None None + | Parse_ast.K_type -> K_aux(K_type,l'), { k = K_Typ} + | Parse_ast.K_int -> K_aux(K_int,l'), { k = K_Nat } + | Parse_ast.K_order -> K_aux(K_order,l'), { k = K_Ord } let rec to_ast_typ (k_env : kind Envmap.t) (def_ord : order) (t: Parse_ast.atyp) : Ast.typ = (* let _ = Printf.eprintf "to_ast_typ\n" in*) @@ -392,7 +380,7 @@ let to_ast_typquant (k_env: kind Envmap.t) (tq : Parse_ast.typquant) : typquant | Parse_ast.KOpt_kind(k,v) -> let v = to_ast_var v in let key = var_to_string v in - let kind,ktyp = to_ast_kind k_env k in + let kind,ktyp = to_ast_kind k in v,key,Some(kind),Some(ktyp) in if (Nameset.mem key local_names) @@ -639,13 +627,13 @@ and to_ast_record_try (k_env:kind Envmap.t) (def_ord:order) (Parse_ast.E_aux(exp let to_ast_default (names, k_env, default_order) (default : Parse_ast.default_typing_spec) : default_spec envs_out = match default with - | Parse_ast.DT_aux(Parse_ast.DT_order(bk,o),l) -> - let k,k_typ = to_ast_base_kind bk in + | Parse_ast.DT_aux(Parse_ast.DT_order(k,o),l) -> + let k,k_typ = to_ast_kind k in (match (k,o) with - | (BK_aux(BK_order, _), Parse_ast.ATyp_aux(Parse_ast.ATyp_inc,lo)) -> + | (K_aux(K_order, _), Parse_ast.ATyp_aux(Parse_ast.ATyp_inc,lo)) -> let default_order = Ord_aux(Ord_inc,lo) in DT_aux(DT_order default_order,l),(names,k_env,default_order) - | (BK_aux(BK_order, _), Parse_ast.ATyp_aux(Parse_ast.ATyp_dec,lo)) -> + | (K_aux(K_order, _), Parse_ast.ATyp_aux(Parse_ast.ATyp_dec,lo)) -> let default_order = Ord_aux(Ord_dec,lo) in DT_aux(DT_order default_order,l),(names,k_env,default_order) | _ -> typ_error l "Inc and Dec must have kind Order" None None None) @@ -732,7 +720,7 @@ let to_ast_kdef (names, k_env, def_ord) (td:Parse_ast.kind_def) : unit kind_def match td with | Parse_ast.KD_aux (Parse_ast.KD_nabbrev (kind, id, name_scm_opt, atyp), l) -> let id = to_ast_id id in - let (kind, k) = to_ast_kind k_env kind in + let (kind, k) = to_ast_kind kind in KD_aux (KD_nabbrev (kind, id, to_ast_namescm name_scm_opt, to_ast_nexp k_env atyp), (l, ())) let to_ast_rec (Parse_ast.Rec_aux(r,l): Parse_ast.rec_opt) : rec_opt = @@ -1257,7 +1245,7 @@ let generate_enum_functions vs_ids (Defs defs) = if IdSet.mem name vs_ids then [] else [ enum_val_spec name - [mk_qi_id BK_int kid; mk_qi_nc (range_constraint kid)] + [mk_qi_id K_int kid; mk_qi_nc (range_constraint kid)] (function_typ [atom_typ (nvar kid)] (mk_typ (Typ_id id)) no_effect); mk_fundef [funcl] ] in diff --git a/src/monomorphise.ml b/src/monomorphise.ml index 0d7fd6e5..6a262df6 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -749,7 +749,7 @@ let reduce_cast typ exp l annot = let typ' = Env.base_typ_of env typ in match exp, destruct_exist env typ' with | E_aux (E_lit (L_aux (L_num n,_)),_), Some ([kid],nc,typ'') when atom_typ_kid kid typ'' -> - let nc_env = Env.add_typ_var l kid BK_int env in + let nc_env = Env.add_typ_var l kid K_int env in let nc_env = Env.add_constraint (nc_eq (nvar kid) (nconstant n)) nc_env in if prove nc_env nc then exp @@ -2774,7 +2774,7 @@ let update_env_new_kids env deps typ_env_pre typ_env_post = let kbound = KBindings.merge (fun k x y -> match x,y with - | Some bk, None -> Some bk + | Some k, None -> Some k | _ -> None) (Env.get_typ_vars typ_env_post) (Env.get_typ_vars typ_env_pre) @@ -3190,7 +3190,7 @@ let rec analyse_exp fn_id env assigns (E_aux (e,(l,annot)) as exp) = { env with kid_deps = List.fold_left (fun kds kid -> KBindings.add kid deps kds) env.kid_deps kids }, Env.add_constraint nc - (List.fold_left (fun tenv kid -> Env.add_typ_var l kid BK_int tenv) tenv kids), + (List.fold_left (fun tenv kid -> Env.add_typ_var l kid K_int tenv) tenv kids), typ in if is_bitvector_typ typ then @@ -4031,9 +4031,9 @@ let fill_in_type env typ = let tyvars = tyvars_of_typ typ in let subst = KidSet.fold (fun kid subst -> match Env.get_typ_var kid env with - | BK_type - | BK_order -> subst - | BK_int -> + | K_type + | K_order -> subst + | K_int -> (match solve env (nvar kid) with | None -> subst | Some n -> KBindings.add kid (nconstant n) subst)) tyvars KBindings.empty in diff --git a/src/parse_ast.ml b/src/parse_ast.ml index c50977ed..38854d48 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -70,15 +70,15 @@ type x = text (* identifier *) type ix = text (* infix identifier *) type -base_kind_aux = (* base kind *) - BK_type (* kind of types *) - | BK_int (* kind of natural number size expressions *) - | BK_order (* kind of vector order specifications *) +kind_aux = (* base kind *) + K_type (* kind of types *) + | K_int (* kind of natural number size expressions *) + | K_order (* kind of vector order specifications *) type -base_kind = - BK_aux of base_kind_aux * l +kind = + K_aux of kind_aux * l type @@ -110,13 +110,7 @@ id_aux = (* Identifier *) Id of x | DeIid of x (* remove infix status *) - -type -kind_aux = (* kinds *) - K_kind of (base_kind) list - - -type +type base_effect = BE_aux of base_effect_aux * l @@ -130,13 +124,7 @@ type id = Id_aux of id_aux * l - -type -kind = - K_aux of kind_aux * l - - -type +type atyp_aux = (* expressions of all kinds, to be translated to types, nats, orders, and effects after parsing *) ATyp_id of id (* identifier *) | ATyp_var of kid (* ticked variable *) @@ -425,7 +413,7 @@ name_scm_opt = type default_typing_spec_aux = (* Default kinding or typing assumption, and default order for literal vectors and vector shorthands *) - DT_order of base_kind * atyp + DT_order of kind * atyp type mpat_aux = (* Mapping pattern. Mostly the same as normal patterns but only constructible parts *) diff --git a/src/parser.mly b/src/parser.mly index cd655217..fd6c9373 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -585,17 +585,13 @@ typ_list: | typ Comma typ_list { $1 :: $3 } -base_kind: +kind: | Int - { BK_aux (BK_int, loc $startpos $endpos) } + { K_aux (K_int, loc $startpos $endpos) } | TYPE - { BK_aux (BK_type, loc $startpos $endpos) } + { K_aux (K_type, loc $startpos $endpos) } | Order - { BK_aux (BK_order, loc $startpos $endpos) } - -kind: - | base_kind - { K_aux (K_kind [$1], loc $startpos $endpos) } + { K_aux (K_order, loc $startpos $endpos) } kopt: | Lparen kid Colon kind Rparen @@ -1393,9 +1389,9 @@ register_def: { mk_reg_dec (DEC_config ($3, $5, $7)) $startpos $endpos } default_def: - | Default base_kind Inc + | Default kind Inc { mk_default (DT_order ($2, mk_typ ATyp_inc $startpos($3) $endpos)) $startpos $endpos } - | Default base_kind Dec + | Default kind Dec { mk_default (DT_order ($2, mk_typ ATyp_dec $startpos($3) $endpos)) $startpos $endpos } scattered_def: @@ -1449,8 +1445,7 @@ def: | default_def { DEF_default $1 } | Constant id Eq typ - { DEF_kind (KD_aux (KD_nabbrev (K_aux (K_kind [BK_aux (BK_int, loc $startpos($1) $endpos($1))], - loc $startpos($1) $endpos($1)), $2, mk_namesectn, $4), + { DEF_kind (KD_aux (KD_nabbrev (K_aux (K_int, loc $startpos($1) $endpos($1)), $2, mk_namesectn, $4), loc $startpos $endpos)) } | Mutual Lcurly fun_def_list Rcurly { DEF_internal_mutrec $3 } diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 630d5b1e..4b466326 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -598,12 +598,12 @@ let doc_quant_item_id ctx delimit (QI_aux (qi,_)) = | QI_id (KOpt_aux (KOpt_none kid,_)) -> if KBindings.mem kid ctx.kid_id_renames then None else Some (delimit (separate space [doc_var ctx kid; colon; string "Z"])) - | QI_id (KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (kind,_)],_),kid),_)) -> begin + | QI_id (KOpt_aux (KOpt_kind (K_aux (kind,_),kid),_)) -> begin if KBindings.mem kid ctx.kid_id_renames then None else match kind with - | BK_type -> Some (delimit (separate space [doc_var ctx kid; colon; string "Type"])) - | BK_int -> Some (delimit (separate space [doc_var ctx kid; colon; string "Z"])) - | BK_order -> None + | K_type -> Some (delimit (separate space [doc_var ctx kid; colon; string "Type"])) + | K_int -> Some (delimit (separate space [doc_var ctx kid; colon; string "Z"])) + | K_order -> None end | QI_id _ -> failwith "Quantifier with multiple kinds" | QI_const nc -> None diff --git a/src/return_analysis.ml b/src/return_analysis.ml index f60366fc..06565b01 100644 --- a/src/return_analysis.ml +++ b/src/return_analysis.ml @@ -114,7 +114,7 @@ let existentialize_annot funcl_annot annot = when Id.compare ty_id (mk_id "atom") = 0 -> let tyvars = Env.get_typ_vars funcl_env |> KBindings.bindings in let toplevel_kids = - List.filter (fun (kid, bk) -> match bk with BK_int -> true | _ -> false) tyvars |> List.map fst |> KidSet.of_list + List.filter (fun (kid, k) -> match k with K_int -> true | _ -> false) tyvars |> List.map fst |> KidSet.of_list in let new_kids = KidSet.diff (tyvars_of_nexp nexp) toplevel_kids in diff --git a/src/rewrites.ml b/src/rewrites.ml index f10c0059..2734e91f 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2096,7 +2096,7 @@ let rewrite_split_fun_constr_pats fun_name (Defs defs) = let quant_tyvars = List.fold_left KidSet.union KidSet.empty (List.map tyvars_of_quant_item qis) in let typ_tyvars = tyvars_of_typ fun_typ in let new_tyvars = KidSet.diff typ_tyvars quant_tyvars in - List.map (mk_qi_id BK_int) (KidSet.elements new_tyvars) + List.map (mk_qi_id K_int) (KidSet.elements new_tyvars) in let typquant = match typquant with | TypQ_aux (TypQ_tq qis, l) -> @@ -2108,7 +2108,7 @@ let rewrite_split_fun_constr_pats fun_name (Defs defs) = in TypQ_aux (TypQ_tq qis, l) | _ -> - TypQ_aux (TypQ_tq (List.map (mk_qi_id BK_int) (KidSet.elements (tyvars_of_typ fun_typ))), l) + TypQ_aux (TypQ_tq (List.map (mk_qi_id K_int) (KidSet.elements (tyvars_of_typ fun_typ))), l) in let val_spec = VS_aux (VS_val_spec diff --git a/src/specialize.ml b/src/specialize.ml index 4d7a997f..6e625176 100644 --- a/src/specialize.ml +++ b/src/specialize.ml @@ -319,8 +319,8 @@ let specialize_id_valspec instantiations id ast = (* Remove type variables from the type quantifier. *) let kopts, constraints = quant_split typq in let kopts = List.filter (fun kopt -> not (is_typ_kopt kopt || is_order_kopt kopt)) kopts in - let typq = mk_typquant (List.map (mk_qi_id BK_type) typ_frees - @ List.map (mk_qi_id BK_int) int_frees + let typq = mk_typquant (List.map (mk_qi_id K_type) typ_frees + @ List.map (mk_qi_id K_int) int_frees @ List.map mk_qi_kopt kopts @ List.map mk_qi_nc constraints) in let typschm = mk_typschm typq typ in diff --git a/src/type_check.ml b/src/type_check.ml index 866aa071..d39ce27d 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -209,11 +209,7 @@ and strip_kinded_id_aux = function | KOpt_none kid -> KOpt_none (strip_kid kid) | KOpt_kind (kind, kid) -> KOpt_kind (strip_kind kind, strip_kid kid) and strip_kind = function - | K_aux (k_aux, _) -> K_aux (strip_kind_aux k_aux, Parse_ast.Unknown) -and strip_kind_aux = function - | K_kind base_kinds -> K_kind (List.map strip_base_kind base_kinds) -and strip_base_kind = function - | BK_aux (bk_aux, _) -> BK_aux (bk_aux, Parse_ast.Unknown) + | K_aux (k_aux, _) -> K_aux (k_aux, Parse_ast.Unknown) let adding = Util.("Adding " |> darkgray |> clear) @@ -250,11 +246,11 @@ module Env : sig val is_mutable : id -> t -> bool val get_constraints : t -> n_constraint list val add_constraint : n_constraint -> t -> t - val get_typ_var : kid -> t -> base_kind_aux + val get_typ_var : kid -> t -> kind_aux val get_typ_var_loc : kid -> t -> Ast.l - val get_typ_vars : t -> base_kind_aux KBindings.t + val get_typ_vars : t -> kind_aux KBindings.t val get_typ_var_locs : t -> Ast.l KBindings.t - val add_typ_var : l -> kid -> base_kind_aux -> t -> t + val add_typ_var : l -> kid -> kind_aux -> t -> t val get_ret_typ : t -> typ option val add_ret_typ : typ -> t -> t val add_typ_synonym : id -> (t -> typ_arg list -> typ) -> t -> t @@ -320,7 +316,7 @@ end = struct registers : (effect * effect * typ) Bindings.t; variants : (typquant * type_union list) Bindings.t; mappings : (typquant * typ * typ) Bindings.t; - typ_vars : (Ast.l * base_kind_aux) KBindings.t; + typ_vars : (Ast.l * kind_aux) KBindings.t; typ_synonyms : (t -> typ_arg list -> typ) Bindings.t; num_defs : nexp Bindings.t; overloads : (id list) Bindings.t; @@ -388,26 +384,26 @@ end = struct let get_typ_vars env = KBindings.map snd env.typ_vars let get_typ_var_locs env = KBindings.map fst env.typ_vars - let bk_counter = ref 0 - let bk_name () = let kid = mk_kid ("bk#" ^ string_of_int !bk_counter) in incr bk_counter; kid + let k_counter = ref 0 + let k_name () = let kid = mk_kid ("k#" ^ string_of_int !k_counter) in incr k_counter; kid - let kinds_typq kinds = mk_typquant (List.map (fun k -> mk_qi_id k (bk_name ())) kinds) + let kinds_typq kinds = mk_typquant (List.map (fun k -> mk_qi_id k (k_name ())) kinds) let builtin_typs = List.fold_left (fun m (name, kinds) -> Bindings.add (mk_id name) (kinds_typq kinds) m) Bindings.empty - [ ("range", [BK_int; BK_int]); - ("atom", [BK_int]); - ("vector", [BK_int; BK_order; BK_type]); - ("register", [BK_type]); + [ ("range", [K_int; K_int]); + ("atom", [K_int]); + ("vector", [K_int; K_order; K_type]); + ("register", [K_type]); ("bit", []); ("unit", []); ("int", []); ("nat", []); ("bool", []); ("real", []); - ("list", [BK_type]); + ("list", [K_type]); ("string", []); - ("itself", [BK_int]) + ("itself", [K_int]) ] let builtin_mappings = @@ -517,10 +513,10 @@ end = struct try let (l, _) = KBindings.find kid env.typ_vars in rebindings := kid :: !rebindings; - { env with typ_vars = KBindings.add (prepend_kid "syn#" kid) (l, BK_int) env.typ_vars } + { env with typ_vars = KBindings.add (prepend_kid "syn#" kid) (l, K_int) env.typ_vars } with | Not_found -> - { env with typ_vars = KBindings.add kid (l, BK_int) env.typ_vars } + { env with typ_vars = KBindings.add kid (l, K_int) env.typ_vars } in let env = List.fold_left add_typ_var env kids in @@ -612,9 +608,9 @@ end = struct | Typ_id id -> typ_error l ("Undefined type " ^ string_of_id id) | Typ_var kid -> begin match KBindings.find kid env.typ_vars with - | (_, BK_type) -> () + | (_, K_type) -> () | (_, k) -> typ_error l ("Kind identifier " ^ string_of_kid kid ^ " in type " ^ string_of_typ typ - ^ " is " ^ string_of_base_kind_aux k ^ " rather than Type") + ^ " is " ^ string_of_kind_aux k ^ " rather than Type") | exception Not_found -> typ_error l ("Unbound kind identifier " ^ string_of_kid kid ^ " in type " ^ string_of_typ typ) end @@ -646,10 +642,10 @@ end = struct | Nexp_var kid -> begin match get_typ_var kid env with - | BK_int -> () + | K_int -> () | kind -> typ_error l ("Constraint is badly formed, " ^ string_of_kid kid ^ " has kind " - ^ string_of_base_kind_aux kind ^ " but should have kind Int") + ^ string_of_kind_aux kind ^ " but should have kind Int") end | Nexp_constant _ -> () | Nexp_app (id, nexps) -> @@ -665,10 +661,10 @@ end = struct | Ord_var kid -> begin match get_typ_var kid env with - | BK_order -> () + | K_order -> () | kind -> typ_error l ("Order is badly formed, " ^ string_of_kid kid ^ " has kind " - ^ string_of_base_kind_aux kind ^ " but should have kind Order") + ^ string_of_kind_aux kind ^ " but should have kind Order") end | Ord_inc | Ord_dec -> () and wf_constraint ?exs:(exs=KidSet.empty) env (NC_aux (nc_aux, l) as nc) = @@ -681,10 +677,10 @@ end = struct | NC_set (kid, _) when KidSet.mem kid exs -> () | NC_set (kid, _) -> begin match get_typ_var kid env with - | BK_int -> () + | K_int -> () | kind -> typ_error l ("Set constraint is badly formed, " ^ string_of_kid kid ^ " has kind " - ^ string_of_base_kind_aux kind ^ " but should have kind Int") + ^ string_of_kind_aux kind ^ " but should have kind Int") end | NC_or (nc1, nc2) -> wf_constraint ~exs:exs env nc1; wf_constraint ~exs:exs env nc2 | NC_and (nc1, nc2) -> wf_constraint ~exs:exs env nc1; wf_constraint ~exs:exs env nc2 @@ -716,7 +712,7 @@ end = struct let get_val_spec id env = try let bind = Bindings.find id env.top_val_specs in - typ_debug (lazy ("get_val_spec: Env has " ^ string_of_list ", " (fun (kid, (_, bk)) -> string_of_kid kid ^ " => " ^ string_of_base_kind_aux bk) (KBindings.bindings env.typ_vars))); + typ_debug (lazy ("get_val_spec: Env has " ^ string_of_list ", " (fun (kid, (_, k)) -> string_of_kid kid ^ " => " ^ string_of_kind_aux k) (KBindings.bindings env.typ_vars))); let bind' = List.fold_left (fun bind (kid, _) -> freshen_kid env kid bind) bind (KBindings.bindings env.typ_vars) in typ_debug (lazy ("get_val_spec: freshened to " ^ string_of_bind bind')); bind' @@ -752,7 +748,7 @@ end = struct let existential_arg typq = function | None -> typq | Some (exs, nc, _) -> - List.fold_left (fun typq kid -> quant_add (mk_qi_id BK_int kid) typq) (quant_add (mk_qi_nc nc) typq) exs + List.fold_left (fun typq kid -> quant_add (mk_qi_id K_int kid) typq) (quant_add (mk_qi_nc nc) typq) exs in let typq = List.fold_left existential_arg typq base_args in let arg_typs = List.map2 (fun typ -> function Some (_, _, typ) -> typ | None -> typ) arg_typs base_args in @@ -1003,7 +999,7 @@ end = struct then typ_error (kid_loc kid) ("type variable " ^ string_of_kid kid ^ " is already bound") else begin - typ_print (lazy (adding ^ "type variable " ^ string_of_kid kid ^ " : " ^ string_of_base_kind_aux k)); + typ_print (lazy (adding ^ "type variable " ^ string_of_kid kid ^ " : " ^ string_of_kind_aux k)); { env with typ_vars = KBindings.add kid (l, k) env.typ_vars } end @@ -1116,9 +1112,8 @@ let add_typquant l (quant : typquant) (env : Env.t) : Env.t = | QI_aux (qi, _) -> add_quant_item_aux env qi and add_quant_item_aux env = function | QI_const constr -> Env.add_constraint constr env - | QI_id (KOpt_aux (KOpt_none kid, _)) -> Env.add_typ_var l kid BK_int env - | QI_id (KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (k, _)], _), kid), _)) -> Env.add_typ_var l kid k env - | QI_id (KOpt_aux (_, l)) -> typ_error l "Type variable had non base kinds!" + | QI_id (KOpt_aux (KOpt_none kid, _)) -> Env.add_typ_var l kid K_int env + | QI_id (KOpt_aux (KOpt_kind (K_aux (k, _), kid), _)) -> Env.add_typ_var l kid k env in match quant with | TypQ_aux (TypQ_no_forall, _) -> env @@ -1150,10 +1145,10 @@ let destruct_exist env typ = | _ -> None let add_existential l kids nc env = - let env = List.fold_left (fun env kid -> Env.add_typ_var l kid BK_int env) env kids in + let env = List.fold_left (fun env kid -> Env.add_typ_var l kid K_int env) env kids in Env.add_constraint nc env -let add_typ_vars l kids env = List.fold_left (fun env kid -> Env.add_typ_var l kid BK_int env) env kids +let add_typ_vars l kids env = List.fold_left (fun env kid -> Env.add_typ_var l kid K_int env) env kids let is_exist = function | Typ_aux (Typ_exist (_, _, _), _) -> true @@ -1344,7 +1339,7 @@ let solve env nexp = try KBindings.find kid !bindings with | Not_found -> fresh_var kid in - let env = Env.add_typ_var Parse_ast.Unknown (mk_kid "solve#") BK_int env in + let env = Env.add_typ_var Parse_ast.Unknown (mk_kid "solve#") K_int env in let constr = Constraint.conj (nc_constraints env var_of (Env.get_constraints env)) (nc_constraint env var_of (nc_eq (nvar (mk_kid "solve#")) nexp)) in @@ -1868,7 +1863,7 @@ let rec subtyp l env (Typ_aux (typ_aux1, _) as typ1) (Typ_aux (typ_aux2, _) as t let env = match existential_kids, existential_nc with | [], None -> env | _, Some enc -> - let env = List.fold_left (fun env kid -> Env.add_typ_var l kid BK_int env) env existential_kids in + let env = List.fold_left (fun env kid -> Env.add_typ_var l kid K_int env) env existential_kids in Env.add_constraint enc env | _, None -> assert false (* Cannot have existential_kids without existential_nc *) in @@ -1945,16 +1940,16 @@ let infer_lit env (L_aux (lit_aux, l) as lit) = | L_undef -> typ_error l "Cannot infer the type of undefined" let is_nat_kid kid = function - | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_int, _)], _), kid'), _) -> Kid.compare kid kid' = 0 + | KOpt_aux (KOpt_kind (K_aux (K_int, _), kid'), _) -> Kid.compare kid kid' = 0 | KOpt_aux (KOpt_none kid', _) -> Kid.compare kid kid' = 0 | _ -> false let is_order_kid kid = function - | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_order, _)], _), kid'), _) -> Kid.compare kid kid' = 0 + | KOpt_aux (KOpt_kind (K_aux (K_order, _), kid'), _) -> Kid.compare kid kid' = 0 | _ -> false let is_typ_kid kid = function - | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_type, _)], _), kid'), _) -> Kid.compare kid kid' = 0 + | KOpt_aux (KOpt_kind (K_aux (K_type, _), kid'), _) -> Kid.compare kid kid' = 0 | _ -> false let rec instantiate_quants quants kid uvar = match quants with @@ -2883,7 +2878,7 @@ and bind_typ_pat env (TP_aux (typ_pat_aux, l) as typ_pat) (Typ_aux (typ_aux, _) begin match typ_nexps typ with | [nexp] -> - Env.add_constraint (nc_eq (nvar kid) nexp) (Env.add_typ_var l kid BK_int env) + Env.add_constraint (nc_eq (nvar kid) nexp) (Env.add_typ_var l kid K_int env) | [] -> typ_error l ("No numeric expressions in " ^ string_of_typ typ ^ " to bind " ^ string_of_kid kid ^ " to") | nexps -> @@ -2896,7 +2891,7 @@ and bind_typ_pat_arg env (TP_aux (typ_pat_aux, l) as typ_pat) (Typ_arg_aux (typ_ match typ_pat_aux, typ_arg_aux with | TP_wild, _ -> env | TP_var kid, Typ_arg_nexp nexp -> - Env.add_constraint (nc_eq (nvar kid) nexp) (Env.add_typ_var l kid BK_int env) + Env.add_constraint (nc_eq (nvar kid) nexp) (Env.add_typ_var l kid K_int env) | _, Typ_arg_typ typ -> bind_typ_pat env typ_pat typ | _, Typ_arg_order _ -> typ_error l "Cannot bind type pattern against order" | _, _ -> typ_error l ("Couldn't bind type argument " ^ string_of_typ_arg typ_arg ^ " with " ^ string_of_typ_pat typ_pat) @@ -3238,7 +3233,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = match destruct_numeric env (typ_of inferred_f), destruct_numeric env (typ_of inferred_t) with | Some (kids1, nc1, nexp1), Some (kids2, nc2, nexp2) -> let loop_kid = mk_kid ("loop_" ^ string_of_id v) in - let env = List.fold_left (fun env kid -> Env.add_typ_var l kid BK_int env) env (loop_kid :: kids1 @ kids2) in + let env = List.fold_left (fun env kid -> Env.add_typ_var l kid K_int env) env (loop_kid :: kids1 @ kids2) in let env = Env.add_constraint (nc_and nc1 nc2) env in let env = Env.add_constraint (nc_and (nc_lteq nexp1 (nvar loop_kid)) (nc_lteq (nvar loop_kid) nexp2)) env in let loop_vtyp = atom_typ (nvar loop_kid) in @@ -3392,7 +3387,7 @@ and infer_funapp' l env f (typq, f_typ) xs ret_ctx_typ = | [], None -> env | _, Some enc -> let enc = List.fold_left (fun nc kid -> nc_subst_nexp kid (Nexp_var (prepend_kid ex_tag kid)) nc) enc ex_kids in - let env = List.fold_left (fun env kid -> Env.add_typ_var l (prepend_kid ex_tag kid) BK_int env) env ex_kids in + let env = List.fold_left (fun env kid -> Env.add_typ_var l (prepend_kid ex_tag kid) K_int env) env ex_kids in Env.add_constraint enc env | _, None -> assert false (* Cannot have ex_kids without ex_nc *) in @@ -3428,7 +3423,7 @@ and infer_funapp' l env f (typq, f_typ) xs ret_ctx_typ = typ_debug (lazy (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers))); if ex_kids = [] then () else (typ_debug (lazy ("EX GOAL: " ^ string_of_option string_of_n_constraint ex_nc)); ex_goal := ex_nc); record_unifiers unifiers; - let env = List.fold_left (fun env kid -> Env.add_typ_var l kid BK_int env) env ex_kids in + let env = List.fold_left (fun env kid -> Env.add_typ_var l kid K_int env) env ex_kids in let typs' = List.map (subst_unifiers unifiers) typs in let quants' = List.fold_left (fun qs (kid, uvar) -> instantiate_quants qs kid uvar) quants (KBindings.bindings unifiers) in let ret_typ' = @@ -4385,12 +4380,11 @@ let kinded_id_arg kind_id = let typ_arg arg = Typ_arg_aux (arg, Parse_ast.Unknown) in match kind_id with | KOpt_aux (KOpt_none kid, _) -> typ_arg (Typ_arg_nexp (nvar kid)) - | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_int, _)], _), kid), _) -> typ_arg (Typ_arg_nexp (nvar kid)) - | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_order, _)], _), kid), _) -> + | KOpt_aux (KOpt_kind (K_aux (K_int, _), kid), _) -> typ_arg (Typ_arg_nexp (nvar kid)) + | KOpt_aux (KOpt_kind (K_aux (K_order, _), kid), _) -> typ_arg (Typ_arg_order (Ord_aux (Ord_var kid, Parse_ast.Unknown))) - | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_type, _)], _), kid), _) -> + | KOpt_aux (KOpt_kind (K_aux (K_type, _), kid), _) -> typ_arg (Typ_arg_typ (mk_typ (Typ_var kid))) - | KOpt_aux (KOpt_kind (K_aux (K_kind kinds, _), kid), l) -> typ_error l "Badly formed kind" let fold_union_quant quants (QI_aux (qi, l)) = match qi with @@ -4401,7 +4395,7 @@ let check_type_union env variant typq (Tu_aux (tu, l)) = let ret_typ = app_typ variant (List.fold_left fold_union_quant [] (quant_items typq)) in match tu with | Tu_ty_id (Typ_aux (Typ_fn (arg_typ, ret_typ, _), _) as typ, v) -> - let typq = mk_typquant (List.map (mk_qi_id BK_type) (KidSet.elements (typ_frees typ))) in + let typq = mk_typquant (List.map (mk_qi_id K_type) (KidSet.elements (typ_frees typ))) in env |> Env.add_union_id v (typq, typ) |> Env.add_val_spec v (typq, typ) @@ -4441,7 +4435,7 @@ let mk_synonym typq typ = let check_kinddef env (KD_aux (kdef, (l, _))) = let kd_err () = raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented kind def") in match kdef with - | KD_nabbrev ((K_aux(K_kind([BK_aux (BK_int, _)]),_) as kind), id, nmscm, nexp) -> + | KD_nabbrev (K_aux (K_int, _) as kind, id, nmscm, nexp) -> [DEF_kind (KD_aux (KD_nabbrev (kind, id, nmscm, nexp), (l, None)))], Env.add_num_def id nexp env | _ -> kd_err () diff --git a/src/type_check.mli b/src/type_check.mli index 1081af08..f08272de 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -127,13 +127,13 @@ module Env : sig val add_constraint : n_constraint -> t -> t - val get_typ_var : kid -> t -> base_kind_aux + val get_typ_var : kid -> t -> kind_aux - val get_typ_vars : t -> base_kind_aux KBindings.t + val get_typ_vars : t -> kind_aux KBindings.t val get_typ_var_locs : t -> Ast.l KBindings.t - val add_typ_var : Ast.l -> kid -> base_kind_aux -> t -> t + val add_typ_var : Ast.l -> kid -> kind_aux -> t -> t val is_record : id -> t -> bool -- cgit v1.2.3 From df3ea2e6da387ead7cba1e27632768e563696502 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Tue, 4 Dec 2018 14:53:23 +0000 Subject: Remove FES_Fexps constructor This makes dealing with records and field expressions in Sail much nicer because the constructors are no longer stacked together like matryoshka dolls with unnecessary layers. Previously to get the fields of a record it would be either E_aux (E_record (FES_aux (FES_Fexps (fexps, _), _)), _) but now it is simply: E_aux (E_record fexps, _) --- src/anf.ml | 4 ++-- src/ast_util.ml | 25 ++++++++--------------- src/ast_util.mli | 1 - src/constant_fold.ml | 4 ++-- src/initial_check.ml | 8 ++++---- src/interpreter.ml | 10 ++++----- src/monomorphise.ml | 22 ++++++++------------ src/ocaml_backend.ml | 4 ++-- src/pretty_print_coq.ml | 4 ++-- src/pretty_print_lem.ml | 4 ++-- src/pretty_print_sail.ml | 2 +- src/rewriter.ml | 53 +++++++++++++++++++----------------------------- src/rewriter.mli | 28 +++++++++++-------------- src/rewrites.ml | 25 ++++++++--------------- src/spec_analysis.ml | 4 ++-- src/type_check.ml | 20 +++++++++--------- 16 files changed, 91 insertions(+), 127 deletions(-) (limited to 'src') diff --git a/src/anf.ml b/src/anf.ml index 1f93e00f..915ab738 100644 --- a/src/anf.ml +++ b/src/anf.ml @@ -569,7 +569,7 @@ let rec anf (E_aux (e_aux, ((l, _) as exp_annot)) as exp) = let aval, wrap = to_aval (anf field_exp) in wrap (mk_aexp (AE_field (aval, id, typ_of exp))) - | E_record_update (exp, FES_aux (FES_Fexps (fexps, _), _)) -> + | E_record_update (exp, fexps) -> let anf_fexp (FE_aux (FE_Fexp (id, exp), _)) = let aval, wrap = to_aval (anf exp) in (id, aval), wrap @@ -679,7 +679,7 @@ let rec anf (E_aux (e_aux, ((l, _) as exp_annot)) as exp) = let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd avals) in wrap (mk_aexp (AE_val (AV_tuple (List.map fst avals)))) - | E_record (FES_aux (FES_Fexps (fexps, _), _)) -> + | E_record fexps -> let anf_fexp (FE_aux (FE_Fexp (id, exp), _)) = let aval, wrap = to_aval (anf exp) in (id, aval), wrap diff --git a/src/ast_util.ml b/src/ast_util.ml index ffe4c90e..48750ab7 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -393,7 +393,6 @@ let mk_typschm typq typ = TypSchm_aux (TypSchm_ts (typq, typ), Parse_ast.Unknown let mk_typquant qis = TypQ_aux (TypQ_tq qis, Parse_ast.Unknown) let mk_fexp id exp = FE_aux (FE_Fexp (id, exp), no_annot) -let mk_fexps fexps = FES_aux (FES_Fexps (fexps, false), no_annot) let mk_effect effs = Effect_aux (Effect_set (List.map (fun be_aux -> BE_aux (be_aux, Parse_ast.Unknown)) effs), Parse_ast.Unknown) @@ -461,8 +460,8 @@ and map_exp_annot_aux f = function | E_vector_append (exp1, exp2) -> E_vector_append (map_exp_annot f exp1, map_exp_annot f exp2) | E_list xs -> E_list (List.map (map_exp_annot f) xs) | E_cons (exp1, exp2) -> E_cons (map_exp_annot f exp1, map_exp_annot f exp2) - | E_record fexps -> E_record (map_fexps_annot f fexps) - | E_record_update (exp, fexps) -> E_record_update (map_exp_annot f exp, map_fexps_annot f fexps) + | E_record fexps -> E_record (List.map (map_fexp_annot f) fexps) + | E_record_update (exp, fexps) -> E_record_update (map_exp_annot f exp, List.map (map_fexp_annot f) fexps) | E_field (exp, id) -> E_field (map_exp_annot f exp, id) | E_case (exp, cases) -> E_case (map_exp_annot f exp, List.map (map_pexp_annot f) cases) | E_try (exp, cases) -> E_try (map_exp_annot f exp, List.map (map_pexp_annot f) cases) @@ -482,7 +481,6 @@ and map_opt_default_annot f (Def_val_aux (df, annot)) = Def_val_aux (map_opt_def and map_opt_default_annot_aux f = function | Def_val_empty -> Def_val_empty | Def_val_dec exp -> Def_val_dec (map_exp_annot f exp) -and map_fexps_annot f (FES_aux (FES_Fexps (fexps, b), annot)) = FES_aux (FES_Fexps (List.map (map_fexp_annot f) fexps, b), f annot) and map_fexp_annot f (FE_aux (FE_Fexp (id, exp), annot)) = FE_aux (FE_Fexp (id, map_exp_annot f exp), f annot) and map_pexp_annot f (Pat_aux (pexp, annot)) = Pat_aux (map_pexp_annot_aux f pexp, f annot) and map_pexp_annot_aux f = function @@ -770,9 +768,9 @@ let rec string_of_exp (E_aux (exp, _)) = | E_throw exp -> "throw " ^ string_of_exp exp | E_cons (x, xs) -> string_of_exp x ^ " :: " ^ string_of_exp xs | E_list xs -> "[|" ^ string_of_list ", " string_of_exp xs ^ "|]" - | E_record_update (exp, FES_aux (FES_Fexps (fexps, _), _)) -> + | E_record_update (exp, fexps) -> "{ " ^ string_of_exp exp ^ " with " ^ string_of_list "; " string_of_fexp fexps ^ " }" - | E_record (FES_aux (FES_Fexps (fexps, _), _)) -> + | E_record fexps -> "{ " ^ string_of_list "; " string_of_fexp fexps ^ " }" | E_var (lexp, binding, exp) -> "var " ^ string_of_lexp lexp ^ " = " ^ string_of_exp binding ^ " in " ^ string_of_exp exp | E_internal_return exp -> "internal_return (" ^ string_of_exp exp ^ ")" @@ -1290,8 +1288,8 @@ let rec subst id value (E_aux (e_aux, annot) as exp) = | E_list exps -> E_list (List.map (subst id value) exps) | E_cons (exp1, exp2) -> E_cons (subst id value exp1, subst id value exp2) - | E_record fexps -> E_record (subst_fexps id value fexps) - | E_record_update (exp, fexps) -> E_record_update (subst id value exp, subst_fexps id value fexps) + | E_record fexps -> E_record (List.map (subst_fexp id value) fexps) + | E_record_update (exp, fexps) -> E_record_update (subst id value exp, List.map (subst_fexp id value) fexps) | E_field (exp, id') -> E_field (subst id value exp, id') | E_case (exp, pexps) -> @@ -1336,10 +1334,6 @@ and subst_pexp id value (Pat_aux (pexp_aux, annot)) = in Pat_aux (pexp_aux, annot) - -and subst_fexps id value (FES_aux (FES_Fexps (fexps, flag), annot)) = - FES_aux (FES_Fexps (List.map (subst_fexp id value) fexps, flag), annot) - and subst_fexp id value (FE_aux (FE_Fexp (id', exp), annot)) = FE_aux (FE_Fexp (id', subst id value exp), annot) @@ -1493,8 +1487,8 @@ let rec locate : 'a. (l -> l) -> 'a exp -> 'a exp = fun f (E_aux (e_aux, (l, ann E_vector_append (locate f exp1, locate f exp2) | E_list exps -> E_list (List.map (locate f) exps) | E_cons (exp1, exp2) -> E_cons (locate f exp1, locate f exp2) - | E_record fexps -> E_record (locate_fexps f fexps) - | E_record_update (exp, fexps) -> E_record_update (locate f exp, locate_fexps f fexps) + | E_record fexps -> E_record (List.map (locate_fexp f) fexps) + | E_record_update (exp, fexps) -> E_record_update (locate f exp, List.map (locate_fexp f) fexps) | E_field (exp, id) -> E_field (locate f exp, locate_id f id) | E_case (exp, cases) -> E_case (locate f exp, List.map (locate_pexp f) cases) | E_let (letbind, exp) -> E_let (locate_letbind f letbind, locate f exp) @@ -1538,9 +1532,6 @@ and locate_lexp : 'a. (l -> l) -> 'a lexp -> 'a lexp = fun f (LEXP_aux (lexp_aux in LEXP_aux (lexp_aux, (f l, annot)) -and locate_fexps : 'a. (l -> l) -> 'a fexps -> 'a fexps = fun f (FES_aux (FES_Fexps (fexps, semi), (l, annot))) -> - FES_aux (FES_Fexps (List.map (locate_fexp f) fexps, semi), (f l, annot)) - and locate_fexp : 'a. (l -> l) -> 'a fexp -> 'a fexp = fun f (FE_aux (FE_Fexp (id, exp), (l, annot))) -> FE_aux (FE_Fexp (locate_id f id, locate f exp), (f l, annot)) diff --git a/src/ast_util.mli b/src/ast_util.mli index b7979e88..b6bce7c5 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -89,7 +89,6 @@ val mk_qi_id : kind_aux -> kid -> quant_item val mk_qi_nc : n_constraint -> quant_item val mk_qi_kopt : kinded_id -> quant_item val mk_fexp : id -> unit exp -> unit fexp -val mk_fexps : (unit fexp) list -> unit fexps val mk_letbind : unit pat -> unit exp -> unit letbind val unaux_exp : 'a exp -> 'a exp_aux diff --git a/src/constant_fold.ml b/src/constant_fold.ml index 0e34ed5b..b86f4ea5 100644 --- a/src/constant_fold.ml +++ b/src/constant_fold.ml @@ -72,7 +72,7 @@ and exp_of_value = | V_bool false -> mk_lit_exp L_false | V_string str -> mk_lit_exp (L_string str) | V_record ctors -> - mk_exp (E_record (FES_aux (FES_Fexps (List.map fexp_of_ctor (StringMap.bindings ctors), false), no_annot))) + mk_exp (E_record (List.map fexp_of_ctor (StringMap.bindings ctors))) | V_vector vs -> mk_exp (E_vector (List.map exp_of_value vs)) | V_tuple vs -> @@ -110,7 +110,7 @@ let rec is_constant (E_aux (e_aux, _)) = match e_aux with | E_lit _ -> true | E_vector exps -> List.for_all is_constant exps - | E_record (FES_aux (FES_Fexps (fexps, _), _)) -> List.for_all is_constant_fexp fexps + | E_record fexps -> List.for_all is_constant_fexp fexps | E_cast (_, exp) -> is_constant exp | E_tuple exps -> List.for_all is_constant exps | _ -> false diff --git a/src/initial_check.ml b/src/initial_check.ml index d1efb374..aa3a7136 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -595,14 +595,14 @@ and to_ast_case (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.Pat_aux(pex | Parse_ast.Pat_when(pat,guard,exp) -> Pat_aux (Pat_when (to_ast_pat k_env def_ord pat, to_ast_exp k_env def_ord guard, to_ast_exp k_env def_ord exp), (l, ())) -and to_ast_fexps (fail_on_error:bool) (k_env:kind Envmap.t) (def_ord:order) (exps : Parse_ast.exp list) : unit fexps option = +and to_ast_fexps (fail_on_error:bool) (k_env:kind Envmap.t) (def_ord:order) (exps : Parse_ast.exp list) : unit fexp list option = match exps with - | [] -> Some(FES_aux(FES_Fexps([],false), (Parse_ast.Unknown,()))) + | [] -> Some [] | fexp::exps -> let maybe_fexp,maybe_error = to_ast_record_try k_env def_ord fexp in (match maybe_fexp,maybe_error with | Some(fexp),None -> (match (to_ast_fexps fail_on_error k_env def_ord exps) with - | Some(FES_aux(FES_Fexps(fexps,_),l)) -> Some(FES_aux(FES_Fexps(fexp::fexps,false),l)) + | Some(fexps) -> Some(fexp::fexps) | _ -> None) | None,Some(l,msg) -> if fail_on_error @@ -1138,7 +1138,7 @@ let generate_undefineds vs_ids (Defs defs) = [mk_val_spec (VS_val_spec (undefined_typschm id typq, prepend_id "undefined_" id, (fun _ -> None), false)); mk_fundef [mk_funcl (prepend_id "undefined_" id) pat - (mk_exp (E_record (mk_fexps (List.map (fun (_, id) -> mk_fexp id (mk_lit_exp L_undef)) fields))))]] + (mk_exp (E_record (List.map (fun (_, id) -> mk_fexp id (mk_lit_exp L_undef)) fields)))]] | TD_variant (id, _, typq, tus, _) when not (IdSet.mem (prepend_id "undefined_" id) vs_ids) -> let pat = p_tup (quant_items typq |> List.map quant_item_param |> List.concat |> List.map (fun id -> mk_pat (P_id id))) in let body = diff --git a/src/interpreter.ml b/src/interpreter.ml index 03877600..194812ca 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -401,13 +401,13 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = | _ -> failwith ("Couldn't find id " ^ string_of_id id) end - | E_record (FES_aux (FES_Fexps (fexps, flag), fes_annot)) -> + | E_record fexps -> let evaluated, unevaluated = Util.take_drop is_value_fexp fexps in begin match unevaluated with | FE_aux (FE_Fexp (id, exp), fe_annot) :: fexps -> step exp >>= fun exp' -> - wrap (E_record (FES_aux (FES_Fexps (evaluated @ FE_aux (FE_Fexp (id, exp'), fe_annot) :: fexps, flag), fes_annot))) + wrap (E_record (evaluated @ FE_aux (FE_Fexp (id, exp'), fe_annot) :: fexps)) | [] -> List.map value_of_fexp fexps |> List.fold_left (fun record (field, v) -> StringMap.add field v record) StringMap.empty @@ -418,13 +418,13 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = | E_record_update (exp, fexps) when not (is_value exp) -> step exp >>= fun exp' -> wrap (E_record_update (exp', fexps)) - | E_record_update (record, FES_aux (FES_Fexps (fexps, flag), fes_annot)) -> + | E_record_update (record, fexps) -> let evaluated, unevaluated = Util.take_drop is_value_fexp fexps in begin match unevaluated with | FE_aux (FE_Fexp (id, exp), fe_annot) :: fexps -> step exp >>= fun exp' -> - wrap (E_record_update (record, FES_aux (FES_Fexps (evaluated @ FE_aux (FE_Fexp (id, exp'), fe_annot) :: fexps, flag), fes_annot))) + wrap (E_record_update (record, evaluated @ FE_aux (FE_Fexp (id, exp'), fe_annot) :: fexps)) | [] -> List.map value_of_fexp fexps |> List.fold_left (fun record (field, v) -> StringMap.add field v record) (coerce_record (value_of_exp record)) @@ -444,7 +444,7 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = | E_assign (LEXP_aux (LEXP_field (lexp, id), ul), exp) -> let open Type_check in let lexp_exp = infer_exp (env_of_annot annot) (exp_of_lexp (strip_lexp lexp)) in - let exp' = E_aux (E_record_update (lexp_exp, FES_aux (FES_Fexps ([FE_aux (FE_Fexp (id, exp), ul)], false), ul)), ul) in + let exp' = E_aux (E_record_update (lexp_exp, [FE_aux (FE_Fexp (id, exp), ul)]), ul) in wrap (E_assign (lexp, exp')) | E_assign (LEXP_aux (LEXP_vector (vec, n), lexp_annot), exp) -> let open Type_check in diff --git a/src/monomorphise.ml b/src/monomorphise.ml index 6a262df6..7626971e 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -615,8 +615,8 @@ let nexp_subst_fns substs = | E_vector_append (e1,e2) -> re (E_vector_append (s_exp e1,s_exp e2)) | E_list es -> re (E_list (List.map s_exp es)) | E_cons (e1,e2) -> re (E_cons (s_exp e1,s_exp e2)) - | E_record fes -> re (E_record (s_fexps fes)) - | E_record_update (e,fes) -> re (E_record_update (s_exp e, s_fexps fes)) + | E_record fes -> re (E_record (List.map s_fexp fes)) + | E_record_update (e,fes) -> re (E_record_update (s_exp e, List.map s_fexp fes)) | E_field (e,id) -> re (E_field (s_exp e,id)) | E_case (e,cases) -> re (E_case (s_exp e, List.map s_pexp cases)) | E_let (lb,e) -> re (E_let (s_letbind lb, s_exp e)) @@ -629,8 +629,6 @@ let nexp_subst_fns substs = | E_internal_return e -> re (E_internal_return (s_exp e)) | E_throw e -> re (E_throw (s_exp e)) | E_try (e,cases) -> re (E_try (s_exp e, List.map s_pexp cases)) - and s_fexps (FES_aux (FES_Fexps (fes,flag), (l,annot))) = - FES_aux (FES_Fexps (List.map s_fexp fes, flag), (l,s_tannot annot)) and s_fexp (FE_aux (FE_Fexp (id,e), (l,annot))) = FE_aux (FE_Fexp (id,s_exp e),(l,s_tannot annot)) and s_pexp = function @@ -954,7 +952,7 @@ let referenced_vars exp = { (compute_exp_alg IdSet.empty IdSet.union) with e_ref = (fun id -> IdSet.singleton id, E_ref id) } exp) -let assigned_vars_in_fexps (FES_aux (FES_Fexps (fes,_), _)) = +let assigned_vars_in_fexps fes = List.fold_left (fun vs (FE_aux (FE_Fexp (_,e),_)) -> IdSet.union vs (assigned_vars e)) IdSet.empty @@ -1460,8 +1458,8 @@ let split_defs all_errors splits defs = | E_internal_value _ -> raise (Reporting.err_unreachable l __POS__ ("Unexpected expression encountered in monomorphisation: " ^ string_of_exp exp)) - and const_prop_fexps ref_vars substs assigns (FES_aux (FES_Fexps (fes,flag), annot)) = - FES_aux (FES_Fexps (List.map (const_prop_fexp ref_vars substs assigns) fes, flag), annot) + and const_prop_fexps ref_vars substs assigns fes = + List.map (const_prop_fexp ref_vars substs assigns) fes and const_prop_fexp ref_vars substs assigns (FE_aux (FE_Fexp (id,e), annot)) = FE_aux (FE_Fexp (id,fst (const_prop_exp ref_vars substs assigns e)),annot) and const_prop_pexp ref_vars substs assigns = function @@ -1995,8 +1993,8 @@ let split_defs all_errors splits defs = | E_vector_append (e1,e2) -> re (E_vector_append (map_exp e1,map_exp e2)) | E_list es -> re (E_list (List.map map_exp es)) | E_cons (e1,e2) -> re (E_cons (map_exp e1,map_exp e2)) - | E_record fes -> re (E_record (map_fexps fes)) - | E_record_update (e,fes) -> re (E_record_update (map_exp e, map_fexps fes)) + | E_record fes -> re (E_record (List.map map_fexp fes)) + | E_record_update (e,fes) -> re (E_record_update (map_exp e, List.map map_fexp fes)) | E_field (e,id) -> re (E_field (map_exp e,id)) | E_case (e,cases) -> re (E_case (map_exp e, List.concat (List.map map_pexp cases))) | E_let (lb,e) -> re (E_let (map_letbind lb, map_exp e)) @@ -2009,8 +2007,6 @@ let split_defs all_errors splits defs = | E_var (le,e1,e2) -> re (E_var (map_lexp le, map_exp e1, map_exp e2)) | E_internal_plet (p,e1,e2) -> re (E_internal_plet (check_single_pat p, map_exp e1, map_exp e2)) | E_internal_return e -> re (E_internal_return (map_exp e)) - and map_fexps (FES_aux (FES_Fexps (fes,flag), annot)) = - FES_aux (FES_Fexps (List.map map_fexp fes, flag), annot) and map_fexp (FE_aux (FE_Fexp (id,e), annot)) = FE_aux (FE_Fexp (id,map_exp e),annot) and map_pexp = function @@ -3087,11 +3083,11 @@ let rec analyse_exp fn_id env assigns (E_aux (e,(l,annot)) as exp) = | E_vector_update_subrange (e1,e2,e3,e4) -> let ds, assigns, r = non_det [e1;e2;e3;e4] in (merge_deps ds, assigns, r) - | E_record (FES_aux (FES_Fexps (fexps,_),_)) -> + | E_record fexps -> let es = List.map (function (FE_aux (FE_Fexp (_,e),_)) -> e) fexps in let ds, assigns, r = non_det es in (merge_deps ds, assigns, r) - | E_record_update (e,FES_aux (FES_Fexps (fexps,_),_)) -> + | E_record_update (e,fexps) -> let es = List.map (function (FE_aux (FE_Fexp (_,e),_)) -> e) fexps in let ds, assigns, r = non_det (e::es) in (merge_deps ds, assigns, r) diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index cf681ae5..f3a3fa54 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -242,9 +242,9 @@ let rec ocaml_exp ctx (E_aux (exp_aux, _) as exp) = | E_if (c, t, e) -> separate space [string "if"; ocaml_atomic_exp ctx c; string "then"; ocaml_atomic_exp ctx t; string "else"; ocaml_atomic_exp ctx e] - | E_record (FES_aux (FES_Fexps (fexps, _), _)) -> + | E_record fexps -> enclose lbrace rbrace (group (separate_map (semi ^^ break 1) (ocaml_fexp ctx) fexps)) - | E_record_update (exp, FES_aux (FES_Fexps (fexps, _), _)) -> + | E_record_update (exp, fexps) -> enclose lbrace rbrace (separate space [ocaml_atomic_exp ctx exp; string "with"; separate_map (semi ^^ space) (ocaml_fexp ctx) fexps]) diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 4b466326..7cc61507 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -1370,7 +1370,7 @@ let doc_exp, doc_let = if aexp_needed then parens epp else epp | E_tuple exps -> parens (align (group (separate_map (comma ^^ break 1) expN exps))) - | E_record(FES_aux(FES_Fexps(fexps,_),_)) -> + | E_record fexps -> let recordtyp = match destruct_tannot annot with | Some (env, Typ_aux (Typ_id tid,_), _) | Some (env, Typ_aux (Typ_app (tid, _), _), _) -> @@ -1381,7 +1381,7 @@ let doc_exp, doc_let = (semi_sp ^^ break 1) (doc_fexp ctxt recordtyp) fexps)) in if aexp_needed then parens epp else epp - | E_record_update(e,(FES_aux(FES_Fexps(fexps,_),_))) -> + | E_record_update(e, fexps) -> let recordtyp, env = match destruct_tannot annot with | Some (env, Typ_aux (Typ_id tid,_), _) | Some (env, Typ_aux (Typ_app (tid, _), _), _) diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index 53b703bf..be790a1c 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -825,7 +825,7 @@ let doc_exp_lem, doc_let_lem = | E_cast(typ,e) -> expV aexp_needed e | E_tuple exps -> parens (align (group (separate_map (comma ^^ break 1) expN exps))) - | E_record(FES_aux(FES_Fexps(fexps,_),_)) -> + | E_record fexps -> let recordtyp = match destruct_tannot annot with | Some (env, Typ_aux (Typ_id tid,_), _) | Some (env, Typ_aux (Typ_app (tid, _), _), _) -> @@ -835,7 +835,7 @@ let doc_exp_lem, doc_let_lem = wrap_parens (anglebars (space ^^ (align (separate_map (semi_sp ^^ break 1) (doc_fexp ctxt recordtyp) fexps)) ^^ space)) - | E_record_update(e,(FES_aux(FES_Fexps(fexps,_),_))) -> + | E_record_update(e, fexps) -> let recordtyp = match destruct_tannot annot with | Some (env, Typ_aux (Typ_id tid,_), _) | Some (env, Typ_aux (Typ_app (tid, _), _), _) diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index fe533f00..b1efd11d 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -453,7 +453,7 @@ and doc_atomic_exp (E_aux (e_aux, _) as exp) = brackets (separate space [doc_exp exp1; string "with"; doc_atomic_exp exp2; string ".."; doc_atomic_exp exp3; equals; doc_exp exp4]) | E_internal_value v -> string (Value.string_of_value v |> Util.green |> Util.clear) | _ -> parens (doc_exp exp) -and doc_fexps (FES_aux (FES_Fexps (fexps, _), _)) = +and doc_fexps fexps = separate_map (comma ^^ space) doc_fexp fexps and doc_fexp (FE_aux (FE_Fexp (id, exp), _)) = separate space [doc_id id; equals; doc_exp exp] diff --git a/src/rewriter.ml b/src/rewriter.ml index 082d9850..77070025 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -64,11 +64,10 @@ type 'a rewriters = { rewrite_defs : 'a rewriters -> 'a defs -> 'a defs; } - let effect_of_fpat (FP_aux (_,(_,a))) = effect_of_annot a let effect_of_lexp (LEXP_aux (_,(_,a))) = effect_of_annot a let effect_of_fexp (FE_aux (_,(_,a))) = effect_of_annot a -let effect_of_fexps (FES_aux (FES_Fexps (fexps,_),_)) = +let effect_of_fexps fexps = List.fold_left union_effects no_effect (List.map effect_of_fexp fexps) let effect_of_opt_default (Def_val_aux (_,(_,a))) = effect_of_annot a (* The typechecker does not seem to annotate pexps themselves *) @@ -295,16 +294,14 @@ let rewrite_exp rewriters (E_aux (exp,(l,annot)) as orig_exp) = | E_vector_append (v1,v2) -> rewrap (E_vector_append (rewrite v1,rewrite v2)) | E_list exps -> rewrap (E_list (List.map rewrite exps)) | E_cons(h,t) -> rewrap (E_cons (rewrite h,rewrite t)) - | E_record (FES_aux (FES_Fexps(fexps, bool),fannot)) -> + | E_record fexps -> rewrap (E_record - (FES_aux (FES_Fexps - (List.map (fun (FE_aux(FE_Fexp(id,e),fannot)) -> - FE_aux(FE_Fexp(id,rewrite e),fannot)) fexps, bool), fannot))) - | E_record_update (re,(FES_aux (FES_Fexps(fexps, bool),fannot))) -> + (List.map (fun (FE_aux(FE_Fexp(id,e),fannot)) -> + FE_aux(FE_Fexp(id,rewrite e),fannot)) fexps)) + | E_record_update (re, fexps) -> rewrap (E_record_update ((rewrite re), - (FES_aux (FES_Fexps - (List.map (fun (FE_aux(FE_Fexp(id,e),fannot)) -> - FE_aux(FE_Fexp(id,rewrite e),fannot)) fexps, bool), fannot)))) + (List.map (fun (FE_aux(FE_Fexp(id,e),fannot)) -> + FE_aux(FE_Fexp(id,rewrite e),fannot)) fexps))) | E_field(exp,id) -> rewrap (E_field(rewrite exp,id)) | E_case (exp,pexps) -> rewrap (E_case (rewrite exp, List.map (rewrite_pexp rewriters) pexps)) @@ -475,9 +472,9 @@ let id_pat_alg : ('a,'a pat, 'a pat_aux, 'a fpat, 'a fpat_aux) pat_alg = ; fP_Fpat = (fun (id,pat) -> FP_Fpat (id,pat)) } -type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, +type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux, 'opt_default_aux,'opt_default,'pexp,'pexp_aux,'letbind_aux,'letbind, - 'pat,'pat_aux,'fpat,'fpat_aux) exp_alg = + 'pat,'pat_aux,'fpat,'fpat_aux) exp_alg = { e_block : 'exp list -> 'exp_aux ; e_nondet : 'exp list -> 'exp_aux ; e_id : id -> 'exp_aux @@ -498,8 +495,8 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, ; e_vector_append : 'exp * 'exp -> 'exp_aux ; e_list : 'exp list -> 'exp_aux ; e_cons : 'exp * 'exp -> 'exp_aux - ; e_record : 'fexps -> 'exp_aux - ; e_record_update : 'exp * 'fexps -> 'exp_aux + ; e_record : 'fexp list -> 'exp_aux + ; e_record_update : 'exp * 'fexp list -> 'exp_aux ; e_field : 'exp * id -> 'exp_aux ; e_case : 'exp * 'pexp list -> 'exp_aux ; e_try : 'exp * 'pexp list -> 'exp_aux @@ -528,8 +525,6 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, ; lEXP_aux : 'lexp_aux * 'a annot -> 'lexp ; fE_Fexp : id * 'exp -> 'fexp_aux ; fE_aux : 'fexp_aux * 'a annot -> 'fexp - ; fES_Fexps : 'fexp list * bool -> 'fexps_aux - ; fES_aux : 'fexps_aux * 'a annot -> 'fexps ; def_val_empty : 'opt_default_aux ; def_val_dec : 'exp -> 'opt_default_aux ; def_val_aux : 'opt_default_aux * 'a annot -> 'opt_default @@ -567,8 +562,8 @@ let rec fold_exp_aux alg = function | E_vector_append (e1,e2) -> alg.e_vector_append (fold_exp alg e1, fold_exp alg e2) | E_list es -> alg.e_list (List.map (fold_exp alg) es) | E_cons (e1,e2) -> alg.e_cons (fold_exp alg e1, fold_exp alg e2) - | E_record fexps -> alg.e_record (fold_fexps alg fexps) - | E_record_update (e,fexps) -> alg.e_record_update (fold_exp alg e, fold_fexps alg fexps) + | E_record fexps -> alg.e_record (List.map (fold_fexp alg) fexps) + | E_record_update (e,fexps) -> alg.e_record_update (fold_exp alg e, List.map (fold_fexp alg) fexps) | E_field (e,id) -> alg.e_field (fold_exp alg e, id) | E_case (e,pexps) -> alg.e_case (fold_exp alg e, List.map (fold_pexp alg) pexps) | E_try (e,pexps) -> alg.e_try (fold_exp alg e, List.map (fold_pexp alg) pexps) @@ -602,8 +597,6 @@ and fold_lexp alg (LEXP_aux (lexp_aux,annot)) = alg.lEXP_aux (fold_lexp_aux alg lexp_aux, annot) and fold_fexp_aux alg (FE_Fexp (id,e)) = alg.fE_Fexp (id, fold_exp alg e) and fold_fexp alg (FE_aux (fexp_aux,annot)) = alg.fE_aux (fold_fexp_aux alg fexp_aux,annot) -and fold_fexps_aux alg (FES_Fexps (fexps,b)) = alg.fES_Fexps (List.map (fold_fexp alg) fexps, b) -and fold_fexps alg (FES_aux (fexps_aux,annot)) = alg.fES_aux (fold_fexps_aux alg fexps_aux, annot) and fold_opt_default_aux alg = function | Def_val_empty -> alg.def_val_empty | Def_val_dec e -> alg.def_val_dec (fold_exp alg e) @@ -674,8 +667,6 @@ let id_exp_alg = ; lEXP_aux = (fun (lexp,annot) -> LEXP_aux (lexp,annot)) ; fE_Fexp = (fun (id,e) -> FE_Fexp (id,e)) ; fE_aux = (fun (fexp,annot) -> FE_aux (fexp,annot)) - ; fES_Fexps = (fun (fexps,b) -> FES_Fexps (fexps,b)) - ; fES_aux = (fun (fexp,annot) -> FES_aux (fexp,annot)) ; def_val_empty = Def_val_empty ; def_val_dec = (fun e -> Def_val_dec e) ; def_val_aux = (fun (defval,aux) -> Def_val_aux (defval,aux)) @@ -742,8 +733,12 @@ let compute_exp_alg bot join = ; e_vector_append = (fun ((v1,e1),(v2,e2)) -> (join v1 v2, E_vector_append (e1,e2))) ; e_list = split_join (fun es -> E_list es) ; e_cons = (fun ((v1,e1),(v2,e2)) -> (join v1 v2, E_cons (e1,e2))) - ; e_record = (fun (vs,fexps) -> (vs, E_record fexps)) - ; e_record_update = (fun ((v1,e1),(vf,fexp)) -> (join v1 vf, E_record_update (e1,fexp))) + ; e_record = (fun fexps -> + let vs, fexps = List.split fexps in + (join_list vs, E_record fexps)) + ; e_record_update = (fun ((v1,e1),fexps) -> + let (vps,fexps) = List.split fexps in + (join_list (v1::vps), E_record_update (e1,fexps))) ; e_field = (fun ((v1,e1),id) -> (v1, E_field (e1,id))) ; e_case = (fun ((v1,e1),pexps) -> let (vps,pexps) = List.split pexps in @@ -783,10 +778,6 @@ let compute_exp_alg bot join = ; lEXP_aux = (fun ((vl,lexp),annot) -> (vl, LEXP_aux (lexp,annot))) ; fE_Fexp = (fun (id,(v,e)) -> (v, FE_Fexp (id,e))) ; fE_aux = (fun ((vf,fexp),annot) -> (vf, FE_aux (fexp,annot))) - ; fES_Fexps = (fun (fexps,b) -> - let (vs,fexps) = List.split fexps in - (join_list vs, FES_Fexps (fexps,b))) - ; fES_aux = (fun ((vf,fexp),annot) -> (vf, FES_aux (fexp,annot))) ; def_val_empty = (bot, Def_val_empty) ; def_val_dec = (fun (v,e) -> (v, Def_val_dec e)) ; def_val_aux = (fun ((v,defval),aux) -> (v, Def_val_aux (defval,aux))) @@ -843,8 +834,8 @@ let pure_exp_alg bot join = ; e_vector_append = (fun (v1,v2) -> join v1 v2) ; e_list = join_list ; e_cons = (fun (v1,v2) -> join v1 v2) - ; e_record = (fun vs -> vs) - ; e_record_update = (fun (v1,vf) -> join v1 vf) + ; e_record = (fun vs -> join_list vs) + ; e_record_update = (fun (v1,vf) -> join_list (v1::vf)) ; e_field = (fun (v1,id) -> v1) ; e_case = (fun (v1,vps) -> join_list (v1::vps)) ; e_try = (fun (v1,vps) -> join_list (v1::vps)) @@ -873,8 +864,6 @@ let pure_exp_alg bot join = ; lEXP_aux = (fun (vl,annot) -> vl) ; fE_Fexp = (fun (id,v) -> v) ; fE_aux = (fun (vf,annot) -> vf) - ; fES_Fexps = (fun (vs,b) -> join_list vs) - ; fES_aux = (fun (vf,annot) -> vf) ; def_val_empty = bot ; def_val_dec = (fun v -> v) ; def_val_aux = (fun (v,aux) -> v) diff --git a/src/rewriter.mli b/src/rewriter.mli index 15e704df..9da94a99 100644 --- a/src/rewriter.mli +++ b/src/rewriter.mli @@ -107,7 +107,7 @@ type ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg = (* fold over pat_aux expressions *) (* the type of interpretations of expressions *) -type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, +type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux, 'opt_default_aux,'opt_default,'pexp,'pexp_aux,'letbind_aux,'letbind, 'pat,'pat_aux,'fpat,'fpat_aux) exp_alg = { e_block : 'exp list -> 'exp_aux @@ -130,8 +130,8 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, ; e_vector_append : 'exp * 'exp -> 'exp_aux ; e_list : 'exp list -> 'exp_aux ; e_cons : 'exp * 'exp -> 'exp_aux - ; e_record : 'fexps -> 'exp_aux - ; e_record_update : 'exp * 'fexps -> 'exp_aux + ; e_record : 'fexp list -> 'exp_aux + ; e_record_update : 'exp * 'fexp list -> 'exp_aux ; e_field : 'exp * id -> 'exp_aux ; e_case : 'exp * 'pexp list -> 'exp_aux ; e_try : 'exp * 'pexp list -> 'exp_aux @@ -160,8 +160,6 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, ; lEXP_aux : 'lexp_aux * 'a annot -> 'lexp ; fE_Fexp : id * 'exp -> 'fexp_aux ; fE_aux : 'fexp_aux * 'a annot -> 'fexp - ; fES_Fexps : 'fexp list * bool -> 'fexps_aux - ; fES_aux : 'fexps_aux * 'a annot -> 'fexps ; def_val_empty : 'opt_default_aux ; def_val_dec : 'exp -> 'opt_default_aux ; def_val_aux : 'opt_default_aux * 'a annot -> 'opt_default @@ -177,34 +175,34 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, val fold_pat : ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg -> 'a pat -> 'pat (* fold over expressions *) -val fold_exp : ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, +val fold_exp : ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux, 'opt_default_aux,'opt_default,'pexp,'pexp_aux,'letbind_aux,'letbind, 'pat,'pat_aux,'fpat,'fpat_aux) exp_alg -> 'a exp -> 'exp -val fold_letbind : ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, +val fold_letbind : ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux, 'opt_default_aux,'opt_default,'pexp,'pexp_aux,'letbind_aux,'letbind, 'pat,'pat_aux,'fpat,'fpat_aux) exp_alg -> 'a letbind -> 'letbind -val fold_pexp : ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, +val fold_pexp : ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux, 'opt_default_aux,'opt_default,'pexp,'pexp_aux,'letbind_aux,'letbind, 'pat,'pat_aux,'fpat,'fpat_aux) exp_alg -> 'a pexp -> 'pexp -val fold_pexp : ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, +val fold_pexp : ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux, 'opt_default_aux,'opt_default,'pexp,'pexp_aux,'letbind_aux,'letbind, 'pat,'pat_aux,'fpat,'fpat_aux) exp_alg -> 'a pexp -> 'pexp -val fold_funcl : ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, +val fold_funcl : ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux, 'opt_default_aux,'opt_default,'a pexp,'pexp_aux,'letbind_aux,'letbind, 'pat,'pat_aux,'fpat,'fpat_aux) exp_alg -> 'a funcl -> 'a funcl -val fold_function : ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, +val fold_function : ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux, 'opt_default_aux,'opt_default, 'a pexp,'pexp_aux,'letbind_aux,'letbind, 'pat,'pat_aux,'fpat,'fpat_aux) exp_alg -> 'a fundef -> 'a fundef val id_pat_alg : ('a,'a pat, 'a pat_aux, 'a fpat, 'a fpat_aux) pat_alg val id_exp_alg : ('a,'a exp,'a exp_aux,'a lexp,'a lexp_aux,'a fexp, - 'a fexp_aux,'a fexps,'a fexps_aux, + 'a fexp_aux, 'a opt_default_aux,'a opt_default,'a pexp,'a pexp_aux, 'a letbind_aux,'a letbind, 'a pat,'a pat_aux,'a fpat,'a fpat_aux) exp_alg @@ -214,7 +212,7 @@ val compute_pat_alg : 'b -> ('b -> 'b -> 'b) -> val compute_exp_alg : 'b -> ('b -> 'b -> 'b) -> ('a,('b * 'a exp),('b * 'a exp_aux),('b * 'a lexp),('b * 'a lexp_aux),('b * 'a fexp), - ('b * 'a fexp_aux),('b * 'a fexps),('b * 'a fexps_aux), + ('b * 'a fexp_aux), ('b * 'a opt_default_aux),('b * 'a opt_default),('b * 'a pexp),('b * 'a pexp_aux), ('b * 'a letbind_aux),('b * 'a letbind), ('b * 'a pat),('b * 'a pat_aux),('b * 'a fpat),('b * 'a fpat_aux)) exp_alg @@ -224,7 +222,7 @@ val pure_pat_alg : 'b -> ('b -> 'b -> 'b) -> ('a,'b,'b,'b,'b) pat_alg val pure_exp_alg : 'b -> ('b -> 'b -> 'b) -> ('a,'b,'b,'b,'b,'b, 'b,'b,'b, - 'b,'b,'b,'b, + 'b,'b, 'b,'b, 'b,'b,'b,'b) exp_alg @@ -248,6 +246,4 @@ val fix_eff_pexp : tannot pexp -> tannot pexp val fix_eff_fexp : tannot fexp -> tannot fexp -val fix_eff_fexps : tannot fexps -> tannot fexps - val fix_eff_opt_default : tannot opt_default -> tannot opt_default diff --git a/src/rewrites.ml b/src/rewrites.ml index 2734e91f..8c1311a0 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -513,8 +513,8 @@ let rewrite_sizeof (Defs defs) = ; e_vector_append = (fun ((e1,e1'),(e2,e2')) -> (E_vector_append (e1,e2), E_vector_append (e1',e2'))) ; e_list = (fun es -> let (es, es') = List.split es in (E_list es, E_list es')) ; e_cons = (fun ((e1,e1'),(e2,e2')) -> (E_cons (e1,e2), E_cons (e1',e2'))) - ; e_record = (fun (fexps, fexps') -> (E_record fexps, E_record fexps')) - ; e_record_update = (fun ((e1,e1'),(fexp,fexp')) -> (E_record_update (e1,fexp), E_record_update (e1',fexp'))) + ; e_record = (fun fexps -> let (fexps, fexps') = List.split fexps in (E_record fexps, E_record fexps')) + ; e_record_update = (fun ((e1,e1'),fexps) -> let (fexps, fexps') = List.split fexps in (E_record_update (e1,fexps), E_record_update (e1',fexps'))) ; e_field = (fun ((e1,e1'),id) -> (E_field (e1,id), E_field (e1',id))) ; e_case = (fun ((e1,e1'),pexps) -> let (pexps, pexps') = List.split pexps in (E_case (e1,pexps), E_case (e1',pexps'))) ; e_try = (fun ((e1,e1'),pexps) -> let (pexps, pexps') = List.split pexps in (E_try (e1,pexps), E_try (e1',pexps'))) @@ -543,8 +543,6 @@ let rewrite_sizeof (Defs defs) = ; lEXP_aux = (fun ((lexp,lexp'),annot) -> (LEXP_aux (lexp,annot), LEXP_aux (lexp',annot))) ; fE_Fexp = (fun (id,(e,e')) -> (FE_Fexp (id,e), FE_Fexp (id,e'))) ; fE_aux = (fun ((fexp,fexp'),annot) -> (FE_aux (fexp,annot), FE_aux (fexp',annot))) - ; fES_Fexps = (fun (fexps,b) -> let (fexps, fexps') = List.split fexps in (FES_Fexps (fexps,b), FES_Fexps (fexps',b))) - ; fES_aux = (fun ((fexp,fexp'),annot) -> (FES_aux (fexp,annot), FES_aux (fexp',annot))) ; def_val_empty = (Def_val_empty, Def_val_empty) ; def_val_dec = (fun (e,e') -> (Def_val_dec e, Def_val_dec e')) ; def_val_aux = (fun ((defval,defval'),aux) -> (Def_val_aux (defval,aux), Def_val_aux (defval',aux))) @@ -1173,7 +1171,7 @@ let rec pat_to_exp ((P_aux (pat,(l,annot))) as p_aux) = | P_id id -> rewrap (E_id id) | P_app (id,pats) -> rewrap (E_app (id, List.map pat_to_exp pats)) | P_record (fpats,b) -> - rewrap (E_record (FES_aux (FES_Fexps (List.map fpat_to_fexp fpats,b),(l,annot)))) + rewrap (E_record (List.map fpat_to_fexp fpats)) | P_vector pats -> rewrap (E_vector (List.map pat_to_exp pats)) | P_vector_concat pats -> begin let empty_vec = E_aux (E_vector [], (l,())) in @@ -1728,8 +1726,8 @@ let rec rewrite_lexp_to_rhs ((LEXP_aux(lexp,((l,_) as annot))) as le) = let env = env_of_annot lannot in match Env.expand_synonyms env (typ_of_annot lannot) with | Typ_aux (Typ_id rectyp_id, _) | Typ_aux (Typ_app (rectyp_id, _), _) when Env.is_record rectyp_id env -> - let field_update exp = FES_aux (FES_Fexps ([FE_aux (FE_Fexp (id, exp), annot)], false), annot) in - (lhs, (fun exp -> rhs (E_aux (E_record_update (lexp_to_exp lexp, field_update exp), lannot)))) + let field_update exp = FE_aux (FE_Fexp (id, exp), annot) in + (lhs, (fun exp -> rhs (E_aux (E_record_update (lexp_to_exp lexp, [field_update exp]), lannot)))) | _ -> raise (Reporting.err_unreachable l __POS__ ("Unsupported lexp: " ^ string_of_lexp le)) end | _ -> raise (Reporting.err_unreachable l __POS__ ("Unsupported lexp: " ^ string_of_lexp le)) @@ -2590,7 +2588,7 @@ let rewrite_defs_letbind_effects = and value_optdefault (Def_val_aux (o,_)) = match o with | Def_val_empty -> true | Def_val_dec e -> value e - and value_fexps (FES_aux (FES_Fexps (fexps,_),_)) = + and value_fexps fexps = List.fold_left (fun b (FE_aux (FE_Fexp (_,e),_)) -> b && value e) true fexps in @@ -2621,11 +2619,6 @@ let rewrite_defs_letbind_effects = and n_pexpL (newreturn : bool) (pexps : 'a pexp list) (k : 'a pexp list -> 'a exp) : 'a exp = mapCont (n_pexp newreturn) pexps k - and n_fexps (fexps : 'a fexps) (k : 'a fexps -> 'a exp) : 'a exp = - let (FES_aux (FES_Fexps (fexps_aux,b),annot)) = fexps in - n_fexpL fexps_aux (fun fexps_aux -> - k (fix_eff_fexps (FES_aux (FES_Fexps (fexps_aux,b),annot)))) - and n_opt_default (opt_default : 'a opt_default) (k : 'a opt_default -> 'a exp) : 'a exp = let (Def_val_aux (opt_default,annot)) = opt_default in match opt_default with @@ -2774,11 +2767,11 @@ let rewrite_defs_letbind_effects = n_exp_name exp2 (fun exp2 -> k (rewrap (E_cons (exp1,exp2))))) | E_record fexps -> - n_fexps fexps (fun fexps -> + n_fexpL fexps (fun fexps -> k (rewrap (E_record fexps))) | E_record_update (exp1,fexps) -> n_exp_name exp1 (fun exp1 -> - n_fexps fexps (fun fexps -> + n_fexpL fexps (fun fexps -> k (rewrap (E_record_update (exp1,fexps))))) | E_field (exp1,id) -> n_exp_name exp1 (fun exp1 -> @@ -4155,7 +4148,7 @@ and fexps_of_mfpats mfpats flag annot = let fexp_of_mfpat (MFP_aux (MFP_mpat (id, mpat), annot)) = FE_aux (FE_Fexp (id, exp_of_mpat mpat), annot) in - FES_aux (FES_Fexps (List.map fexp_of_mfpat mfpats, flag), annot) + List.map fexp_of_mfpat mfpats and pat_of_mpat (MP_aux (mpat, annot)) = match mpat with diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index fa68c6f2..180b96b2 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -210,11 +210,11 @@ let rec fv_of_exp consider_var bound used set (E_aux (e,(_,tannot))) : (Nameset. | E_vector_update(v,i,e) -> list_fv bound used set [v;i;e] | E_vector_update_subrange(v,i1,i2,e) -> list_fv bound used set [v;i1;i2;e] | E_vector_append(e1,e2) | E_cons(e1,e2) -> list_fv bound used set [e1;e2] - | E_record (FES_aux(FES_Fexps(fexps,_),_)) -> + | E_record fexps -> let used = Nameset.union (free_type_names_tannot consider_var tannot) used in List.fold_right (fun (FE_aux(FE_Fexp(_,e),_)) (b,u,s) -> fv_of_exp consider_var b u s e) fexps (bound,used,set) - | E_record_update(e,(FES_aux(FES_Fexps(fexps,_),_))) -> + | E_record_update(e, fexps) -> let b,u,s = fv_of_exp consider_var bound used set e in List.fold_right (fun (FE_aux(FE_Fexp(_,e),_)) (b,u,s) -> fv_of_exp consider_var b u s e) fexps (b,u,s) diff --git a/src/type_check.ml b/src/type_check.ml index d39ce27d..435c5cd8 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -2293,7 +2293,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ annot_exp (E_list checked_xs) typ | None -> typ_error l ("List " ^ string_of_exp exp ^ " must have list type, got " ^ string_of_typ typ) end - | E_record_update (exp, FES_aux (FES_Fexps (fexps, flag), (l, ()))), _ -> + | E_record_update (exp, fexps), _ -> (* TODO: this could also infer exp - also fix code duplication with E_record below *) let checked_exp = crule check_exp env exp typ in let rectyp_id = match Env.expand_synonyms env typ with @@ -2308,8 +2308,8 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ let checked_exp = crule check_exp env exp field_typ' in FE_aux (FE_Fexp (field, checked_exp), (l, None)) in - annot_exp (E_record_update (checked_exp, FES_aux (FES_Fexps (List.map check_fexp fexps, flag), (l, None)))) typ - | E_record (FES_aux (FES_Fexps (fexps, flag), (l, ()))), _ -> + annot_exp (E_record_update (checked_exp, List.map check_fexp fexps)) typ + | E_record fexps, _ -> (* TODO: check record fields are total *) let rectyp_id = match Env.expand_synonyms env typ with | Typ_aux (Typ_id rectyp_id, _) | Typ_aux (Typ_app (rectyp_id, _), _) when Env.is_record rectyp_id env -> @@ -2323,7 +2323,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ let checked_exp = crule check_exp env exp field_typ' in FE_aux (FE_Fexp (field, checked_exp), (l, None)) in - annot_exp (E_record (FES_aux (FES_Fexps (List.map check_fexp fexps, flag), (l, None)))) typ + annot_exp (E_record (List.map check_fexp fexps)) typ | E_let (LB_aux (letbind, (let_loc, _)), exp), _ -> begin match letbind with @@ -3165,7 +3165,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = annot_exp (E_tuple inferred_exps) (mk_typ (Typ_tup (List.map typ_of inferred_exps))) | E_assign (lexp, bind) -> fst (bind_assignment env lexp bind) - | E_record_update (exp, FES_aux (FES_Fexps (fexps, flag), (l, ()))) -> + | E_record_update (exp, fexps) -> let inferred_exp = irule infer_exp env exp in let typ = typ_of inferred_exp in let rectyp_id = match Env.expand_synonyms env typ with @@ -3180,7 +3180,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = let inferred_exp = crule check_exp env exp field_typ' in FE_aux (FE_Fexp (field, inferred_exp), (l, None)) in - annot_exp (E_record_update (inferred_exp, FES_aux (FES_Fexps (List.map check_fexp fexps, flag), (l, None)))) typ + annot_exp (E_record_update (inferred_exp, List.map check_fexp fexps)) typ | E_cast (typ, exp) -> let checked_exp = crule check_exp env exp typ in annot_exp (E_cast (typ, checked_exp)) typ @@ -3857,14 +3857,14 @@ and propagate_exp_effect_aux = function let p_cases = List.map propagate_pexp_effect cases in let case_eff = List.fold_left union_effects no_effect (List.map snd p_cases) in E_case (p_exp, List.map fst p_cases), union_effects (effect_of p_exp) case_eff - | E_record_update (exp, FES_aux (FES_Fexps (fexps, flag), (l, _))) -> + | E_record_update (exp, fexps) -> let p_exp = propagate_exp_effect exp in let p_fexps = List.map propagate_fexp_effect fexps in - E_record_update (p_exp, FES_aux (FES_Fexps (List.map fst p_fexps, flag), (l, None))), + E_record_update (p_exp, List.map fst p_fexps), List.fold_left union_effects no_effect (effect_of p_exp :: List.map snd p_fexps) - | E_record (FES_aux (FES_Fexps (fexps, flag), (l, _))) -> + | E_record fexps -> let p_fexps = List.map propagate_fexp_effect fexps in - E_record (FES_aux (FES_Fexps (List.map fst p_fexps, flag), (l, None))), + E_record (List.map fst p_fexps), List.fold_left union_effects no_effect (List.map snd p_fexps) | E_try (exp, cases) -> let p_exp = propagate_exp_effect exp in -- cgit v1.2.3 From 272d9565ef7f48baa0982a291c7fde8497ab0cd9 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 5 Dec 2018 20:49:38 +0000 Subject: Re-factor initial check Mostly this is to change how we desugar types in order to make us more flexible with what we can parse as a valid constraint as type. Previously the structure of the initial check forced some awkward limitations on what was parseable due to how the parse AST is set up. As part of this, I've taken the de-scattering of scattered functions out of the initial check, and moved it to a re-writing step after type-checking, where I think it logically belongs. This doesn't change much right now, but opens up some more possibilities in the future: Since scattered functions are now typechecked normally, any future module system for Sail would be able to handle them specially, and the Latex documentation backend can now document scattered functions explicitly, rather than relying on hackish 'de-scattering' logic to present documentation as the functions originally appeared. This has one slight breaking change which is that union clauses must appear before their uses in scattered functions, so union ast = Foo : unit function clause execute(Foo()) is ok, but function clause execute(Foo()) union ast = Foo : unit is not. Previously this worked because the de-scattering moved union clauses upwards before type-checking, but as this now happens after type-checking they must appear in the correct order. This doesn't occur in ARM, RISC-V, MIPS, but did appear in Cheri and I submitted a pull request to re-order the places where it happens. --- src/ast_util.ml | 1 + src/ast_util.mli | 1 + src/c_backend.ml | 8 +- src/initial_check.ml | 1458 +++++++++++++++++++--------------------------- src/initial_check.mli | 6 +- src/isail.ml | 6 +- src/monomorphise.ml | 4 +- src/parse_ast.ml | 14 +- src/parser.mly | 22 +- src/pretty_print_sail.ml | 13 +- src/process_file.ml | 1 - src/process_file.mli | 1 - src/rewrites.ml | 5 +- src/sail.ml | 1 + src/scattered.ml | 141 +++++ src/spec_analysis.ml | 19 +- src/type_check.ml | 50 +- 17 files changed, 824 insertions(+), 927 deletions(-) create mode 100644 src/scattered.ml (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index 48750ab7..e9153f7a 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -436,6 +436,7 @@ let quant_map_items f = function let unaux_nexp (Nexp_aux (nexp, _)) = nexp let unaux_order (Ord_aux (ord, _)) = ord let unaux_typ (Typ_aux (typ, _)) = typ +let unaux_kind (K_aux (k, _)) = k let rec map_exp_annot f (E_aux (exp, annot)) = E_aux (map_exp_annot_aux f exp, f annot) and map_exp_annot_aux f = function diff --git a/src/ast_util.mli b/src/ast_util.mli index b6bce7c5..19fc017d 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -96,6 +96,7 @@ val unaux_pat : 'a pat -> 'a pat_aux val unaux_nexp : nexp -> nexp_aux val unaux_order : order -> order_aux val unaux_typ : typ -> typ_aux +val unaux_kind : kind -> kind_aux val untyp_pat : 'a pat -> 'a pat * typ option val uncast_exp : 'a exp -> 'a exp * typ option diff --git a/src/c_backend.ml b/src/c_backend.ml index 2f57a802..fa21f96d 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -3328,8 +3328,8 @@ let instrument_tracing ctx = | cdef -> cdef let bytecode_ast ctx rewrites (Defs defs) = - let assert_vs = Initial_check.extern_of_string dec_ord (mk_id "sail_assert") "(bool, string) -> unit effect {escape}" in - let exit_vs = Initial_check.extern_of_string dec_ord (mk_id "sail_exit") "unit -> unit effect {escape}" in + let assert_vs = Initial_check.extern_of_string (mk_id "sail_assert") "(bool, string) -> unit effect {escape}" in + let exit_vs = Initial_check.extern_of_string (mk_id "sail_exit") "unit -> unit effect {escape}" in let ctx = { ctx with tc_env = snd (Type_error.check ctx.tc_env (Defs [assert_vs; exit_vs])) } in let chunks, ctx = List.fold_left (fun (chunks, ctx) def -> let defs, ctx = compile_def ctx def in defs :: chunks, ctx) ([], ctx) defs in @@ -3370,8 +3370,8 @@ let compile_ast ctx c_includes (Defs defs) = let ctx = { ctx with recursive_functions = recursive_functions } in c_debug (lazy (Util.string_of_list ", " string_of_id (IdSet.elements recursive_functions))); - let assert_vs = Initial_check.extern_of_string dec_ord (mk_id "sail_assert") "(bool, string) -> unit effect {escape}" in - let exit_vs = Initial_check.extern_of_string dec_ord (mk_id "sail_exit") "unit -> unit effect {escape}" in + let assert_vs = Initial_check.extern_of_string (mk_id "sail_assert") "(bool, string) -> unit effect {escape}" in + let exit_vs = Initial_check.extern_of_string (mk_id "sail_exit") "unit -> unit effect {escape}" in let ctx = { ctx with tc_env = snd (Type_error.check ctx.tc_env (Defs [assert_vs; exit_vs])) } in let chunks, ctx = List.fold_left (fun (chunks, ctx) def -> let defs, ctx = compile_def ctx def in defs :: chunks, ctx) ([], ctx) defs in let cdefs = List.concat (List.rev chunks) in diff --git a/src/initial_check.ml b/src/initial_check.ml index aa3a7136..926e993a 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -51,1006 +51,718 @@ open Ast open Util open Ast_util +open Printf module Big_int = Nat_big_num +module P = Parse_ast + (* See mli file for details on what these flags do *) let opt_undefined_gen = ref false let opt_fast_undefined = ref false let opt_magic_hash = ref false let opt_enum_casts = ref false -module Envmap = Finite_map.Fmap_map(String) -module Nameset' = Set.Make(String) -module Nameset = struct - include Nameset' - let pp ppf nameset = - Format.fprintf ppf "{@[%a@]}" - (Pp.lst ",@ " Pp.pp_str) - (Nameset'.elements nameset) -end - -type kind = { mutable k : k_aux } -and k_aux = - | K_Typ - | K_Nat - | K_Ord - | K_Efct - | K_Val - | K_Lam of kind list * kind - | K_infer - -let rec kind_to_string kind = match kind.k with - | K_Nat -> "Nat" - | K_Typ -> "Type" - | K_Ord -> "Order" - | K_Efct -> "Effect" - | K_infer -> "Infer" - | K_Val -> "Val" - | K_Lam (kinds,kind) -> "Lam [" ^ string_of_list ", " kind_to_string kinds ^ "] -> " ^ (kind_to_string kind) - -(*Envs is a tuple of used names (currently unused), map from id to kind, default order for vector types and literal vectors *) -type envs = Nameset.t * kind Envmap.t * order -type 'a envs_out = 'a * envs - -let id_to_string (Id_aux(id,l)) = - match id with | Id(x) | DeIid(x) -> x - -let var_to_string (Kid_aux(Var v,l)) = v - -let typquant_to_quantkinds k_env typquant = - match typquant with - | TypQ_aux(tq,_) -> - (match tq with - | TypQ_no_forall -> [] - | TypQ_tq(qlist) -> - List.fold_right - (fun (QI_aux(qi,_)) rst -> - match qi with - | QI_const _ -> rst - | QI_id(ki) -> begin - match ki with - | KOpt_aux(KOpt_none(v),l) | KOpt_aux(KOpt_kind(_,v),l) -> - (match Envmap.apply k_env (var_to_string v) with - | Some(typ) -> typ::rst - | None -> raise (Reporting.err_unreachable l __POS__ "Envmap didn't get an entry during typschm processing")) - end) - qlist - []) - -let typ_error l msg opt_id opt_var opt_kind = - raise (Reporting.err_typ - l - (msg ^ - (match opt_id, opt_var, opt_kind with - | Some(id),None,Some(kind) -> (id_to_string id) ^ " of " ^ (kind_to_string kind) - | Some(id),None,None -> ": " ^ (id_to_string id) - | None,Some(v),Some(kind) -> (var_to_string v) ^ " of " ^ (kind_to_string kind) - | None,Some(v),None -> ": " ^ (var_to_string v) - | None,None,Some(kind) -> " " ^ (kind_to_string kind) - | _ -> ""))) +type ctx = { + kinds : kind_aux KBindings.t; + type_constructors : (kind_aux list) Bindings.t; + scattereds : ctx Bindings.t; + } let string_of_parse_id_aux = function - | Parse_ast.Id v -> v - | Parse_ast.DeIid v -> v + | P.Id v -> v + | P.DeIid v -> v -let string_of_parse_id (Parse_ast.Id_aux(id, l)) = string_of_parse_id_aux id +let string_of_parse_id (P.Id_aux (id, l)) = string_of_parse_id_aux id let string_contains str char = try (ignore (String.index str char); true) with | Not_found -> false -let to_ast_id (Parse_ast.Id_aux(id, l)) = - if string_contains (string_of_parse_id_aux id) '#' && not (!opt_magic_hash) - then typ_error l "Identifier contains hash character" None None None - else Id_aux ((match id with - | Parse_ast.Id(x) -> Id(x) - | Parse_ast.DeIid(x) -> DeIid(x)), - l) - -let to_ast_var (Parse_ast.Kid_aux(Parse_ast.Var v,l)) = Kid_aux(Var v,l) +let to_ast_var (P.Kid_aux (P.Var v, l)) = Kid_aux (Var v, l) -let to_ast_kind (Parse_ast.K_aux(k,l')) = +let to_ast_kind (P.K_aux (k, l)) = match k with - | Parse_ast.K_type -> K_aux(K_type,l'), { k = K_Typ} - | Parse_ast.K_int -> K_aux(K_int,l'), { k = K_Nat } - | Parse_ast.K_order -> K_aux(K_order,l'), { k = K_Ord } - -let rec to_ast_typ (k_env : kind Envmap.t) (def_ord : order) (t: Parse_ast.atyp) : Ast.typ = - (* let _ = Printf.eprintf "to_ast_typ\n" in*) - match t with - | Parse_ast.ATyp_aux(t,l) -> - Typ_aux( (match t with - | Parse_ast.ATyp_id(id) -> Typ_id (to_ast_id id) - | Parse_ast.ATyp_var(v) -> - let v = to_ast_var v in - let mk = Envmap.apply k_env (var_to_string v) in - (match mk with - | Some(k) -> (match k.k with - | K_Typ -> Typ_var v - | K_infer -> k.k <- K_Typ; Typ_var v - | _ -> typ_error l "Required a variable with kind Type, encountered " None (Some v) (Some k)) - | None -> typ_error l "Encountered an unbound variable" None (Some v) None) - | Parse_ast.ATyp_fn(arg,ret,efct) -> - begin match arg with - | Parse_ast.ATyp_aux (Parse_ast.ATyp_tup args, _) -> - Typ_fn (List.map (to_ast_typ k_env def_ord) args, - (to_ast_typ k_env def_ord ret), - (to_ast_effects k_env efct)) - | _ -> Typ_fn ([to_ast_typ k_env def_ord arg], - (to_ast_typ k_env def_ord ret), - (to_ast_effects k_env efct)) - end - | Parse_ast.ATyp_bidir (typ1, typ2) -> Typ_bidir ( (to_ast_typ k_env def_ord typ1), - (to_ast_typ k_env def_ord typ2)) - | Parse_ast.ATyp_tup(typs) -> Typ_tup( List.map (to_ast_typ k_env def_ord) typs) - | Parse_ast.ATyp_app(Parse_ast.Id_aux(Parse_ast.Id "vector_sugar_tb",il), [ b; r; ord ; ti]) -> - let make_r bot top = - match bot,top with - | Parse_ast.ATyp_aux(Parse_ast.ATyp_constant b,_),Parse_ast.ATyp_aux(Parse_ast.ATyp_constant t,l) -> - Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (Big_int.add (Big_int.sub t b) (Big_int.of_int 1)),l) - | bot,(Parse_ast.ATyp_aux(_,l) as top) -> - Parse_ast.ATyp_aux((Parse_ast.ATyp_sum - ((Parse_ast.ATyp_aux - (Parse_ast.ATyp_sum (top, - Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (Big_int.of_int 1),Parse_ast.Unknown)), - Parse_ast.Unknown)), - (Parse_ast.ATyp_aux ((Parse_ast.ATyp_neg bot),Parse_ast.Unknown)))), l) in - let base = to_ast_nexp k_env b in - let rise = match def_ord with - | Ord_aux(Ord_inc,dl) -> to_ast_nexp k_env (make_r b r) - | Ord_aux(Ord_dec,dl) -> to_ast_nexp k_env (make_r r b) - | _ -> raise (Reporting.err_unreachable l __POS__ "Default order not inc or dec") in - Typ_app(Id_aux(Id "vector",il), - [Typ_arg_aux (Typ_arg_nexp base,Parse_ast.Unknown); - Typ_arg_aux (Typ_arg_nexp rise,Parse_ast.Unknown); - Typ_arg_aux (Typ_arg_order def_ord,Parse_ast.Unknown); - Typ_arg_aux (Typ_arg_typ (to_ast_typ k_env def_ord ti), Parse_ast.Unknown);]) - | Parse_ast.ATyp_app(Parse_ast.Id_aux(Parse_ast.Id "vector_sugar_r",il), [b;r;ord;ti]) -> - let make_sub_one t = - match t with - | Parse_ast.ATyp_aux(Parse_ast.ATyp_constant t,_) -> Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (Big_int.sub t (Big_int.of_int 1)),l) - | t -> (Parse_ast.ATyp_aux - (Parse_ast.ATyp_sum (t, Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (Big_int.negate (Big_int.of_int 1)),Parse_ast.Unknown)), - Parse_ast.Unknown)) in - let (base,rise) = match def_ord with - | Ord_aux(Ord_inc,dl) -> (to_ast_nexp k_env b), (to_ast_nexp k_env r) - | Ord_aux(Ord_dec,dl) -> (to_ast_nexp k_env (make_sub_one r)), (to_ast_nexp k_env r) - | _ -> raise (Reporting.err_unreachable l __POS__ "Default order not inc or dec") in - Typ_app(Id_aux(Id "vector",il), - [Typ_arg_aux (Typ_arg_nexp base,Parse_ast.Unknown); - Typ_arg_aux (Typ_arg_nexp rise,Parse_ast.Unknown); - Typ_arg_aux (Typ_arg_order def_ord,Parse_ast.Unknown); - Typ_arg_aux (Typ_arg_typ (to_ast_typ k_env def_ord ti), Parse_ast.Unknown);]) - | Parse_ast.ATyp_app (Parse_ast.Id_aux (Parse_ast.Id "int", il), [n]) -> - Typ_app(Id_aux(Id "atom", il), [Typ_arg_aux (Typ_arg_nexp (to_ast_nexp k_env n), Parse_ast.Unknown)]) - | Parse_ast.ATyp_app(pid,typs) -> - let id = to_ast_id pid in - let k = Envmap.apply k_env (id_to_string id) in - (match k with - | Some({k = K_Lam(args,t)}) -> - if ((List.length args) = (List.length typs)) - then - Typ_app(id,(List.map2 (fun k a -> (to_ast_typ_arg k_env def_ord k a)) args typs)) - else typ_error l "Type constructor given incorrect number of arguments" (Some id) None None - | None -> typ_error l "Required a type constructor, encountered an unbound identifier" (Some id) None None - | _ -> typ_error l "Required a type constructor, encountered a base kind variable" (Some id) None None) - | Parse_ast.ATyp_exist (kids, nc, atyp) -> - let kids = List.map to_ast_var kids in - let k_env = List.fold_left Envmap.insert k_env (List.map (fun kid -> (var_to_string kid, {k=K_Nat})) kids) in - let exist_typ = to_ast_typ k_env def_ord atyp in - Typ_exist (kids, to_ast_nexp_constraint k_env nc, exist_typ) - | Parse_ast.ATyp_with (atyp, nc) -> - let exist_typ = to_ast_typ k_env def_ord atyp in - let kids = KidSet.elements (tyvars_of_typ exist_typ) in - let k_env = List.fold_left Envmap.insert k_env (List.map (fun kid -> (var_to_string kid, {k=K_Nat})) kids) in - Typ_exist (kids, to_ast_nexp_constraint k_env nc, exist_typ) - | _ -> typ_error l "Required an item of kind Type, encountered an illegal form for this kind" None None None - ), l) - -and to_ast_nexp (k_env : kind Envmap.t) (n: Parse_ast.atyp) : Ast.nexp = - match n with - | Parse_ast.ATyp_aux(t,l) -> - (match t with - | Parse_ast.ATyp_id i -> Nexp_aux (Nexp_id (to_ast_id i), l) - | Parse_ast.ATyp_var v -> Nexp_aux (Nexp_var (to_ast_var v), l) - | Parse_ast.ATyp_constant i -> Nexp_aux (Nexp_constant i, l) - | Parse_ast.ATyp_sum (t1, t2) -> - let n1 = to_ast_nexp k_env t1 in - let n2 = to_ast_nexp k_env t2 in - Nexp_aux (Nexp_sum (n1, n2), l) - | Parse_ast.ATyp_exp t1 -> Nexp_aux(Nexp_exp(to_ast_nexp k_env t1),l) - | Parse_ast.ATyp_neg t1 -> Nexp_aux(Nexp_neg(to_ast_nexp k_env t1),l) - | Parse_ast.ATyp_times (t1, t2) -> - let n1 = to_ast_nexp k_env t1 in - let n2 = to_ast_nexp k_env t2 in - Nexp_aux (Nexp_times (n1, n2), l) - | Parse_ast.ATyp_minus (t1, t2) -> - let n1 = to_ast_nexp k_env t1 in - let n2 = to_ast_nexp k_env t2 in - Nexp_aux (Nexp_minus (n1, n2), l) - | Parse_ast.ATyp_app (id, ts) -> - let nexps = List.map (to_ast_nexp k_env) ts in - Nexp_aux (Nexp_app (to_ast_id id, nexps), l) - | _ -> typ_error l "Required an item of kind Nat, encountered an illegal form for this kind" None None None) - -and to_ast_order (k_env : kind Envmap.t) (def_ord : order) (o: Parse_ast.atyp) : Ast.order = - match o with - | Parse_ast.ATyp_aux(t,l) -> - (match t with - | Parse_ast.ATyp_var(v) -> - let v = to_ast_var v in - let mk = Envmap.apply k_env (var_to_string v) in - (match mk with - | Some(k) -> (match k.k with - | K_Ord -> Ord_aux(Ord_var v, l) - | K_infer -> k.k <- K_Ord; Ord_aux(Ord_var v,l) - | _ -> typ_error l "Required a variable with kind Order, encountered " None (Some v) (Some k)) - | None -> typ_error l "Encountered an unbound variable" None (Some v) None) - | Parse_ast.ATyp_inc -> Ord_aux(Ord_inc,l) - | Parse_ast.ATyp_dec -> Ord_aux(Ord_dec,l) - | Parse_ast.ATyp_default_ord -> def_ord - | _ -> typ_error l "Required an item of kind Order, encountered an illegal form for this kind" None None None - ) - -and to_ast_effects (k_env : kind Envmap.t) (e : Parse_ast.atyp) : Ast.effect = - match e with - | Parse_ast.ATyp_aux(t,l) -> - Effect_aux( (match t with - | Parse_ast.ATyp_var(v) -> - let v = to_ast_var v in - let mk = Envmap.apply k_env (var_to_string v) in - (match mk with - | Some k -> typ_error l "Required a variable with kind Effect, encountered " None (Some v) (Some k) - | None -> typ_error l "Encountered an unbound variable" None (Some v) None) - | Parse_ast.ATyp_set(effects) -> - Effect_set( List.map - (fun efct -> match efct with - | Parse_ast.BE_aux(e,l) -> - BE_aux((match e with - | Parse_ast.BE_barr -> BE_barr - | Parse_ast.BE_rreg -> BE_rreg - | Parse_ast.BE_wreg -> BE_wreg - | Parse_ast.BE_rmem -> BE_rmem - | Parse_ast.BE_rmemt -> BE_rmemt - | Parse_ast.BE_wmem -> BE_wmem - | Parse_ast.BE_wmv -> BE_wmv - | Parse_ast.BE_wmvt -> BE_wmvt - | Parse_ast.BE_eamem -> BE_eamem - | Parse_ast.BE_exmem -> BE_exmem - | Parse_ast.BE_depend -> BE_depend - | Parse_ast.BE_undef -> BE_undef - | Parse_ast.BE_unspec -> BE_unspec - | Parse_ast.BE_nondet -> BE_nondet - | Parse_ast.BE_escape -> BE_escape - | Parse_ast.BE_config -> BE_config),l)) - effects) - | _ -> typ_error l "Required an item of kind Effects, encountered an illegal form for this kind" None None None - ), l) - -and to_ast_typ_arg (k_env : kind Envmap.t) (def_ord : order) (kind : kind) (arg : Parse_ast.atyp) : Ast.typ_arg = - let l = (match arg with Parse_ast.ATyp_aux(_,l) -> l) in - Typ_arg_aux ( - (match kind.k with - | K_Typ -> Typ_arg_typ (to_ast_typ k_env def_ord arg) - | K_Nat -> Typ_arg_nexp (to_ast_nexp k_env arg) - | K_Ord -> Typ_arg_order (to_ast_order k_env def_ord arg) - | _ -> raise (Reporting.err_unreachable l __POS__ ("To_ast_typ_arg received Lam kind or infer kind: " ^ kind_to_string kind))), - l) + | P.K_type -> K_aux (K_type, l) + | P.K_int -> K_aux (K_int, l) + | P.K_order -> K_aux (K_order, l) -and to_ast_nexp_constraint (k_env : kind Envmap.t) (c : Parse_ast.n_constraint) : n_constraint = - match c with - | Parse_ast.NC_aux(nc,l) -> - NC_aux( (match nc with - | Parse_ast.NC_equal(t1,t2) -> - let n1 = to_ast_nexp k_env t1 in - let n2 = to_ast_nexp k_env t2 in - NC_equal(n1,n2) - | Parse_ast.NC_not_equal(t1,t2) -> - let n1 = to_ast_nexp k_env t1 in - let n2 = to_ast_nexp k_env t2 in - NC_not_equal(n1,n2) - | Parse_ast.NC_bounded_ge(t1,t2) -> - let n1 = to_ast_nexp k_env t1 in - let n2 = to_ast_nexp k_env t2 in - NC_bounded_ge(n1,n2) - | Parse_ast.NC_bounded_le(t1,t2) -> - let n1 = to_ast_nexp k_env t1 in - let n2 = to_ast_nexp k_env t2 in - NC_bounded_le(n1,n2) - | Parse_ast.NC_set(id,bounds) -> - NC_set(to_ast_var id, bounds) - | Parse_ast.NC_or (nc1, nc2) -> - NC_or (to_ast_nexp_constraint k_env nc1, to_ast_nexp_constraint k_env nc2) - | Parse_ast.NC_and (nc1, nc2) -> - NC_and (to_ast_nexp_constraint k_env nc1, to_ast_nexp_constraint k_env nc2) - | Parse_ast.NC_true -> NC_true - | Parse_ast.NC_false -> NC_false - ), l) - -(* Transforms a typquant while building first the kind environment of declared variables, and also the kind environment in context *) -let to_ast_typquant (k_env: kind Envmap.t) (tq : Parse_ast.typquant) : typquant * kind Envmap.t * kind Envmap.t = - let opt_kind_to_ast k_env local_names local_env (Parse_ast.KOpt_aux(ki,l)) = - let v, key, kind, ktyp = - match ki with - | Parse_ast.KOpt_none(v) -> - let v = to_ast_var v in - let key = var_to_string v in - let kind,ktyp = if (Envmap.in_dom key k_env) then None,(Envmap.apply k_env key) else None,(Some{ k = K_infer }) in - v,key,kind, ktyp - | Parse_ast.KOpt_kind(k,v) -> - let v = to_ast_var v in - let key = var_to_string v in - let kind,ktyp = to_ast_kind k in - v,key,Some(kind),Some(ktyp) - in - if (Nameset.mem key local_names) - then typ_error l "Encountered duplicate name in type scheme" None (Some v) None - else - let local_names = Nameset.add key local_names in - let kopt,k_env,k_env_local = (match kind,ktyp with - | Some(k),Some(kt) -> KOpt_kind(k,v), (Envmap.insert k_env (key,kt)), (Envmap.insert local_env (key,kt)) - | None, Some(kt) -> KOpt_none(v), (Envmap.insert k_env (key,kt)), (Envmap.insert local_env (key,kt)) - | _ -> raise (Reporting.err_unreachable l __POS__ "Envmap in dom is true but apply gives None")) in - KOpt_aux(kopt,l),k_env,local_names,k_env_local +let to_ast_id (P.Id_aux(id, l)) = + if string_contains (string_of_parse_id_aux id) '#' && not (!opt_magic_hash) then + raise (Reporting.err_general l "Identifier contains hash character and -dmagic_hash is unset") + else + Id_aux ((match id with + | P.Id x -> Id x + | P.DeIid x -> DeIid x), + l) + +let to_ast_var (P.Kid_aux(P.Var v,l)) = Kid_aux(Var v,l) + +let to_ast_effects = function + | P.ATyp_aux (P.ATyp_set effects, l) -> + let to_effect (P.BE_aux (e, l)) = + BE_aux ((match e with + | P.BE_barr -> BE_barr + | P.BE_rreg -> BE_rreg + | P.BE_wreg -> BE_wreg + | P.BE_rmem -> BE_rmem + | P.BE_rmemt -> BE_rmemt + | P.BE_wmem -> BE_wmem + | P.BE_wmv -> BE_wmv + | P.BE_wmvt -> BE_wmvt + | P.BE_eamem -> BE_eamem + | P.BE_exmem -> BE_exmem + | P.BE_depend -> BE_depend + | P.BE_undef -> BE_undef + | P.BE_unspec -> BE_unspec + | P.BE_nondet -> BE_nondet + | P.BE_escape -> BE_escape + | P.BE_config -> BE_config), + l) + in + Effect_aux (Effect_set (List.map to_effect effects), l) + | P.ATyp_aux (_, l) -> + raise (Reporting.err_typ l "Invalid effect set") + +(* Used for error messages involving lists of kinds *) +let format_kind_aux_list = function + | [kind] -> string_of_kind_aux kind + | kinds -> "(" ^ Util.string_of_list ", " string_of_kind_aux kinds ^ ")" + +let rec to_ast_typ ctx (P.ATyp_aux (aux, l)) = + let aux = match aux with + | P.ATyp_id id -> Typ_id (to_ast_id id) + | P.ATyp_var v -> Typ_var (to_ast_var v) + | P.ATyp_fn (from_typ, to_typ, effects) -> + let from_typs = match from_typ with + | P.ATyp_aux (P.ATyp_tup typs, _) -> + List.map (to_ast_typ ctx) typs + | _ -> [to_ast_typ ctx from_typ] + in + Typ_fn (from_typs, to_ast_typ ctx to_typ, to_ast_effects effects) + | P.ATyp_bidir (typ1, typ2) -> Typ_bidir (to_ast_typ ctx typ1, to_ast_typ ctx typ2) + | P.ATyp_tup typs -> Typ_tup (List.map (to_ast_typ ctx) typs) + | P.ATyp_app (P.Id_aux (P.Id "int", il), [n]) -> + Typ_app (Id_aux (Id "atom", il), [to_ast_typ_arg ctx n K_int]) + | P.ATyp_app (id, args) -> + let id = to_ast_id id in + begin match Bindings.find_opt id ctx.type_constructors with + | None -> raise (Reporting.err_typ l (sprintf "Could not find type constructor %s" (string_of_id id))) + | Some kinds when List.length args <> List.length kinds -> + raise (Reporting.err_typ l (sprintf "%s : %s -> Type expected %d arguments, given %d" + (string_of_id id) (format_kind_aux_list kinds) + (List.length kinds) (List.length args))) + | Some kinds -> + Typ_app (id, List.map2 (to_ast_typ_arg ctx) args kinds) + end + | P.ATyp_exist (kids, nc, atyp) -> + let kids = List.map to_ast_var kids in + let ctx = { ctx with kinds = List.fold_left (fun kinds kid -> KBindings.add kid K_int kinds) ctx.kinds kids } in + Typ_exist (kids, to_ast_constraint ctx nc, to_ast_typ ctx atyp) + | _ -> raise (Reporting.err_typ l "Invalid type") in - match tq with - | Parse_ast.TypQ_aux(tqa,l) -> - (match tqa with - | Parse_ast.TypQ_no_forall -> TypQ_aux(TypQ_no_forall,l), k_env, Envmap.empty - | Parse_ast.TypQ_tq(qlist) -> - let rec to_ast_q_items k_env local_names local_env = function - | [] -> [],k_env,local_env - | q::qs -> (match q with - | Parse_ast.QI_aux(qi,l) -> - (match qi with - | Parse_ast.QI_const(n_const) -> - let c = QI_aux(QI_const(to_ast_nexp_constraint k_env n_const),l) in - let qis,k_env,local_env = to_ast_q_items k_env local_names local_env qs in - (c::qis),k_env,local_env - | Parse_ast.QI_id(kid) -> - let kid,k_env,local_names,local_env = opt_kind_to_ast k_env local_names local_env kid in - let c = QI_aux(QI_id(kid),l) in - let qis,k_env,local_env = to_ast_q_items k_env local_names local_env qs in - (c::qis),k_env,local_env)) - in - let lst,k_env,local_env = to_ast_q_items k_env Nameset.empty Envmap.empty qlist in - TypQ_aux(TypQ_tq(lst),l), k_env, local_env) - -let to_ast_typschm (k_env:kind Envmap.t) (def_ord:order) (tschm:Parse_ast.typschm) :Ast.typschm * kind Envmap.t * kind Envmap.t = - match tschm with - | Parse_ast.TypSchm_aux(ts,l) -> - (match ts with | Parse_ast.TypSchm_ts(tquant,t) -> - let tq,k_env,local_env = to_ast_typquant k_env tquant in - let typ = to_ast_typ k_env def_ord t in - TypSchm_aux(TypSchm_ts(tq,typ),l),k_env,local_env) - -let to_ast_lit (Parse_ast.L_aux(lit,l)) : lit = - L_aux( - (match lit with - | Parse_ast.L_unit -> L_unit - | Parse_ast.L_zero -> L_zero - | Parse_ast.L_one -> L_one - | Parse_ast.L_true -> L_true - | Parse_ast.L_false -> L_false - | Parse_ast.L_undef -> L_undef - | Parse_ast.L_num(i) -> L_num(i) - | Parse_ast.L_hex(h) -> L_hex(h) - | Parse_ast.L_bin(b) -> L_bin(b) - | Parse_ast.L_real r -> L_real r - | Parse_ast.L_string(s) -> L_string(s)) - ,l) - -let rec to_ast_typ_pat (Parse_ast.ATyp_aux (typ_aux, l)) = - match typ_aux with - | Parse_ast.ATyp_wild -> TP_aux (TP_wild, l) - | Parse_ast.ATyp_var kid -> TP_aux (TP_var (to_ast_var kid), l) - | Parse_ast.ATyp_app (Parse_ast.Id_aux (Parse_ast.Id "int", il), typs) -> - TP_aux (TP_app (Id_aux (Id "atom", il), List.map to_ast_typ_pat typs), l) - | Parse_ast.ATyp_app (f, typs) -> - TP_aux (TP_app (to_ast_id f, List.map to_ast_typ_pat typs), l) - | _ -> typ_error l "Unexpected type in type pattern" None None None - -let rec to_ast_pat (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.P_aux(pat,l) : Parse_ast.pat) : unit pat = - P_aux( - (match pat with - | Parse_ast.P_lit(lit) -> P_lit(to_ast_lit lit) - | Parse_ast.P_wild -> P_wild - | Parse_ast.P_or(pat1, pat2) -> - P_or (to_ast_pat k_env def_ord pat1, to_ast_pat k_env def_ord pat2) - | Parse_ast.P_var (pat, Parse_ast.ATyp_aux (Parse_ast.ATyp_id id, _)) -> - P_as (to_ast_pat k_env def_ord pat, to_ast_id id) - | Parse_ast.P_typ(typ,pat) -> P_typ(to_ast_typ k_env def_ord typ,to_ast_pat k_env def_ord pat) - | Parse_ast.P_id(id) -> P_id(to_ast_id id) - | Parse_ast.P_var (pat, typ) -> P_var (to_ast_pat k_env def_ord pat, to_ast_typ_pat typ) - | Parse_ast.P_app(id, []) -> P_id (to_ast_id id) - | Parse_ast.P_app(id, pats) -> - if List.length pats == 1 && string_of_parse_id id = "~" - then P_not (to_ast_pat k_env def_ord (List.hd pats)) - else P_app(to_ast_id id, List.map (to_ast_pat k_env def_ord) pats) - | Parse_ast.P_record(fpats,_) -> - P_record(List.map - (fun (Parse_ast.FP_aux(Parse_ast.FP_Fpat(id,fp),l)) -> - FP_aux(FP_Fpat(to_ast_id id, to_ast_pat k_env def_ord fp),(l,()))) - fpats, false) - | Parse_ast.P_vector(pats) -> P_vector(List.map (to_ast_pat k_env def_ord) pats) - | Parse_ast.P_vector_concat(pats) -> P_vector_concat(List.map (to_ast_pat k_env def_ord) pats) - | Parse_ast.P_tup(pats) -> P_tup(List.map (to_ast_pat k_env def_ord) pats) - | Parse_ast.P_list(pats) -> P_list(List.map (to_ast_pat k_env def_ord) pats) - | Parse_ast.P_cons(pat1, pat2) -> P_cons (to_ast_pat k_env def_ord pat1, to_ast_pat k_env def_ord pat2) - | Parse_ast.P_string_append pats -> P_string_append (List.map (to_ast_pat k_env def_ord) pats) - ), (l,())) + Typ_aux (aux, l) + +and to_ast_typ_arg ctx (ATyp_aux (_, l) as atyp) = function + | K_type -> Typ_arg_aux (Typ_arg_typ (to_ast_typ ctx atyp), l) + | K_int -> Typ_arg_aux (Typ_arg_nexp (to_ast_nexp ctx atyp), l) + | K_order -> Typ_arg_aux (Typ_arg_order (to_ast_order ctx atyp), l) + +and to_ast_nexp ctx (P.ATyp_aux (aux, l)) = + let aux = match aux with + | P.ATyp_id id -> Nexp_id (to_ast_id id) + | P.ATyp_var v -> Nexp_var (to_ast_var v) + | P.ATyp_constant c -> Nexp_constant c + | P.ATyp_sum (t1, t2) -> Nexp_sum (to_ast_nexp ctx t1, to_ast_nexp ctx t2) + | P.ATyp_exp t1 -> Nexp_exp (to_ast_nexp ctx t1) + | P.ATyp_neg t1 -> Nexp_neg (to_ast_nexp ctx t1) + | P.ATyp_times (t1, t2) -> Nexp_times (to_ast_nexp ctx t1, to_ast_nexp ctx t2) + | P.ATyp_minus (t1, t2) -> Nexp_minus (to_ast_nexp ctx t1, to_ast_nexp ctx t2) + | P.ATyp_app (id, ts) -> Nexp_app (to_ast_id id, List.map (to_ast_nexp ctx) ts) + | _ -> raise (Reporting.err_typ l "Invalid numeric expression in type") + in + Nexp_aux (aux, l) +and to_ast_order ctx (P.ATyp_aux (aux, l)) = + match aux with + | ATyp_var v -> Ord_aux (Ord_var (to_ast_var v), l) + | ATyp_inc -> Ord_aux (Ord_inc, l) + | ATyp_dec -> Ord_aux (Ord_dec, l) + | _ -> raise (Reporting.err_typ l "Invalid order in type") + +and to_ast_constraint ctx (P.NC_aux (nc, l)) = + let nc = match nc with + | P.NC_equal (t1, t2) -> + NC_equal (to_ast_nexp ctx t1, to_ast_nexp ctx t2) + | P.NC_not_equal (t1, t2) -> + NC_not_equal (to_ast_nexp ctx t1, to_ast_nexp ctx t2) + | P.NC_bounded_ge (t1,t2) -> + NC_bounded_ge (to_ast_nexp ctx t1, to_ast_nexp ctx t2) + | P.NC_bounded_le(t1,t2) -> + NC_bounded_le (to_ast_nexp ctx t1, to_ast_nexp ctx t2) + | P.NC_set(id,bounds) -> + NC_set(to_ast_var id, bounds) + | P.NC_or (nc1, nc2) -> + NC_or (to_ast_constraint ctx nc1, to_ast_constraint ctx nc2) + | P.NC_and (nc1, nc2) -> + NC_and (to_ast_constraint ctx nc1, to_ast_constraint ctx nc2) + | P.NC_true -> NC_true + | P.NC_false -> NC_false + in + NC_aux (nc, l) -let rec to_ast_letbind (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.LB_aux(lb,l) : Parse_ast.letbind) : unit letbind = +let to_ast_quant_item ctx (P.QI_aux (aux, l)) = + match aux with + | P.QI_const nc -> QI_aux (QI_const (to_ast_constraint ctx nc), l), ctx + | P.QI_id (KOpt_aux (aux, kopt_l)) -> + let aux, ctx = match aux with + | P.KOpt_none v -> + let v = to_ast_var v in + KOpt_none v, { ctx with kinds = KBindings.add v K_int ctx.kinds } + | P.KOpt_kind (k, v) -> + let v = to_ast_var v in + let k = to_ast_kind k in + KOpt_kind (k, v), { ctx with kinds = KBindings.add v (unaux_kind k) ctx.kinds } + in + QI_aux (QI_id (KOpt_aux (aux, kopt_l)), l), ctx + +let to_ast_typquant ctx (P.TypQ_aux (aux, l)) = + match aux with + | P.TypQ_no_forall -> TypQ_aux (TypQ_no_forall, l), ctx + | P.TypQ_tq quants -> + let quants, ctx = + List.fold_left (fun (qis, ctx) qi -> let qi', ctx = to_ast_quant_item ctx qi in qi' :: qis, ctx) ([], ctx) quants + in + TypQ_aux (TypQ_tq (List.rev quants), l), ctx + +let to_ast_typschm ctx (P.TypSchm_aux (P.TypSchm_ts (typq, typ), l)) = + let typq, ctx = to_ast_typquant ctx typq in + let typ = to_ast_typ ctx typ in + TypSchm_aux (TypSchm_ts (typq, typ), l), ctx + +let to_ast_lit (P.L_aux (lit, l)) = + L_aux ((match lit with + | P.L_unit -> L_unit + | P.L_zero -> L_zero + | P.L_one -> L_one + | P.L_true -> L_true + | P.L_false -> L_false + | P.L_undef -> L_undef + | P.L_num i -> L_num i + | P.L_hex h -> L_hex h + | P.L_bin b -> L_bin b + | P.L_real r -> L_real r + | P.L_string s -> L_string s) + ,l) + +let rec to_ast_typ_pat (P.ATyp_aux (aux, l)) = + match aux with + | P.ATyp_wild -> TP_aux (TP_wild, l) + | P.ATyp_var kid -> TP_aux (TP_var (to_ast_var kid), l) + | P.ATyp_app (P.Id_aux (P.Id "int", il), typs) -> + TP_aux (TP_app (Id_aux (Id "atom", il), List.map to_ast_typ_pat typs), l) + | P.ATyp_app (f, typs) -> + TP_aux (TP_app (to_ast_id f, List.map to_ast_typ_pat typs), l) + | _ -> raise (Reporting.err_typ l "Unexpected type in type pattern") + +let rec to_ast_pat ctx (P.P_aux (pat, l)) = + P_aux ((match pat with + | P.P_lit lit -> P_lit (to_ast_lit lit) + | P.P_wild -> P_wild + | P.P_or (pat1, pat2) -> + P_or (to_ast_pat ctx pat1, to_ast_pat ctx pat2) + | P.P_var (pat, P.ATyp_aux (P.ATyp_id id, _)) -> + P_as (to_ast_pat ctx pat, to_ast_id id) + | P.P_typ (typ, pat) -> P_typ (to_ast_typ ctx typ, to_ast_pat ctx pat) + | P.P_id id -> P_id (to_ast_id id) + | P.P_var (pat, typ) -> P_var (to_ast_pat ctx pat, to_ast_typ_pat typ) + | P.P_app (id, []) -> P_id (to_ast_id id) + | P.P_app (id, pats) -> + if List.length pats == 1 && string_of_parse_id id = "~" + then P_not (to_ast_pat ctx (List.hd pats)) + else P_app (to_ast_id id, List.map (to_ast_pat ctx) pats) + | P.P_record(fpats,_) -> + P_record(List.map + (fun (P.FP_aux(P.FP_Fpat(id,fp),l)) -> + FP_aux(FP_Fpat(to_ast_id id, to_ast_pat ctx fp),(l,()))) + fpats, false) + | P.P_vector(pats) -> P_vector(List.map (to_ast_pat ctx) pats) + | P.P_vector_concat(pats) -> P_vector_concat(List.map (to_ast_pat ctx) pats) + | P.P_tup(pats) -> P_tup(List.map (to_ast_pat ctx) pats) + | P.P_list(pats) -> P_list(List.map (to_ast_pat ctx) pats) + | P.P_cons(pat1, pat2) -> P_cons (to_ast_pat ctx pat1, to_ast_pat ctx pat2) + | P.P_string_append pats -> P_string_append (List.map (to_ast_pat ctx) pats) + ), (l,())) + +let rec to_ast_letbind ctx (P.LB_aux(lb,l) : P.letbind) : unit letbind = LB_aux( (match lb with - | Parse_ast.LB_val(pat,exp) -> - LB_val(to_ast_pat k_env def_ord pat, to_ast_exp k_env def_ord exp) + | P.LB_val(pat,exp) -> + LB_val(to_ast_pat ctx pat, to_ast_exp ctx exp) ), (l,())) -and to_ast_exp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) : Parse_ast.exp) : unit exp = +and to_ast_exp ctx (P.E_aux(exp,l) : P.exp) = E_aux( (match exp with - | Parse_ast.E_block(exps) -> - (match to_ast_fexps false k_env def_ord exps with + | P.E_block(exps) -> + (match to_ast_fexps false ctx exps with | Some(fexps) -> E_record(fexps) - | None -> E_block(List.map (to_ast_exp k_env def_ord) exps)) - | Parse_ast.E_nondet(exps) -> E_nondet(List.map (to_ast_exp k_env def_ord) exps) - | Parse_ast.E_id(id) -> E_id(to_ast_id id) - | Parse_ast.E_ref(id) -> E_ref(to_ast_id id) - | Parse_ast.E_lit(lit) -> E_lit(to_ast_lit lit) - | Parse_ast.E_cast(typ,exp) -> E_cast(to_ast_typ k_env def_ord typ, to_ast_exp k_env def_ord exp) - | Parse_ast.E_app(f,args) -> - (match List.map (to_ast_exp k_env def_ord) args with + | None -> E_block(List.map (to_ast_exp ctx) exps)) + | P.E_nondet(exps) -> E_nondet(List.map (to_ast_exp ctx) exps) + | P.E_id(id) -> E_id(to_ast_id id) + | P.E_ref(id) -> E_ref(to_ast_id id) + | P.E_lit(lit) -> E_lit(to_ast_lit lit) + | P.E_cast(typ,exp) -> E_cast(to_ast_typ ctx typ, to_ast_exp ctx exp) + | P.E_app(f,args) -> + (match List.map (to_ast_exp ctx) args with | [] -> E_app(to_ast_id f, []) | exps -> E_app(to_ast_id f, exps)) - | Parse_ast.E_app_infix(left,op,right) -> - E_app_infix(to_ast_exp k_env def_ord left, to_ast_id op, to_ast_exp k_env def_ord right) - | Parse_ast.E_tuple(exps) -> E_tuple(List.map (to_ast_exp k_env def_ord) exps) - | Parse_ast.E_if(e1,e2,e3) -> E_if(to_ast_exp k_env def_ord e1, to_ast_exp k_env def_ord e2, to_ast_exp k_env def_ord e3) - | Parse_ast.E_for(id,e1,e2,e3,atyp,e4) -> - E_for(to_ast_id id,to_ast_exp k_env def_ord e1, to_ast_exp k_env def_ord e2, - to_ast_exp k_env def_ord e3,to_ast_order k_env def_ord atyp, to_ast_exp k_env def_ord e4) - | Parse_ast.E_loop (Parse_ast.While, e1, e2) -> E_loop (While, to_ast_exp k_env def_ord e1, to_ast_exp k_env def_ord e2) - | Parse_ast.E_loop (Parse_ast.Until, e1, e2) -> E_loop (Until, to_ast_exp k_env def_ord e1, to_ast_exp k_env def_ord e2) - | Parse_ast.E_vector(exps) -> E_vector(List.map (to_ast_exp k_env def_ord) exps) - | Parse_ast.E_vector_access(vexp,exp) -> E_vector_access(to_ast_exp k_env def_ord vexp, to_ast_exp k_env def_ord exp) - | Parse_ast.E_vector_subrange(vex,exp1,exp2) -> - E_vector_subrange(to_ast_exp k_env def_ord vex, to_ast_exp k_env def_ord exp1, to_ast_exp k_env def_ord exp2) - | Parse_ast.E_vector_update(vex,exp1,exp2) -> - E_vector_update(to_ast_exp k_env def_ord vex, to_ast_exp k_env def_ord exp1, to_ast_exp k_env def_ord exp2) - | Parse_ast.E_vector_update_subrange(vex,e1,e2,e3) -> - E_vector_update_subrange(to_ast_exp k_env def_ord vex, to_ast_exp k_env def_ord e1, - to_ast_exp k_env def_ord e2, to_ast_exp k_env def_ord e3) - | Parse_ast.E_vector_append(e1,e2) -> E_vector_append(to_ast_exp k_env def_ord e1,to_ast_exp k_env def_ord e2) - | Parse_ast.E_list(exps) -> E_list(List.map (to_ast_exp k_env def_ord) exps) - | Parse_ast.E_cons(e1,e2) -> E_cons(to_ast_exp k_env def_ord e1, to_ast_exp k_env def_ord e2) - | Parse_ast.E_record fexps -> - (match to_ast_fexps true k_env def_ord fexps with + | P.E_app_infix(left,op,right) -> + E_app_infix(to_ast_exp ctx left, to_ast_id op, to_ast_exp ctx right) + | P.E_tuple(exps) -> E_tuple(List.map (to_ast_exp ctx) exps) + | P.E_if(e1,e2,e3) -> E_if(to_ast_exp ctx e1, to_ast_exp ctx e2, to_ast_exp ctx e3) + | P.E_for(id,e1,e2,e3,atyp,e4) -> + E_for(to_ast_id id,to_ast_exp ctx e1, to_ast_exp ctx e2, + to_ast_exp ctx e3,to_ast_order ctx atyp, to_ast_exp ctx e4) + | P.E_loop (P.While, e1, e2) -> E_loop (While, to_ast_exp ctx e1, to_ast_exp ctx e2) + | P.E_loop (P.Until, e1, e2) -> E_loop (Until, to_ast_exp ctx e1, to_ast_exp ctx e2) + | P.E_vector(exps) -> E_vector(List.map (to_ast_exp ctx) exps) + | P.E_vector_access(vexp,exp) -> E_vector_access(to_ast_exp ctx vexp, to_ast_exp ctx exp) + | P.E_vector_subrange(vex,exp1,exp2) -> + E_vector_subrange(to_ast_exp ctx vex, to_ast_exp ctx exp1, to_ast_exp ctx exp2) + | P.E_vector_update(vex,exp1,exp2) -> + E_vector_update(to_ast_exp ctx vex, to_ast_exp ctx exp1, to_ast_exp ctx exp2) + | P.E_vector_update_subrange(vex,e1,e2,e3) -> + E_vector_update_subrange(to_ast_exp ctx vex, to_ast_exp ctx e1, + to_ast_exp ctx e2, to_ast_exp ctx e3) + | P.E_vector_append(e1,e2) -> E_vector_append(to_ast_exp ctx e1,to_ast_exp ctx e2) + | P.E_list(exps) -> E_list(List.map (to_ast_exp ctx) exps) + | P.E_cons(e1,e2) -> E_cons(to_ast_exp ctx e1, to_ast_exp ctx e2) + | P.E_record fexps -> + (match to_ast_fexps true ctx fexps with | Some fexps -> E_record fexps | None -> raise (Reporting.err_unreachable l __POS__ "to_ast_fexps with true returned none")) - | Parse_ast.E_record_update(exp,fexps) -> - (match to_ast_fexps true k_env def_ord fexps with - | Some(fexps) -> E_record_update(to_ast_exp k_env def_ord exp, fexps) + | P.E_record_update(exp,fexps) -> + (match to_ast_fexps true ctx fexps with + | Some(fexps) -> E_record_update(to_ast_exp ctx exp, fexps) | _ -> raise (Reporting.err_unreachable l __POS__ "to_ast_fexps with true returned none")) - | Parse_ast.E_field(exp,id) -> E_field(to_ast_exp k_env def_ord exp, to_ast_id id) - | Parse_ast.E_case(exp,pexps) -> E_case(to_ast_exp k_env def_ord exp, List.map (to_ast_case k_env def_ord) pexps) - | Parse_ast.E_try (exp, pexps) -> E_try (to_ast_exp k_env def_ord exp, List.map (to_ast_case k_env def_ord) pexps) - | Parse_ast.E_let(leb,exp) -> E_let(to_ast_letbind k_env def_ord leb, to_ast_exp k_env def_ord exp) - | Parse_ast.E_assign(lexp,exp) -> E_assign(to_ast_lexp k_env def_ord lexp, to_ast_exp k_env def_ord exp) - | Parse_ast.E_var(lexp,exp1,exp2) -> E_var(to_ast_lexp k_env def_ord lexp, to_ast_exp k_env def_ord exp1, to_ast_exp k_env def_ord exp2) - | Parse_ast.E_sizeof(nexp) -> E_sizeof(to_ast_nexp k_env nexp) - | Parse_ast.E_constraint nc -> E_constraint (to_ast_nexp_constraint k_env nc) - | Parse_ast.E_exit exp -> E_exit(to_ast_exp k_env def_ord exp) - | Parse_ast.E_throw exp -> E_throw (to_ast_exp k_env def_ord exp) - | Parse_ast.E_return exp -> E_return(to_ast_exp k_env def_ord exp) - | Parse_ast.E_assert(cond,msg) -> E_assert(to_ast_exp k_env def_ord cond, to_ast_exp k_env def_ord msg) + | P.E_field(exp,id) -> E_field(to_ast_exp ctx exp, to_ast_id id) + | P.E_case(exp,pexps) -> E_case(to_ast_exp ctx exp, List.map (to_ast_case ctx) pexps) + | P.E_try (exp, pexps) -> E_try (to_ast_exp ctx exp, List.map (to_ast_case ctx) pexps) + | P.E_let(leb,exp) -> E_let(to_ast_letbind ctx leb, to_ast_exp ctx exp) + | P.E_assign(lexp,exp) -> E_assign(to_ast_lexp ctx lexp, to_ast_exp ctx exp) + | P.E_var(lexp,exp1,exp2) -> E_var(to_ast_lexp ctx lexp, to_ast_exp ctx exp1, to_ast_exp ctx exp2) + | P.E_sizeof(nexp) -> E_sizeof(to_ast_nexp ctx nexp) + | P.E_constraint nc -> E_constraint (to_ast_constraint ctx nc) + | P.E_exit exp -> E_exit(to_ast_exp ctx exp) + | P.E_throw exp -> E_throw (to_ast_exp ctx exp) + | P.E_return exp -> E_return(to_ast_exp ctx exp) + | P.E_assert(cond,msg) -> E_assert(to_ast_exp ctx cond, to_ast_exp ctx msg) | _ -> raise (Reporting.err_unreachable l __POS__ "Unparsable construct in to_ast_exp") ), (l,())) -and to_ast_lexp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) : Parse_ast.exp) : unit lexp = +and to_ast_lexp ctx (P.E_aux(exp,l) : P.exp) : unit lexp = let lexp = match exp with - | Parse_ast.E_id id -> LEXP_id (to_ast_id id) - | Parse_ast.E_deref exp -> LEXP_deref (to_ast_exp k_env def_ord exp) - | Parse_ast.E_cast (typ, Parse_ast.E_aux (Parse_ast.E_id id, l')) -> - LEXP_cast (to_ast_typ k_env def_ord typ, to_ast_id id) - | Parse_ast.E_tuple tups -> - let ltups = List.map (to_ast_lexp k_env def_ord) tups in + | P.E_id id -> LEXP_id (to_ast_id id) + | P.E_deref exp -> LEXP_deref (to_ast_exp ctx exp) + | P.E_cast (typ, P.E_aux (P.E_id id, l')) -> + LEXP_cast (to_ast_typ ctx typ, to_ast_id id) + | P.E_tuple tups -> + let ltups = List.map (to_ast_lexp ctx) tups in let is_ok_in_tup (LEXP_aux (le, (l, _))) = match le with | LEXP_id _ | LEXP_cast _ | LEXP_vector _ | LEXP_vector_concat _ | LEXP_field _ | LEXP_vector_range _ | LEXP_tup _ -> () | LEXP_memory _ | LEXP_deref _ -> - typ_error l "only identifiers, fields, and vectors may be set in a tuple" None None None + raise (Reporting.err_typ l "only identifiers, fields, and vectors may be set in a tuple") in List.iter is_ok_in_tup ltups; LEXP_tup ltups - | Parse_ast.E_app ((Parse_ast.Id_aux (f, l') as f'), args) -> + | P.E_app ((P.Id_aux (f, l') as f'), args) -> begin match f with - | Parse_ast.Id(id) -> - (match List.map (to_ast_exp k_env def_ord) args with + | P.Id(id) -> + (match List.map (to_ast_exp ctx) args with | [E_aux (E_lit (L_aux (L_unit, _)), _)] -> LEXP_memory (to_ast_id f', []) | [E_aux (E_tuple exps,_)] -> LEXP_memory (to_ast_id f', exps) | args -> LEXP_memory(to_ast_id f', args)) - | _ -> typ_error l' "memory call on lefthand side of assignment must begin with an id" None None None + | _ -> raise (Reporting.err_typ l' "memory call on lefthand side of assignment must begin with an id") end - | Parse_ast.E_vector_append (exp1, exp2) -> - LEXP_vector_concat (to_ast_lexp k_env def_ord exp1 :: to_ast_lexp_vector_concat k_env def_ord exp2) - | Parse_ast.E_vector_access (vexp, exp) -> LEXP_vector (to_ast_lexp k_env def_ord vexp, to_ast_exp k_env def_ord exp) - | Parse_ast.E_vector_subrange (vexp, exp1, exp2) -> - LEXP_vector_range (to_ast_lexp k_env def_ord vexp, to_ast_exp k_env def_ord exp1, to_ast_exp k_env def_ord exp2) - | Parse_ast.E_field (fexp, id) -> LEXP_field (to_ast_lexp k_env def_ord fexp, to_ast_id id) - | _ -> typ_error l "Only identifiers, cast identifiers, vector accesses, vector slices, and fields can be on the lefthand side of an assignment" None None None + | P.E_vector_append (exp1, exp2) -> + LEXP_vector_concat (to_ast_lexp ctx exp1 :: to_ast_lexp_vector_concat ctx exp2) + | P.E_vector_access (vexp, exp) -> LEXP_vector (to_ast_lexp ctx vexp, to_ast_exp ctx exp) + | P.E_vector_subrange (vexp, exp1, exp2) -> + LEXP_vector_range (to_ast_lexp ctx vexp, to_ast_exp ctx exp1, to_ast_exp ctx exp2) + | P.E_field (fexp, id) -> LEXP_field (to_ast_lexp ctx fexp, to_ast_id id) + | _ -> raise (Reporting.err_typ l "Only identifiers, cast identifiers, vector accesses, vector slices, and fields can be on the lefthand side of an assignment") in LEXP_aux (lexp, (l, ())) -and to_ast_lexp_vector_concat k_env def_ord (Parse_ast.E_aux (exp_aux, l) as exp) = +and to_ast_lexp_vector_concat ctx (P.E_aux (exp_aux, l) as exp) = match exp_aux with - | Parse_ast.E_vector_append (exp1, exp2) -> - to_ast_lexp k_env def_ord exp1 :: to_ast_lexp_vector_concat k_env def_ord exp2 - | _ -> [to_ast_lexp k_env def_ord exp] + | P.E_vector_append (exp1, exp2) -> + to_ast_lexp ctx exp1 :: to_ast_lexp_vector_concat ctx exp2 + | _ -> [to_ast_lexp ctx exp] -and to_ast_case (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.Pat_aux(pex,l) : Parse_ast.pexp) : unit pexp = +and to_ast_case ctx (P.Pat_aux(pex,l) : P.pexp) : unit pexp = match pex with - | Parse_ast.Pat_exp(pat,exp) -> Pat_aux(Pat_exp(to_ast_pat k_env def_ord pat, to_ast_exp k_env def_ord exp),(l,())) - | Parse_ast.Pat_when(pat,guard,exp) -> - Pat_aux (Pat_when (to_ast_pat k_env def_ord pat, to_ast_exp k_env def_ord guard, to_ast_exp k_env def_ord exp), (l, ())) + | P.Pat_exp(pat,exp) -> Pat_aux(Pat_exp(to_ast_pat ctx pat, to_ast_exp ctx exp),(l,())) + | P.Pat_when(pat,guard,exp) -> + Pat_aux (Pat_when (to_ast_pat ctx pat, to_ast_exp ctx guard, to_ast_exp ctx exp), (l, ())) -and to_ast_fexps (fail_on_error:bool) (k_env:kind Envmap.t) (def_ord:order) (exps : Parse_ast.exp list) : unit fexp list option = +and to_ast_fexps (fail_on_error:bool) ctx (exps : P.exp list) : unit fexp list option = match exps with | [] -> Some [] - | fexp::exps -> let maybe_fexp,maybe_error = to_ast_record_try k_env def_ord fexp in + | fexp::exps -> let maybe_fexp,maybe_error = to_ast_record_try ctx fexp in (match maybe_fexp,maybe_error with | Some(fexp),None -> - (match (to_ast_fexps fail_on_error k_env def_ord exps) with + (match (to_ast_fexps fail_on_error ctx exps) with | Some(fexps) -> Some(fexp::fexps) | _ -> None) | None,Some(l,msg) -> if fail_on_error - then typ_error l msg None None None + then raise (Reporting.err_typ l msg) else None | _ -> None) -and to_ast_record_try (k_env:kind Envmap.t) (def_ord:order) (Parse_ast.E_aux(exp,l):Parse_ast.exp): unit fexp option * (l * string) option = +and to_ast_record_try ctx (P.E_aux(exp,l):P.exp): unit fexp option * (l * string) option = match exp with - | Parse_ast.E_app_infix(left,op,r) -> + | P.E_app_infix(left,op,r) -> (match left, op with - | Parse_ast.E_aux(Parse_ast.E_id(id),li), Parse_ast.Id_aux(Parse_ast.Id("="),leq) -> - Some(FE_aux(FE_Fexp(to_ast_id id, to_ast_exp k_env def_ord r), (l,()))),None - | Parse_ast.E_aux(_,li) , Parse_ast.Id_aux(Parse_ast.Id("="),leq) -> + | P.E_aux(P.E_id(id),li), P.Id_aux(P.Id("="),leq) -> + Some(FE_aux(FE_Fexp(to_ast_id id, to_ast_exp ctx r), (l,()))),None + | P.E_aux(_,li) , P.Id_aux(P.Id("="),leq) -> None,Some(li,"Expected an identifier to begin this field assignment") - | Parse_ast.E_aux(Parse_ast.E_id(id),li), Parse_ast.Id_aux(_,leq) -> + | P.E_aux(P.E_id(id),li), P.Id_aux(_,leq) -> None,Some(leq,"Expected a field assignment to be identifier = expression") - | Parse_ast.E_aux(_,li),Parse_ast.Id_aux(_,leq) -> + | P.E_aux(_,li),P.Id_aux(_,leq) -> None,Some(l,"Expected a field assignment to be identifier = expression")) | _ -> - None,Some(l, "Expected a field assignment to be identifier = expression") + None,Some(l, "Expected a field assignment to be identifier = expression") + +type 'a ctx_out = 'a * ctx -let to_ast_default (names, k_env, default_order) (default : Parse_ast.default_typing_spec) : default_spec envs_out = +let to_ast_default ctx (default : P.default_typing_spec) : default_spec ctx_out = match default with - | Parse_ast.DT_aux(Parse_ast.DT_order(k,o),l) -> - let k,k_typ = to_ast_kind k in - (match (k,o) with - | (K_aux(K_order, _), Parse_ast.ATyp_aux(Parse_ast.ATyp_inc,lo)) -> - let default_order = Ord_aux(Ord_inc,lo) in - DT_aux(DT_order default_order,l),(names,k_env,default_order) - | (K_aux(K_order, _), Parse_ast.ATyp_aux(Parse_ast.ATyp_dec,lo)) -> - let default_order = Ord_aux(Ord_dec,lo) in - DT_aux(DT_order default_order,l),(names,k_env,default_order) - | _ -> typ_error l "Inc and Dec must have kind Order" None None None) - -let to_ast_spec (names,k_env,default_order) (val_:Parse_ast.val_spec) : (unit val_spec) envs_out = + | P.DT_aux(P.DT_order(k,o),l) -> + let k = to_ast_kind k in + match (k,o) with + | K_aux(K_order, _), P.ATyp_aux(P.ATyp_inc,lo) -> + let default_order = Ord_aux(Ord_inc,lo) in + DT_aux(DT_order default_order,l),ctx + | K_aux(K_order, _), P.ATyp_aux(P.ATyp_dec,lo) -> + let default_order = Ord_aux(Ord_dec,lo) in + DT_aux(DT_order default_order,l),ctx + | _ -> raise (Reporting.err_typ l "Inc and Dec must have kind Order") + +let to_ast_spec ctx (val_:P.val_spec) : (unit val_spec) ctx_out = match val_ with - | Parse_ast.VS_aux(vs,l) -> + | P.VS_aux(vs,l) -> (match vs with - | Parse_ast.VS_val_spec(ts,id,ext,is_cast) -> - let typsch,_,_ = to_ast_typschm k_env default_order ts in - VS_aux(VS_val_spec(typsch,to_ast_id id,ext,is_cast),(l,())),(names,k_env,default_order)) + | P.VS_val_spec(ts,id,ext,is_cast) -> + let typschm, _ = to_ast_typschm ctx ts in + VS_aux(VS_val_spec(typschm,to_ast_id id,ext,is_cast),(l,())),ctx) -let to_ast_namescm (Parse_ast.Name_sect_aux(ns,l)) = +let to_ast_namescm (P.Name_sect_aux(ns,l)) = Name_sect_aux( (match ns with - | Parse_ast.Name_sect_none -> Name_sect_none - | Parse_ast.Name_sect_some(s) -> Name_sect_some(s) + | P.Name_sect_none -> Name_sect_none + | P.Name_sect_some(s) -> Name_sect_some(s) ),l) -let rec to_ast_range (Parse_ast.BF_aux(r,l)) = (* TODO add check that ranges are sensible for some definition of sensible *) +let rec to_ast_range (P.BF_aux(r,l)) = (* TODO add check that ranges are sensible for some definition of sensible *) BF_aux( (match r with - | Parse_ast.BF_single(i) -> BF_single(i) - | Parse_ast.BF_range(i1,i2) -> BF_range(i1,i2) - | Parse_ast.BF_concat(ir1,ir2) -> BF_concat( to_ast_range ir1, to_ast_range ir2)), + | P.BF_single(i) -> BF_single(i) + | P.BF_range(i1,i2) -> BF_range(i1,i2) + | P.BF_concat(ir1,ir2) -> BF_concat( to_ast_range ir1, to_ast_range ir2)), l) -let to_ast_type_union k_env default_order (Parse_ast.Tu_aux (Parse_ast.Tu_ty_id (atyp, id), l)) = - let typ = to_ast_typ k_env default_order atyp in +let to_ast_type_union ctx (P.Tu_aux (P.Tu_ty_id (atyp, id), l)) = + let typ = to_ast_typ ctx atyp in Tu_aux (Tu_ty_id (typ, to_ast_id id), l) -let to_ast_typedef (names,k_env,def_ord) (td:Parse_ast.type_def) : (unit type_def) envs_out = - match td with - | Parse_ast.TD_aux(td,l) -> - (match td with - | Parse_ast.TD_abbrev(id,name_scm_opt,typschm) -> - let id = to_ast_id id in - let key = id_to_string id in - let typschm,k_env,_ = to_ast_typschm k_env def_ord typschm in - let td_abrv = TD_aux(TD_abbrev(id,to_ast_namescm name_scm_opt,typschm),(l,())) in - let typ = (match typschm with - | TypSchm_aux(TypSchm_ts(tq,typ), _) -> - begin match (typquant_to_quantkinds k_env tq) with - | [] -> {k = K_Typ} - | typs -> {k= K_Lam(typs,{k=K_Typ})} - end) in - td_abrv,(names,Envmap.insert k_env (key,typ),def_ord) - | Parse_ast.TD_record(id,name_scm_opt,typq,fields,_) -> - let id = to_ast_id id in - let key = id_to_string id in - let typq,k_env,_ = to_ast_typquant k_env typq in - let fields = List.map (fun (atyp,id) -> (to_ast_typ k_env def_ord atyp),(to_ast_id id)) fields in (* Add check that all arms have unique names locally *) - let td_rec = TD_aux(TD_record(id,to_ast_namescm name_scm_opt,typq,fields,false),(l,())) in - let typ = (match (typquant_to_quantkinds k_env typq) with - | [ ] -> {k = K_Typ} - | typs -> {k = K_Lam(typs,{k=K_Typ})}) in - td_rec, (names,Envmap.insert k_env (key,typ), def_ord) - | Parse_ast.TD_variant(id,name_scm_opt,typq,arms,_) -> - let id = to_ast_id id in - let key = id_to_string id in - let typq,k_env,_ = to_ast_typquant k_env typq in - let arms = List.map (to_ast_type_union k_env def_ord) arms in (* Add check that all arms have unique names *) - let td_var = TD_aux(TD_variant(id,to_ast_namescm name_scm_opt,typq,arms,false),(l,())) in - let typ = (match (typquant_to_quantkinds k_env typq) with - | [ ] -> {k = K_Typ} - | typs -> {k = K_Lam(typs,{k=K_Typ})}) in - td_var, (names,Envmap.insert k_env (key,typ), def_ord) - | Parse_ast.TD_enum(id,name_scm_opt,enums,_) -> - let id = to_ast_id id in - let key = id_to_string id in - let enums = List.map to_ast_id enums in - let keys = List.map id_to_string enums in - let td_enum = TD_aux(TD_enum(id,to_ast_namescm name_scm_opt,enums,false),(l,())) in (* Add check that all enums have unique names *) - let k_env = List.fold_right (fun k k_env -> Envmap.insert k_env (k,{k=K_Nat})) keys (Envmap.insert k_env (key,{k=K_Typ})) in - td_enum, (names,k_env,def_ord) - | Parse_ast.TD_bitfield(id,typ,ranges) -> - let id = to_ast_id id in - let key = id_to_string id in - let typ = to_ast_typ k_env def_ord typ in - let ranges = List.map (fun (id, range) -> (to_ast_id id, to_ast_range range)) ranges in - TD_aux(TD_bitfield(id,typ,ranges),(l,())), (names,Envmap.insert k_env (key, {k=K_Typ}),def_ord)) - -let to_ast_kdef (names, k_env, def_ord) (td:Parse_ast.kind_def) : unit kind_def = +let kopt_kind (KOpt_aux (aux, l)) = + match aux with + | KOpt_none _ -> K_aux (K_int, gen_loc l) + | KOpt_kind (k, _) -> k + +let add_constructor id typq ctx = + let kinds = List.map (fun kopt -> unaux_kind (kopt_kind kopt)) (quant_kopts typq) in + { ctx with type_constructors = Bindings.add id kinds ctx.type_constructors } + +let to_ast_typedef ctx (P.TD_aux (aux, l) : P.type_def) : unit type_def ctx_out = + let aux, ctx = match aux with + | P.TD_abbrev (id, namescm_opt, P.TypSchm_aux (P.TypSchm_ts (typq, typ), l)) -> + let id = to_ast_id id in + let typq, typq_ctx = to_ast_typquant ctx typq in + let typ = to_ast_typ typq_ctx typ in + TD_abbrev (id, to_ast_namescm namescm_opt, TypSchm_aux (TypSchm_ts (typq, typ), l)), + add_constructor id typq ctx + + | P.TD_record (id, namescm_opt, typq, fields, _) -> + let id = to_ast_id id in + let typq, typq_ctx = to_ast_typquant ctx typq in + let fields = List.map (fun (atyp, id) -> to_ast_typ typq_ctx atyp, to_ast_id id) fields in + TD_record (id, to_ast_namescm namescm_opt, typq, fields, false), + add_constructor id typq ctx + + | P.TD_variant (id, namescm_opt, typq, arms, _) -> + let id = to_ast_id id in + let typq, typq_ctx = to_ast_typquant ctx typq in + let arms = List.map (to_ast_type_union typq_ctx) arms in + TD_variant (id, to_ast_namescm namescm_opt, typq, arms, false), + add_constructor id typq ctx + + | P.TD_enum (id, namescm_opt, enums, _) -> + let id = to_ast_id id in + let enums = List.map to_ast_id enums in + TD_enum (id, to_ast_namescm namescm_opt, enums, false), + { ctx with type_constructors = Bindings.add id [] ctx.type_constructors } + + | P.TD_bitfield (id, typ, ranges) -> + let id = to_ast_id id in + let typ = to_ast_typ ctx typ in + let ranges = List.map (fun (id, range) -> (to_ast_id id, to_ast_range range)) ranges in + TD_bitfield (id, typ, ranges), + { ctx with type_constructors = Bindings.add id [] ctx.type_constructors } + in + TD_aux (aux, (l, ())), ctx + +let to_ast_kdef ctx (td:P.kind_def) : unit kind_def = match td with - | Parse_ast.KD_aux (Parse_ast.KD_nabbrev (kind, id, name_scm_opt, atyp), l) -> + | P.KD_aux (P.KD_nabbrev (kind, id, name_scm_opt, atyp), l) -> let id = to_ast_id id in - let (kind, k) = to_ast_kind kind in - KD_aux (KD_nabbrev (kind, id, to_ast_namescm name_scm_opt, to_ast_nexp k_env atyp), (l, ())) + let kind = to_ast_kind kind in + KD_aux (KD_nabbrev (kind, id, to_ast_namescm name_scm_opt, to_ast_nexp ctx atyp), (l, ())) -let to_ast_rec (Parse_ast.Rec_aux(r,l): Parse_ast.rec_opt) : rec_opt = +let to_ast_rec (P.Rec_aux(r,l): P.rec_opt) : rec_opt = Rec_aux((match r with - | Parse_ast.Rec_nonrec -> Rec_nonrec - | Parse_ast.Rec_rec -> Rec_rec + | P.Rec_nonrec -> Rec_nonrec + | P.Rec_rec -> Rec_rec ),l) -let to_ast_tannot_opt (k_env:kind Envmap.t) (def_ord:order) (Parse_ast.Typ_annot_opt_aux(tp,l)):tannot_opt * kind Envmap.t * kind Envmap.t= +let to_ast_tannot_opt ctx (P.Typ_annot_opt_aux(tp,l)) : tannot_opt ctx_out = match tp with - | Parse_ast.Typ_annot_opt_none -> - Typ_annot_opt_aux (Typ_annot_opt_none, l), k_env, Envmap.empty - | Parse_ast.Typ_annot_opt_some(tq,typ) -> - let typq,k_env,k_local = to_ast_typquant k_env tq in - Typ_annot_opt_aux(Typ_annot_opt_some(typq,to_ast_typ k_env def_ord typ),l),k_env,k_local + | P.Typ_annot_opt_none -> + Typ_annot_opt_aux (Typ_annot_opt_none, l), ctx + | P.Typ_annot_opt_some(tq,typ) -> + let typq, ctx = to_ast_typquant ctx tq in + Typ_annot_opt_aux (Typ_annot_opt_some(typq,to_ast_typ ctx typ),l),ctx -let to_ast_typschm_opt (k_env:kind Envmap.t) (def_ord:order) (Parse_ast.TypSchm_opt_aux(aux,l)) : tannot_opt * kind Envmap.t * kind Envmap.t = +let to_ast_typschm_opt ctx (P.TypSchm_opt_aux(aux,l)) : tannot_opt ctx_out = match aux with - | Parse_ast.TypSchm_opt_none -> - Typ_annot_opt_aux (Typ_annot_opt_none, l), k_env, Envmap.empty - | Parse_ast.TypSchm_opt_some (Parse_ast.TypSchm_aux (Parse_ast.TypSchm_ts (tq, typ), l)) -> - let typq, k_env, k_local = to_ast_typquant k_env tq in - Typ_annot_opt_aux (Typ_annot_opt_some (typq, to_ast_typ k_env def_ord typ), l), k_env, k_local + | P.TypSchm_opt_none -> + Typ_annot_opt_aux (Typ_annot_opt_none, l), ctx + | P.TypSchm_opt_some (P.TypSchm_aux (P.TypSchm_ts (tq, typ), l)) -> + let typq, ctx = to_ast_typquant ctx tq in + Typ_annot_opt_aux (Typ_annot_opt_some (typq, to_ast_typ ctx typ), l), ctx - -let to_ast_effects_opt (k_env : kind Envmap.t) (Parse_ast.Effect_opt_aux(e,l)) : effect_opt = +let to_ast_effects_opt (P.Effect_opt_aux(e,l)) : effect_opt = match e with - | Parse_ast.Effect_opt_pure -> Effect_opt_aux(Effect_opt_pure,l) - | Parse_ast.Effect_opt_effect(typ) -> Effect_opt_aux(Effect_opt_effect(to_ast_effects k_env typ),l) + | P.Effect_opt_pure -> Effect_opt_aux(Effect_opt_pure,l) + | P.Effect_opt_effect(typ) -> Effect_opt_aux(Effect_opt_effect(to_ast_effects typ),l) -let to_ast_funcl (names,k_env,def_ord) (Parse_ast.FCL_aux(fcl,l) : Parse_ast.funcl) : (unit funcl) = - (*let _ = Printf.eprintf "to_ast_funcl\n" in*) +let to_ast_funcl ctx (P.FCL_aux(fcl,l) : P.funcl) : (unit funcl) = match fcl with - | Parse_ast.FCL_Funcl(id,pexp) -> - FCL_aux(FCL_Funcl(to_ast_id id, to_ast_case k_env def_ord pexp),(l,())) + | P.FCL_Funcl(id,pexp) -> + FCL_aux(FCL_Funcl(to_ast_id id, to_ast_case ctx pexp),(l,())) -let to_ast_fundef (names,k_env,def_ord) (Parse_ast.FD_aux(fd,l):Parse_ast.fundef) : (unit fundef) envs_out = +let to_ast_fundef ctx (P.FD_aux(fd,l):P.fundef) : unit fundef = match fd with - | Parse_ast.FD_function(rec_opt,tannot_opt,effects_opt,funcls) -> - (*let _ = Printf.eprintf "to_ast_fundef\n" in*) - let tannot_opt, k_env,_ = to_ast_tannot_opt k_env def_ord tannot_opt in - FD_aux(FD_function(to_ast_rec rec_opt, tannot_opt, to_ast_effects_opt k_env effects_opt, List.map (to_ast_funcl (names, k_env, def_ord)) funcls), (l,())), (names,k_env,def_ord) + | P.FD_function(rec_opt,tannot_opt,effects_opt,funcls) -> + let tannot_opt, ctx = to_ast_tannot_opt ctx tannot_opt in + FD_aux(FD_function(to_ast_rec rec_opt, tannot_opt, to_ast_effects_opt effects_opt, List.map (to_ast_funcl ctx) funcls), (l,())) -let rec to_ast_mpat k_env def_ord (Parse_ast.MP_aux(mpat,l)) = +let rec to_ast_mpat ctx (P.MP_aux(mpat,l)) = MP_aux( (match mpat with - | Parse_ast.MP_lit(lit) -> MP_lit(to_ast_lit lit) - | Parse_ast.MP_id(id) -> MP_id(to_ast_id id) - | Parse_ast.MP_as (mpat, id) -> MP_as (to_ast_mpat k_env def_ord mpat, to_ast_id id) - | Parse_ast.MP_app(id,mpats) -> + | P.MP_lit(lit) -> MP_lit(to_ast_lit lit) + | P.MP_id(id) -> MP_id(to_ast_id id) + | P.MP_as (mpat, id) -> MP_as (to_ast_mpat ctx mpat, to_ast_id id) + | P.MP_app(id,mpats) -> if mpats = [] then MP_id (to_ast_id id) - else MP_app(to_ast_id id, List.map (to_ast_mpat k_env def_ord) mpats) - | Parse_ast.MP_record(mfpats,_) -> + else MP_app(to_ast_id id, List.map (to_ast_mpat ctx) mpats) + | P.MP_record(mfpats,_) -> MP_record(List.map - (fun (Parse_ast.MFP_aux(Parse_ast.MFP_mpat(id,mfp),l)) -> - MFP_aux(MFP_mpat(to_ast_id id, to_ast_mpat k_env def_ord mfp),(l,()))) + (fun (P.MFP_aux(P.MFP_mpat(id,mfp),l)) -> + MFP_aux(MFP_mpat(to_ast_id id, to_ast_mpat ctx mfp),(l,()))) mfpats, false) - | Parse_ast.MP_vector(mpats) -> MP_vector(List.map (to_ast_mpat k_env def_ord) mpats) - | Parse_ast.MP_vector_concat(mpats) -> MP_vector_concat(List.map (to_ast_mpat k_env def_ord) mpats) - | Parse_ast.MP_tup(mpats) -> MP_tup(List.map (to_ast_mpat k_env def_ord) mpats) - | Parse_ast.MP_list(mpats) -> MP_list(List.map (to_ast_mpat k_env def_ord) mpats) - | Parse_ast.MP_cons(pat1, pat2) -> MP_cons (to_ast_mpat k_env def_ord pat1, to_ast_mpat k_env def_ord pat2) - | Parse_ast.MP_string_append pats -> MP_string_append (List.map (to_ast_mpat k_env def_ord) pats) - | Parse_ast.MP_typ (mpat, typ) -> MP_typ (to_ast_mpat k_env def_ord mpat, to_ast_typ k_env def_ord typ) + | P.MP_vector(mpats) -> MP_vector(List.map (to_ast_mpat ctx) mpats) + | P.MP_vector_concat(mpats) -> MP_vector_concat(List.map (to_ast_mpat ctx) mpats) + | P.MP_tup(mpats) -> MP_tup(List.map (to_ast_mpat ctx) mpats) + | P.MP_list(mpats) -> MP_list(List.map (to_ast_mpat ctx) mpats) + | P.MP_cons(pat1, pat2) -> MP_cons (to_ast_mpat ctx pat1, to_ast_mpat ctx pat2) + | P.MP_string_append pats -> MP_string_append (List.map (to_ast_mpat ctx) pats) + | P.MP_typ (mpat, typ) -> MP_typ (to_ast_mpat ctx mpat, to_ast_typ ctx typ) ), (l,())) - -let to_ast_mpexp (names,k_env,def_ord) (Parse_ast.MPat_aux(mpexp, l)) = +let to_ast_mpexp ctx (P.MPat_aux(mpexp, l)) = match mpexp with - | Parse_ast.MPat_pat mpat -> MPat_aux (MPat_pat (to_ast_mpat k_env def_ord mpat), (l, ())) - | Parse_ast.MPat_when (mpat, exp) -> MPat_aux (MPat_when (to_ast_mpat k_env def_ord mpat, to_ast_exp k_env def_ord exp), (l, ())) + | P.MPat_pat mpat -> MPat_aux (MPat_pat (to_ast_mpat ctx mpat), (l, ())) + | P.MPat_when (mpat, exp) -> MPat_aux (MPat_when (to_ast_mpat ctx mpat, to_ast_exp ctx exp), (l, ())) -let to_ast_mapcl (names,k_env,def_ord) (Parse_ast.MCL_aux(mapcl, l)) = +let to_ast_mapcl ctx (P.MCL_aux(mapcl, l)) = match mapcl with - | Parse_ast.MCL_bidir (mpexp1, mpexp2) -> MCL_aux (MCL_bidir (to_ast_mpexp (names,k_env,def_ord) mpexp1, to_ast_mpexp (names,k_env,def_ord) mpexp2), (l, ())) - | Parse_ast.MCL_forwards (mpexp, exp) -> MCL_aux (MCL_forwards (to_ast_mpexp (names,k_env,def_ord) mpexp, to_ast_exp k_env def_ord exp), (l, ())) - | Parse_ast.MCL_backwards (mpexp, exp) -> MCL_aux (MCL_backwards (to_ast_mpexp (names,k_env,def_ord) mpexp, to_ast_exp k_env def_ord exp), (l, ())) + | P.MCL_bidir (mpexp1, mpexp2) -> MCL_aux (MCL_bidir (to_ast_mpexp ctx mpexp1, to_ast_mpexp ctx mpexp2), (l, ())) + | P.MCL_forwards (mpexp, exp) -> MCL_aux (MCL_forwards (to_ast_mpexp ctx mpexp, to_ast_exp ctx exp), (l, ())) + | P.MCL_backwards (mpexp, exp) -> MCL_aux (MCL_backwards (to_ast_mpexp ctx mpexp, to_ast_exp ctx exp), (l, ())) -let to_ast_mapdef (names,k_env,def_ord) (Parse_ast.MD_aux(md,l):Parse_ast.mapdef) : (unit mapdef) envs_out = +let to_ast_mapdef ctx (P.MD_aux(md,l):P.mapdef) : unit mapdef = match md with - | Parse_ast.MD_mapping(id, typschm_opt, mapcls) -> - let tannot_opt, k_env, _ = to_ast_typschm_opt k_env def_ord typschm_opt in - MD_aux(MD_mapping(to_ast_id id, tannot_opt, List.map (to_ast_mapcl (names,k_env,def_ord)) mapcls), (l,())), (names,k_env,def_ord) - -type def_progress = - No_def - | Def_place_holder of id * Parse_ast.l - | Finished of unit def - -type partial_def = ((unit def) * bool) ref * kind Envmap.t - -let rec def_in_progress (id : id) (partial_defs : (id * partial_def) list) : partial_def option = - match partial_defs with - | [] -> None - | (n,pd)::defs -> - (match n,id with - | Id_aux(Id(n),_), Id_aux(Id(i),_) -> if (n = i) then Some(pd) else def_in_progress id defs - | _,_ -> def_in_progress id defs) - -let to_ast_alias_spec k_env def_ord (Parse_ast.E_aux(e,le)) = - AL_aux( - (match e with - | Parse_ast.E_field(Parse_ast.E_aux(Parse_ast.E_id id,li), field) -> - AL_subreg(RI_aux(RI_id (to_ast_id id),(li,())),to_ast_id field) - | Parse_ast.E_vector_access(Parse_ast.E_aux(Parse_ast.E_id id,li),range) -> - AL_bit(RI_aux(RI_id (to_ast_id id),(li,())),to_ast_exp k_env def_ord range) - | Parse_ast.E_vector_subrange(Parse_ast.E_aux(Parse_ast.E_id id,li),base,stop) -> - AL_slice(RI_aux(RI_id (to_ast_id id),(li,())),to_ast_exp k_env def_ord base,to_ast_exp k_env def_ord stop) - | Parse_ast.E_vector_append(Parse_ast.E_aux(Parse_ast.E_id first,lf), - Parse_ast.E_aux(Parse_ast.E_id second,ls)) -> - AL_concat(RI_aux(RI_id (to_ast_id first),(lf,())), - RI_aux(RI_id (to_ast_id second),(ls,()))) - | _ -> raise (Reporting.err_unreachable le __POS__ "Found an expression not supported by parser in to_ast_alias_spec") - ), (le,())) - -let to_ast_dec (names,k_env,def_ord) (Parse_ast.DEC_aux(regdec,l)) = - DEC_aux( - (match regdec with - | Parse_ast.DEC_reg(typ,id) -> - DEC_reg(to_ast_typ k_env def_ord typ,to_ast_id id) - | Parse_ast.DEC_config(id,typ,exp) -> - DEC_config(to_ast_id id,to_ast_typ k_env def_ord typ,to_ast_exp k_env def_ord exp) - | Parse_ast.DEC_alias(id,e) -> - DEC_alias(to_ast_id id,to_ast_alias_spec k_env def_ord e) - | Parse_ast.DEC_typ_alias(typ,id,e) -> - DEC_typ_alias(to_ast_typ k_env def_ord typ,to_ast_id id,to_ast_alias_spec k_env def_ord e) - ),(l,())) + | P.MD_mapping(id, typschm_opt, mapcls) -> + let tannot_opt, ctx = to_ast_typschm_opt ctx typschm_opt in + MD_aux(MD_mapping(to_ast_id id, tannot_opt, List.map (to_ast_mapcl ctx) mapcls), (l,())) + +let to_ast_alias_spec ctx (P.E_aux(e, l)) = + AL_aux((match e with + | P.E_field (P.E_aux (P.E_id id, li), field) -> + AL_subreg (RI_aux (RI_id (to_ast_id id), (li, ())), to_ast_id field) + | P.E_vector_access (P.E_aux (P.E_id id, li), range) -> + AL_bit (RI_aux (RI_id (to_ast_id id), (li, ())), to_ast_exp ctx range) + | P.E_vector_subrange(P.E_aux(P.E_id id,li),base,stop) -> + AL_slice (RI_aux (RI_id (to_ast_id id), (li,())), to_ast_exp ctx base, to_ast_exp ctx stop) + | P.E_vector_append (P.E_aux (P.E_id first, lf), P.E_aux (P.E_id second, ls)) -> + AL_concat (RI_aux (RI_id (to_ast_id first), (lf, ())), + RI_aux (RI_id (to_ast_id second), (ls, ()))) + | _ -> raise (Reporting.err_unreachable l __POS__ "Found an expression not supported by parser in to_ast_alias_spec") + ), (l, ())) + +let to_ast_dec ctx (P.DEC_aux(regdec,l)) = + DEC_aux((match regdec with + | P.DEC_reg (typ, id) -> + DEC_reg (to_ast_typ ctx typ, to_ast_id id) + | P.DEC_config (id, typ, exp) -> + DEC_config (to_ast_id id, to_ast_typ ctx typ, to_ast_exp ctx exp) + | P.DEC_alias (id,e) -> + DEC_alias (to_ast_id id, to_ast_alias_spec ctx e) + | P.DEC_typ_alias (typ,id,e) -> + DEC_typ_alias (to_ast_typ ctx typ, to_ast_id id, to_ast_alias_spec ctx e) + ),(l,())) + +let to_ast_scattered ctx (P.SD_aux (aux, l)) = + let aux, ctx = match aux with + | P.SD_function (rec_opt, tannot_opt, effect_opt, id) -> + let tannot_opt, _ = to_ast_tannot_opt ctx tannot_opt in + let effect_opt = to_ast_effects_opt effect_opt in + SD_function (to_ast_rec rec_opt, tannot_opt, effect_opt, to_ast_id id), ctx + | P.SD_funcl funcl -> + SD_funcl (to_ast_funcl ctx funcl), ctx + | P.SD_variant (id, namescm_opt, typq) -> + let id = to_ast_id id in + let typq, typq_ctx = to_ast_typquant ctx typq in + SD_variant (id, to_ast_namescm namescm_opt, typq), + add_constructor id typq { ctx with scattereds = Bindings.add id typq_ctx ctx.scattereds } + | P.SD_unioncl (id, tu) -> + let id = to_ast_id id in + begin match Bindings.find_opt id ctx.scattereds with + | Some typq_ctx -> + let tu = to_ast_type_union typq_ctx tu in + SD_unioncl (id, tu), ctx + | None -> raise (Reporting.err_typ l ("No scattered union declaration found for " ^ string_of_id id)) + end + | P.SD_end id -> SD_end (to_ast_id id), ctx + | P.SD_mapping (id, tannot_opt) -> + let id = to_ast_id id in + let tannot_opt, _ = to_ast_tannot_opt ctx tannot_opt in + SD_mapping (id, tannot_opt), ctx + | P.SD_mapcl (id, mapcl) -> + let id = to_ast_id id in + let mapcl = to_ast_mapcl ctx mapcl in + SD_mapcl (id, mapcl), ctx + in + SD_aux (aux, (l, ())), ctx let to_ast_prec = function - | Parse_ast.Infix -> Infix - | Parse_ast.InfixL -> InfixL - | Parse_ast.InfixR -> InfixR + | P.Infix -> Infix + | P.InfixL -> InfixL + | P.InfixR -> InfixR -let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out * (id * partial_def) list = - let envs = (names,k_env,def_ord) in +let to_ast_def ctx def : unit def ctx_out = match def with - | Parse_ast.DEF_overload(id,ids) -> - ((Finished(DEF_overload(to_ast_id id, List.map to_ast_id ids))),envs),partial_defs - | Parse_ast.DEF_fixity (prec, n, op) -> - ((Finished(DEF_fixity (to_ast_prec prec, n, to_ast_id op)),envs),partial_defs) - | Parse_ast.DEF_kind(k_def) -> - let kd = to_ast_kdef envs k_def in - ((Finished(DEF_kind(kd))),envs),partial_defs - | Parse_ast.DEF_type(t_def) -> - let td,envs = to_ast_typedef envs t_def in - ((Finished(DEF_type(td))),envs),partial_defs - | Parse_ast.DEF_fundef(f_def) -> - let fd,envs = to_ast_fundef envs f_def in - ((Finished(DEF_fundef(fd))),envs),partial_defs - | Parse_ast.DEF_mapdef(m_def) -> - let md, envs = to_ast_mapdef envs m_def in - ((Finished(DEF_mapdef(md))),envs),partial_defs - | Parse_ast.DEF_val(lbind) -> - let lb = to_ast_letbind k_env def_ord lbind in - ((Finished(DEF_val(lb))),envs),partial_defs - | Parse_ast.DEF_spec(val_spec) -> - let vs,envs = to_ast_spec envs val_spec in - ((Finished(DEF_spec(vs))),envs),partial_defs - | Parse_ast.DEF_default(typ_spec) -> - let default,envs = to_ast_default envs typ_spec in - ((Finished(DEF_default(default))),envs),partial_defs - | Parse_ast.DEF_reg_dec(dec) -> - let d = to_ast_dec envs dec in - ((Finished(DEF_reg_dec(d))),envs),partial_defs - | Parse_ast.DEF_pragma (pragma, arg, l) -> - ((Finished(DEF_pragma (pragma, arg, l))), envs), partial_defs - | Parse_ast.DEF_internal_mutrec _ -> + | P.DEF_overload (id, ids) -> + DEF_overload (to_ast_id id, List.map to_ast_id ids), ctx + | P.DEF_fixity (prec, n, op) -> + DEF_fixity (to_ast_prec prec, n, to_ast_id op), ctx + | P.DEF_kind k_def -> + let kd = to_ast_kdef ctx k_def in + DEF_kind kd, ctx + | P.DEF_type(t_def) -> + let td, ctx = to_ast_typedef ctx t_def in + DEF_type td, ctx + | P.DEF_fundef(f_def) -> + let fd = to_ast_fundef ctx f_def in + DEF_fundef fd, ctx + | P.DEF_mapdef(m_def) -> + let md = to_ast_mapdef ctx m_def in + DEF_mapdef md, ctx + | P.DEF_val(lbind) -> + let lb = to_ast_letbind ctx lbind in + DEF_val lb, ctx + | P.DEF_spec(val_spec) -> + let vs,ctx = to_ast_spec ctx val_spec in + DEF_spec vs, ctx + | P.DEF_default(typ_spec) -> + let default,ctx = to_ast_default ctx typ_spec in + DEF_default default, ctx + | P.DEF_reg_dec dec -> + let d = to_ast_dec ctx dec in + DEF_reg_dec d, ctx + | P.DEF_pragma (pragma, arg, l) -> + DEF_pragma (pragma, arg, l), ctx + | P.DEF_internal_mutrec _ -> (* Should never occur because of remove_mutrec *) - typ_error Parse_ast.Unknown "Internal mutual block found when processing scattered defs" None None None - | Parse_ast.DEF_scattered(Parse_ast.SD_aux(sd,l)) -> - (match sd with - | Parse_ast.SD_scattered_function(rec_opt, tannot_opt, effects_opt, id) -> - let rec_opt = to_ast_rec rec_opt in - let unit,k_env',k_local = to_ast_tannot_opt k_env def_ord tannot_opt in - let effects_opt = to_ast_effects_opt k_env' effects_opt in - let id = to_ast_id id in - (match (def_in_progress id partial_defs) with - | None -> let partial_def = ref ((DEF_fundef(FD_aux(FD_function(rec_opt,unit,effects_opt,[]),(l,())))),false) in - (No_def,envs),((id,(partial_def,k_local))::partial_defs) - | Some(d,k) -> typ_error l "Scattered function definition header name already in use by scattered definition" (Some id) None None) - | Parse_ast.SD_scattered_mapping (id, tannot_opt) -> - let id = to_ast_id id in - let unit, k_env ,k_local = to_ast_tannot_opt k_env def_ord tannot_opt in - (match (def_in_progress id partial_defs) with - | None -> let partial_def = ref ((DEF_mapdef(MD_aux(MD_mapping(id, unit, []), (l, ())))), false) in - (No_def,envs),((id,(partial_def,k_local))::partial_defs) - | Some(d,k) -> typ_error l "Scattered mapping definition header name already in use by scattered definition" (Some id) None None) - - | Parse_ast.SD_scattered_mapcl (id, mapcl) -> - let id = to_ast_id id in - (match (def_in_progress id partial_defs) with - | None -> typ_error l "Scattered mapping definition clause does not match any existing mapping definition headers" (Some id) None None - | Some (d, k) -> - (match !d with - | DEF_mapdef(MD_aux(MD_mapping(_,tannot_opt, mcls),ml)),false -> - let (MCL_aux (mapcl_aux, _)) = to_ast_mapcl (names,k_env,def_ord) mapcl in - d := DEF_mapdef(MD_aux(MD_mapping(id, tannot_opt, mcls @ [MCL_aux (mapcl_aux, (l, ()))]), ml)), false; - (No_def,envs),partial_defs - | _, true -> typ_error l "Scattered mapping definition clause extends ended definition" (Some id) None None - | _ -> typ_error l "Scattered mapping definition doesn't match existing definition header" (Some id) None None)) - - | Parse_ast.SD_scattered_funcl(funcl) -> - (match funcl with - | Parse_ast.FCL_aux(Parse_ast.FCL_Funcl(id,_),_) -> - let id = to_ast_id id in - (match (def_in_progress id partial_defs) with - | None -> typ_error l "Scattered function definition clause does not match any existing function definition headers" (Some id) None None - | Some(d,k) -> - (* let _ = Printf.eprintf "SD_scattered_funcl processing\n" in - let _ = Envmap.iter (fun v' k -> P rintf.eprintf "%s -> %s\n" v' (kind_to_string k)) k in - let _ = Envmap.iter (fun v' k -> Prin tf.eprintf "%s -> %s\n" v' (kind_to_string k) ) (Envmap.union k k_env) in *) - (match !d with - | DEF_fundef(FD_aux(FD_function(r,t,e,fcls),fl)),false -> - let (FCL_aux (funcl_aux, _)) = to_ast_funcl (names,Envmap.union k k_env,def_ord) funcl in - d:= DEF_fundef(FD_aux(FD_function(r,t,e,fcls@[FCL_aux (funcl_aux, (l, ()))]),fl)),false; - (No_def,envs),partial_defs - | _,true -> typ_error l "Scattered function definition clauses extends ended definition" (Some id) None None - | _ -> typ_error l "Scattered function definition clause matches an existing scattered type definition header" (Some id) None None))) - | Parse_ast.SD_scattered_variant(id,naming_scheme_opt,typquant) -> - let id = to_ast_id id in - let name = to_ast_namescm naming_scheme_opt in - let typq, k_env',_ = to_ast_typquant k_env typquant in - let kind = (match (typquant_to_quantkinds k_env' typq) with - | [ ] -> {k = K_Typ} - | typs -> {k = K_Lam(typs,{k=K_Typ})}) in - (match (def_in_progress id partial_defs) with - | None -> let partial_def = ref ((DEF_type(TD_aux(TD_variant(id,name,typq,[],false),(l,())))),false) in - (Def_place_holder(id,l),(names,Envmap.insert k_env ((id_to_string id),kind),def_ord)),(id,(partial_def,k_env'))::partial_defs - | Some(d,k) -> typ_error l "Scattered type definition header name already in use by scattered definition" (Some id) None None) - | Parse_ast.SD_scattered_unioncl(id,tu) -> - let id = to_ast_id id in - (match (def_in_progress id partial_defs) with - | None -> typ_error l "Scattered type definition clause does not match any existing type definition headers" (Some id) None None - | Some(d,k) -> - (match !d with - | DEF_type(TD_aux(TD_variant(id,name,typq,arms,false),tl)), false -> - d:= DEF_type(TD_aux(TD_variant(id,name,typq,arms@[to_ast_type_union k def_ord tu],false),tl)),false; - (No_def,envs),partial_defs - | _,true -> typ_error l "Scattered type definition clause extends ended definition" (Some id) None None - | _ -> typ_error l "Scattered type definition clause matches an existing scattered function definition header" (Some id) None None)) - | Parse_ast.SD_scattered_end(id) -> - let id = to_ast_id id in - (match (def_in_progress id partial_defs) with - | None -> typ_error l "Scattered definition end does not match any open scattered definitions" (Some id) None None - | Some(d,k) -> - (match !d with - | (DEF_type(_) as def),false -> - d:= (def,true); - (No_def,envs),partial_defs - | (DEF_fundef(_) as def),false -> - d:= (def,true); - ((Finished def), envs),partial_defs - | (DEF_mapdef(_) as def),false -> - d := (def,true); - ((Finished def), envs),partial_defs - | _, true -> - typ_error l "Scattered definition ended multiple times" (Some id) None None - | _ -> raise (Reporting.err_unreachable l __POS__ "Something in partial_defs other than fundef and type")))) - -let rec to_ast_defs_helper envs partial_defs = function - | [] -> ([],envs,partial_defs) - | d::ds -> let ((d', envs), partial_defs) = to_ast_def envs partial_defs d in - let (defs,envs,partial_defs) = to_ast_defs_helper envs partial_defs ds in - (match d' with - | Finished def -> (def::defs,envs, partial_defs) - | No_def -> defs,envs,partial_defs - | Def_place_holder(id,l) -> - (match (def_in_progress id partial_defs) with - | None -> - raise - (Reporting.err_unreachable l __POS__ "Id stored in place holder not retrievable from partial defs") - | Some(d,k) -> - if (snd !d) - then (fst !d) :: defs, envs, partial_defs - else typ_error l "Scattered type definition never ended" (Some id) None None)) + raise (Reporting.err_unreachable P.Unknown __POS__ + "Internal mutual block found when processing scattered defs") + | P.DEF_scattered sdef -> + let sdef, ctx = to_ast_scattered ctx sdef in + DEF_scattered sdef, ctx let rec remove_mutrec = function | [] -> [] - | Parse_ast.DEF_internal_mutrec fundefs :: defs -> - List.map (fun fdef -> Parse_ast.DEF_fundef fdef) fundefs @ remove_mutrec defs + | P.DEF_internal_mutrec fundefs :: defs -> + List.map (fun fdef -> P.DEF_fundef fdef) fundefs @ remove_mutrec defs | def :: defs -> def :: remove_mutrec defs -let to_ast (default_names : Nameset.t) (kind_env : kind Envmap.t) (def_ord : order) (Parse_ast.Defs(defs)) = +let to_ast ctx (P.Defs(defs)) = let defs = remove_mutrec defs in - let defs,(_,k_env,def_ord),partial_defs = to_ast_defs_helper (default_names,kind_env,def_ord) [] defs in - List.iter - (fun (id,(d,k)) -> - (match !d with - | (d,false) -> typ_error Parse_ast.Unknown "Scattered definition never ended" (Some id) None None - | (_, true) -> ())) - partial_defs; - (Defs defs),k_env,def_ord - -let initial_kind_env = - Envmap.from_list [ - ("bool", {k = K_Typ}); - ("nat", {k = K_Typ}); - ("int", {k = K_Typ}); - ("uint8", {k = K_Typ}); - ("uint16", {k= K_Typ}); - ("uint32", {k=K_Typ}); - ("uint64", {k=K_Typ}); - ("unit", {k = K_Typ}); - ("bit", {k = K_Typ}); - ("string", {k = K_Typ}); - ("real", {k = K_Typ}); - ("list", {k = K_Lam( [{k = K_Typ}], {k = K_Typ})}); - ("reg", {k = K_Lam( [{k = K_Typ}], {k= K_Typ})}); - ("register", {k = K_Lam( [{k = K_Typ}], {k= K_Typ})}); - ("range", {k = K_Lam( [ {k = K_Nat}; {k= K_Nat}], {k = K_Typ}) }); - ("vector", {k = K_Lam( [{k = K_Nat}; {k= K_Ord} ; {k=K_Typ}], {k=K_Typ}) } ); - ("atom", {k = K_Lam( [ {k=K_Nat} ], {k=K_Typ})}); - ("option", { k = K_Lam( [{k=K_Typ}], {k=K_Typ}) }); - ("implicit", {k = K_Lam( [{k = K_Nat}], {k=K_Typ})} ); - ("itself", {k = K_Lam( [ {k=K_Nat} ], {k=K_Typ})}); - ] - -let exp_of_string order str = + let defs, ctx = + List.fold_left (fun (defs, ctx) def -> let def, ctx = to_ast_def ctx def in (def :: defs, ctx)) ([], ctx) defs + in + Defs (List.rev defs), ctx + +let initial_ctx = { + type_constructors = + List.fold_left (fun m (k, v) -> Bindings.add (mk_id k) v m) Bindings.empty + [ ("bool", []); + ("nat", []); + ("int", []); + ("unit", []); + ("bit", []); + ("string", []); + ("real", []); + ("list", [K_type]); + ("register", [K_type]); + ("range", [K_int; K_int]); + ("vector", [K_int; K_order; K_type]); + ("atom", [K_int]); + ("implicit", [K_int]); + ("itself", [K_int]); + ]; + kinds = KBindings.empty; + scattereds = Bindings.empty; + } + +let exp_of_string str = let exp = Parser.exp_eof Lexer.token (Lexing.from_string str) in - to_ast_exp initial_kind_env order exp + to_ast_exp initial_ctx exp -let typschm_of_string order str = +let typschm_of_string str = let typschm = Parser.typschm_eof Lexer.token (Lexing.from_string str) in - let (typschm, _, _) = to_ast_typschm initial_kind_env order typschm in + let typschm, _ = to_ast_typschm initial_ctx typschm in typschm -let extern_of_string order id str = mk_val_spec (VS_val_spec (typschm_of_string order str, id, (fun _ -> Some (string_of_id id)), false)) -let val_spec_of_string order id str = mk_val_spec (VS_val_spec (typschm_of_string order str, id, (fun _ -> None), false)) +let extern_of_string id str = mk_val_spec (VS_val_spec (typschm_of_string str, id, (fun _ -> Some (string_of_id id)), false)) +let val_spec_of_string id str = mk_val_spec (VS_val_spec (typschm_of_string str, id, (fun _ -> None), false)) let val_spec_ids (Defs defs) = let val_spec_id (VS_aux (vs_aux, _)) = @@ -1089,7 +801,7 @@ let have_undefined_builtins = ref false let generate_undefineds vs_ids (Defs defs) = let gen_vs id str = - if (IdSet.mem id vs_ids) then [] else [extern_of_string dec_ord id str] + if (IdSet.mem id vs_ids) then [] else [extern_of_string id str] in let undefined_builtins = if !have_undefined_builtins then @@ -1124,7 +836,7 @@ let generate_undefineds vs_ids (Defs defs) = in let undefined_td = function | TD_enum (id, _, ids, _) when not (IdSet.mem (prepend_id "undefined_" id) vs_ids) -> - let typschm = typschm_of_string dec_ord ("unit -> " ^ string_of_id id ^ " effect {undef}") in + let typschm = typschm_of_string ("unit -> " ^ string_of_id id ^ " effect {undef}") in [mk_val_spec (VS_val_spec (typschm, prepend_id "undefined_" id, (fun _ -> None), false)); mk_fundef [mk_funcl (prepend_id "undefined_" id) (mk_pat (P_lit (mk_lit L_unit))) @@ -1152,7 +864,7 @@ let generate_undefineds vs_ids (Defs defs) = | Tu_aux (Tu_ty_id (typ, id), _) -> (id, [typ]) in let record_arg_typs m (_,typs) = - let m' = + let m' = List.fold_left (fun m typ -> TypMap.add typ (1 + try TypMap.find typ m with Not_found -> 0) m) TypMap.empty typs in TypMap.merge (fun _ x y -> match x,y with Some m, Some n -> Some (max m n) @@ -1208,7 +920,7 @@ let generate_initialize_registers vs_ids (Defs defs) = let initialize_registers = if IdSet.mem (mk_id "initialize_registers") vs_ids || regs = [] then [] else - [val_spec_of_string dec_ord (mk_id "initialize_registers") "unit -> unit effect {undef, wreg}"; + [val_spec_of_string (mk_id "initialize_registers") "unit -> unit effect {undef, wreg}"; mk_fundef [mk_funcl (mk_id "initialize_registers") (mk_pat (P_lit (mk_lit L_unit))) (mk_exp (E_block (List.map (fun (typ, id) -> mk_exp (E_assign (mk_lexp (LEXP_cast (typ, id)), mk_lit_exp L_undef))) regs)))]] @@ -1273,11 +985,11 @@ let generate_enum_functions vs_ids (Defs defs) = in Defs (gen_enums defs) -let incremental_k_env = ref initial_kind_env +let incremental_ctx = ref initial_ctx let process_ast order defs = - let ast, k_env, _= to_ast Nameset.empty !incremental_k_env order defs in - incremental_k_env := k_env; + let ast, ctx = to_ast !incremental_ctx defs in + incremental_ctx := ctx; let vs_ids = val_spec_ids ast in if not !opt_undefined_gen then generate_enum_functions vs_ids ast @@ -1289,4 +1001,4 @@ let process_ast order defs = let ast_of_def_string order str = let def = Parser.def_eof Lexer.token (Lexing.from_string str) in - process_ast order (Parse_ast.Defs [def]) + process_ast order (P.Defs [def]) diff --git a/src/initial_check.mli b/src/initial_check.mli index e6b29216..32def316 100644 --- a/src/initial_check.mli +++ b/src/initial_check.mli @@ -87,7 +87,7 @@ val process_ast : order -> Parse_ast.defs -> unit defs val val_spec_ids : 'a defs -> IdSet.t -val extern_of_string : order -> id -> string -> unit def -val val_spec_of_string : order -> id -> string -> unit def +val extern_of_string : id -> string -> unit def +val val_spec_of_string : id -> string -> unit def -val exp_of_string : order -> string -> unit exp +val exp_of_string : string -> unit exp diff --git a/src/isail.ml b/src/isail.ml index 83bff3f3..195e5940 100644 --- a/src/isail.ml +++ b/src/isail.ml @@ -266,7 +266,7 @@ let handle_input' input = Value.output_close (); exit 0 | ":i" | ":infer" -> - let exp = Initial_check.exp_of_string dec_ord arg in + let exp = Initial_check.exp_of_string arg in let exp = Type_check.infer_exp !interactive_env exp in pretty_sail stdout (doc_typ (Type_check.typ_of exp)); print_newline () @@ -370,7 +370,7 @@ let handle_input' input = Initial_check.have_undefined_builtins := false | ":exec" -> let open Bytecode_interpreter in - let exp = Type_check.infer_exp !interactive_env (Initial_check.exp_of_string Ast_util.dec_ord arg) in + let exp = Type_check.infer_exp !interactive_env (Initial_check.exp_of_string arg) in let anf = Anf.anf exp in let ctx = C_backend.initial_ctx !interactive_env in let ctyp = C_backend.ctyp_of_typ ctx (Type_check.typ_of exp) in @@ -383,7 +383,7 @@ let handle_input' input = | Expression str -> (* An expression in normal mode is type checked, then puts us in evaluation mode. *) - let exp = Type_check.infer_exp !interactive_env (Initial_check.exp_of_string Ast_util.dec_ord str) in + let exp = Type_check.infer_exp !interactive_env (Initial_check.exp_of_string str) in current_mode := Evaluation (eval_frame (Step (lazy "", !interactive_state, return exp, []))); print_program () | Empty -> () diff --git a/src/monomorphise.ml b/src/monomorphise.ml index 7626971e..41a27be7 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -2096,8 +2096,8 @@ let split_defs all_errors splits defs = in let map_scattered_def sd = match sd with - | SD_aux (SD_scattered_funcl fcl, annot) -> - List.map (fun fcl' -> SD_aux (SD_scattered_funcl fcl', annot)) (map_funcl fcl) + | SD_aux (SD_funcl fcl, annot) -> + List.map (fun fcl' -> SD_aux (SD_funcl fcl', annot)) (map_funcl fcl) | _ -> [sd] in let map_def d = diff --git a/src/parse_ast.ml b/src/parse_ast.ml index 38854d48..79d90635 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -494,13 +494,13 @@ dec_spec_aux = (* Register declarations *) type scattered_def_aux = (* Function and type union definitions that can be spread across a file. Each one must end in $_$ *) - SD_scattered_function of rec_opt * tannot_opt * effect_opt * id (* scattered function definition header *) - | SD_scattered_funcl of funcl (* scattered function definition clause *) - | SD_scattered_variant of id * name_scm_opt * typquant (* scattered union definition header *) - | SD_scattered_unioncl of id * type_union (* scattered union definition member *) - | SD_scattered_mapping of id * tannot_opt - | SD_scattered_mapcl of id * mapcl - | SD_scattered_end of id (* scattered definition end *) + SD_function of rec_opt * tannot_opt * effect_opt * id (* scattered function definition header *) + | SD_funcl of funcl (* scattered function definition clause *) + | SD_variant of id * name_scm_opt * typquant (* scattered union definition header *) + | SD_unioncl of id * type_union (* scattered union definition member *) + | SD_mapping of id * tannot_opt + | SD_mapcl of id * mapcl + | SD_end of id (* scattered definition end *) type diff --git a/src/parser.mly b/src/parser.mly index fd6c9373..73259210 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -1395,22 +1395,22 @@ default_def: { mk_default (DT_order ($2, mk_typ ATyp_dec $startpos($3) $endpos)) $startpos $endpos } scattered_def: - | Union id typquant - { mk_sd (SD_scattered_variant($2, mk_namesectn, $3)) $startpos $endpos } + | Union id typaram + { mk_sd (SD_variant($2, mk_namesectn, $3)) $startpos $endpos } | Union id - { mk_sd (SD_scattered_variant($2, mk_namesectn, mk_typqn)) $startpos $endpos } + { mk_sd (SD_variant($2, mk_namesectn, mk_typqn)) $startpos $endpos } | Function_ id - { mk_sd (SD_scattered_function(mk_recn, mk_tannotn, mk_eannotn, $2)) $startpos $endpos } + { mk_sd (SD_function(mk_recn, mk_tannotn, mk_eannotn, $2)) $startpos $endpos } | Mapping id - { mk_sd (SD_scattered_mapping ($2, mk_tannotn)) $startpos $endpos } + { mk_sd (SD_mapping ($2, mk_tannotn)) $startpos $endpos } | Mapping id Colon funcl_typ - { mk_sd (SD_scattered_mapping ($2, $4)) $startpos $endpos } + { mk_sd (SD_mapping ($2, $4)) $startpos $endpos } scattered_clause: | Doc Function_ Clause funcl - { mk_sd_doc (SD_scattered_funcl $4) $1 $startpos($2) $endpos } + { mk_sd_doc (SD_funcl $4) $1 $startpos($2) $endpos } | Function_ Clause funcl - { mk_sd (SD_scattered_funcl $3) $startpos $endpos } + { mk_sd (SD_funcl $3) $startpos $endpos } def: @@ -1437,11 +1437,11 @@ def: | scattered_clause { DEF_scattered $1 } | Union Clause id Eq type_union - { DEF_scattered (mk_sd (SD_scattered_unioncl ($3, $5)) $startpos $endpos) } + { DEF_scattered (mk_sd (SD_unioncl ($3, $5)) $startpos $endpos) } | Mapping Clause id Eq mapcl - { DEF_scattered (mk_sd (SD_scattered_mapcl ($3, $5)) $startpos $endpos) } + { DEF_scattered (mk_sd (SD_mapcl ($3, $5)) $startpos $endpos) } | End id - { DEF_scattered (mk_sd (SD_scattered_end $2) $startpos $endpos) } + { DEF_scattered (mk_sd (SD_end $2) $startpos $endpos) } | default_def { DEF_default $1 } | Constant id Eq typ diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index b1efd11d..f9908c71 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -613,13 +613,18 @@ let doc_kind_def (KD_aux (KD_nabbrev (_, id, _, nexp), _)) = let rec doc_scattered (SD_aux (sd_aux, _)) = match sd_aux with - | SD_scattered_function (_, _, _, id) -> + | SD_function (_, _, _, id) -> string "scattered" ^^ space ^^ string "function" ^^ space ^^ doc_id id - | SD_scattered_funcl funcl -> + | SD_funcl funcl -> string "function" ^^ space ^^ string "clause" ^^ space ^^ doc_funcl funcl - | SD_scattered_end id -> + | SD_end id -> string "end" ^^ space ^^ doc_id id - | _ -> string "SCATTERED" + | SD_variant (id, _, TypQ_aux (TypQ_no_forall, _)) -> + string "scattered" ^^ space ^^ string "union" ^^ space ^^ doc_id id + | SD_variant (id, _, TypQ_aux (TypQ_tq quants, _)) -> + string "scattered" ^^ space ^^ string "union" ^^ space ^^ doc_id id ^^ doc_param_quants quants + | SD_unioncl (id, tu) -> + separate space [string "union clause"; doc_id id; equals; doc_union tu] let rec doc_def def = group (match def with | DEF_default df -> doc_default df diff --git a/src/process_file.ml b/src/process_file.ml index c3d0be0e..ca013077 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -388,7 +388,6 @@ let rewrite rewriters defs = raise (Reporting.err_typ l (Type_error.string_of_type_error err)) let rewrite_ast = rewrite [("initial", Rewriter.rewrite_defs)] -let rewrite_undefined bitvectors = rewrite [("undefined", fun x -> Rewrites.rewrite_undefined bitvectors x)] let rewrite_ast_lem = rewrite Rewrites.rewrite_defs_lem let rewrite_ast_coq = rewrite Rewrites.rewrite_defs_coq let rewrite_ast_ocaml = rewrite Rewrites.rewrite_defs_ocaml diff --git a/src/process_file.mli b/src/process_file.mli index 1ebb3014..1d4d629a 100644 --- a/src/process_file.mli +++ b/src/process_file.mli @@ -56,7 +56,6 @@ val convert_ast : Ast.order -> Parse_ast.defs -> unit Ast.defs val preprocess_ast : (Arg.key * Arg.spec * Arg.doc) list -> Parse_ast.defs -> Parse_ast.defs val check_ast: Type_check.Env.t -> unit Ast.defs -> Type_check.tannot Ast.defs * Type_check.Env.t val rewrite_ast: Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs -val rewrite_undefined: bool -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs val rewrite_ast_lem : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs val rewrite_ast_coq : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs val rewrite_ast_ocaml : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs diff --git a/src/rewrites.ml b/src/rewrites.ml index 8c1311a0..0ead9670 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -82,7 +82,7 @@ let fresh_id_pat pre ((l,annot)) = let get_loc_exp (E_aux (_,(l,_))) = l -let gen_vs (id, spec) = Initial_check.extern_of_string dec_ord (mk_id id) spec +let gen_vs (id, spec) = Initial_check.extern_of_string (mk_id id) spec let annot_exp_effect e_aux l env typ effect = E_aux (e_aux, (l, mk_tannot env typ effect)) let annot_exp e_aux l env typ = annot_exp_effect e_aux l env typ no_effect @@ -4277,7 +4277,8 @@ let rewrite_defs_realise_mappings (Defs defs) = let non_rec = (Rec_aux (Rec_nonrec, Parse_ast.Unknown)) in let effect_pure = (Effect_opt_aux (Effect_opt_pure, Parse_ast.Unknown)) in - let env = match mapcls with + (* We need to make sure we get the environment for the last mapping clause *) + let env = match List.rev mapcls with | MCL_aux (_, mapcl_annot) :: _ -> env_of_annot mapcl_annot | _ -> Type_check.typ_error l "mapping with no clauses?" in diff --git a/src/sail.ml b/src/sail.ml index b9a18417..73173946 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -282,6 +282,7 @@ let load_files type_envs files = let (ast, type_envs) = check_ast type_envs ast in Profile.finish "type checking" t; + let ast = Scattered.descatter ast in let ast = rewrite_ast ast in let out_name = match !opt_file_out with diff --git a/src/scattered.ml b/src/scattered.ml new file mode 100644 index 00000000..be304dc8 --- /dev/null +++ b/src/scattered.ml @@ -0,0 +1,141 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Ast_util + +let funcl_id (FCL_aux (FCL_Funcl (id, _), _)) = id + +let rec last_scattered_funcl id = function + | DEF_scattered (SD_aux (SD_funcl funcl, _)) :: _ + when Id.compare (funcl_id funcl) id = 0 -> false + | _ :: defs -> last_scattered_funcl id defs + | [] -> true + +let rec last_scattered_mapcl id = function + | DEF_scattered (SD_aux (SD_mapcl (mid, _), _)) :: _ + when Id.compare mid id = 0 -> false + | _ :: defs -> last_scattered_mapcl id defs + | [] -> true + +(* Nothing cares about these and the AST should be changed *) +let fake_effect_opt l = Effect_opt_aux (Effect_opt_pure, gen_loc l) +let fake_rec_opt l = Rec_aux (Rec_rec, gen_loc l) + +let no_tannot_opt l = Typ_annot_opt_aux (Typ_annot_opt_none, gen_loc l) + +let rec get_union_clauses id = function + | DEF_scattered (SD_aux (SD_unioncl (uid, tu), _)) :: defs when Id.compare id uid = 0 -> + tu :: get_union_clauses id defs + | def :: defs -> + get_union_clauses id defs + | [] -> [] + +let rec filter_union_clauses id = function + | DEF_scattered (SD_aux (SD_unioncl (uid, tu), _)) :: defs when Id.compare id uid = 0 -> + filter_union_clauses id defs + | def :: defs -> + def :: filter_union_clauses id defs + | [] -> [] + +let rec descatter' funcls mapcls = function + (* For scattered functions we collect all the seperate function + clauses until we find the last one, then we turn that function + clause into a DEF_fundef containing all the clauses. *) + | DEF_scattered (SD_aux (SD_funcl funcl, (l, _))) :: defs + when last_scattered_funcl (funcl_id funcl) defs -> + let clauses = match Bindings.find_opt (funcl_id funcl) funcls with + | Some clauses -> List.rev (funcl :: clauses) + | None -> [funcl] + in + DEF_fundef (FD_aux (FD_function (fake_rec_opt l, no_tannot_opt l, fake_effect_opt l, clauses), + (gen_loc l, Type_check.empty_tannot))) + :: descatter' funcls mapcls defs + + | DEF_scattered (SD_aux (SD_funcl funcl, _)) :: defs -> + let id = funcl_id funcl in + begin match Bindings.find_opt id funcls with + | Some clauses -> descatter' (Bindings.add id (funcl :: clauses) funcls) mapcls defs + | None -> descatter' (Bindings.add id [funcl] funcls) mapcls defs + end + + (* Scattered mappings are handled the same way as scattered functions *) + | DEF_scattered (SD_aux (SD_mapcl (id, mapcl), (l, tannot))) :: defs + when last_scattered_mapcl id defs -> + let clauses = match Bindings.find_opt id mapcls with + | Some clauses -> List.rev (mapcl :: clauses) + | None -> [mapcl] + in + DEF_mapdef (MD_aux (MD_mapping (id, no_tannot_opt l, clauses), + (gen_loc l, tannot))) + :: descatter' funcls mapcls defs + + | DEF_scattered (SD_aux (SD_mapcl (id, mapcl), _)) :: defs -> + begin match Bindings.find_opt id mapcls with + | Some clauses -> descatter' funcls (Bindings.add id (mapcl :: clauses) mapcls) defs + | None -> descatter' funcls (Bindings.add id [mapcl] mapcls) defs + end + + (* For scattered unions, when we find a union declaration we + immediately grab all the future clauses and turn it into a + regular union declaration. *) + | DEF_scattered (SD_aux (SD_variant (id, namescm, typq), (l, _))) :: defs -> + let tus = get_union_clauses id defs in + DEF_type (TD_aux (TD_variant (id, namescm, typq, tus, false), (gen_loc l, Type_check.empty_tannot))) + :: descatter' funcls mapcls (filter_union_clauses id defs) + + (* Therefore we should never see SD_unioncl... *) + | DEF_scattered (SD_aux (SD_unioncl _, (l, _))) :: defs -> + raise (Reporting.err_unreachable l __POS__ "Found union clause during de-scattering") + + | def :: defs -> def :: descatter' funcls mapcls defs + | [] -> [] + +let descatter (Defs defs) = Defs (descatter' Bindings.empty Bindings.empty defs) diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index 180b96b2..9453e999 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -386,17 +386,17 @@ let rec find_scattered_of name = function | [] -> [] | DEF_scattered (SD_aux(sda,_) as sd):: defs -> (match sda with - | SD_scattered_function(_,_,_,id) - | SD_scattered_funcl(FCL_aux(FCL_Funcl(id,_),_)) - | SD_scattered_unioncl(id,_) -> + | SD_function(_,_,_,id) + | SD_funcl(FCL_aux(FCL_Funcl(id,_),_)) + | SD_unioncl(id,_) -> if name = string_of_id id then [sd] else [] | _ -> [])@ (find_scattered_of name defs) | _::defs -> find_scattered_of name defs -let rec fv_of_scattered consider_var consider_scatter_as_one all_defs (SD_aux(sd,_)) = match sd with - | SD_scattered_function(_,tannot_opt,_,id) -> +let rec fv_of_scattered consider_var consider_scatter_as_one all_defs (SD_aux(sd,(l, _))) = match sd with + | SD_function(_,tannot_opt,_,id) -> let b,ns = (match tannot_opt with | Typ_annot_opt_aux(Typ_annot_opt_some (typq, typ),_) -> let bindings = if consider_var then typq_bindings typq else mt in @@ -404,7 +404,7 @@ let rec fv_of_scattered consider_var consider_scatter_as_one all_defs (SD_aux(sd | Typ_annot_opt_aux(Typ_annot_opt_none, _) -> mt, mt) in init_env (string_of_id id),ns - | SD_scattered_funcl (FCL_aux(FCL_Funcl(id,pexp),_)) -> + | SD_funcl (FCL_aux(FCL_Funcl(id,pexp),_)) -> begin match pexp with | Pat_aux(Pat_exp (pat,exp),_) -> @@ -423,7 +423,7 @@ let rec fv_of_scattered consider_var consider_scatter_as_one all_defs (SD_aux(sd | _ -> mt in scattered_binds, exp_ns end - | SD_scattered_variant (id,_,_) -> + | SD_variant (id,_,_) -> let name = string_of_id id in let uses = if consider_scatter_as_one @@ -435,12 +435,12 @@ let rec fv_of_scattered consider_var consider_scatter_as_one all_defs (SD_aux(sd Nameset.remove name pieces_uses else mt in init_env name, uses - | SD_scattered_unioncl(id, type_union) -> + | SD_unioncl(id, type_union) -> let typ_name = string_of_id id in let b = init_env typ_name in let (b,r) = typ_variants consider_var b [type_union] in (Nameset.remove typ_name b, Nameset.add typ_name r) - | SD_scattered_end id -> + | SD_end id -> let name = string_of_id id in let uses = if consider_scatter_as_one (*Note: if this is a function ending, the dec is included *) @@ -450,6 +450,7 @@ let rec fv_of_scattered consider_var consider_scatter_as_one all_defs (SD_aux(sd (List.map (fv_of_scattered consider_var false []) scattered_defs) (init_env name) else init_env name in init_env (name ^ "/end"), uses + | _ -> raise (Reporting.err_unreachable l __POS__ "Tried to find free variables for scattered mapping clause") let fv_of_rd consider_var (DEC_aux (d, annot)) = (* When we get the free variables of a register, we have to ensure diff --git a/src/type_check.ml b/src/type_check.ml index 435c5cd8..f204a558 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -235,6 +235,9 @@ module Env : sig val add_local : id -> mut * typ -> t -> t val get_locals : t -> (mut * typ) Bindings.t val add_variant : id -> typquant * type_union list -> t -> t + val add_scattered_variant : id -> typquant -> t -> t + val add_variant_clause : id -> type_union -> t -> t + val get_variant : id -> t -> typquant * type_union list val add_mapping : id -> typquant * typ * typ -> t -> t val add_union_id : id -> typquant * typ -> t -> t val add_flow : id -> (typ -> typ) -> t -> t @@ -916,10 +919,22 @@ end = struct end let add_variant id variant env = - begin - typ_print (lazy (adding ^ "variant " ^ string_of_id id)); - { env with variants = Bindings.add id variant env.variants } - end + typ_print (lazy (adding ^ "variant " ^ string_of_id id)); + { env with variants = Bindings.add id variant env.variants } + + let add_scattered_variant id typq env = + typ_print (lazy (adding ^ "scattered variant " ^ string_of_id id)); + { env with variants = Bindings.add id (typq, []) env.variants } + + let add_variant_clause id tu env = + match Bindings.find_opt id env.variants with + | Some (typq, tus) -> { env with variants = Bindings.add id (typq, tus @ [tu]) env.variants } + | None -> typ_error (id_loc id) ("scattered union " ^ string_of_id id ^ " not found") + + let get_variant id env = + match Bindings.find_opt id env.variants with + | Some (typq, tus) -> typq, tus + | None -> typ_error (id_loc id) ("union " ^ string_of_id id ^ " not found") let add_union_id id bind env = begin @@ -4339,7 +4354,6 @@ let check_mapdef env (MD_aux (MD_mapping (id, tannot_opt, mapcls), (l, _)) as md else typ_error l ("Mapping not pure (or escape only): " ^ string_of_effect eff ^ " found") - (* Checking a val spec simply adds the type as a binding in the context. We have to destructure the various kinds of val specs, but the difference is irrelevant for the typechecker. *) @@ -4355,7 +4369,7 @@ let check_val_spec env (VS_aux (vs, (l, _))) = let env = Env.add_extern id ext_opt env in let env = if is_cast then Env.add_cast id env else env in let typq, typ = - if !opt_expand_valspec then + if !opt_expand_valspec then expand_bind_synonyms ts_l env (typq, typ) else (typq, typ) @@ -4473,6 +4487,28 @@ let rec check_typedef : 'a. Env.t -> 'a type_def -> (tannot def) list * Env.t = typ_error l "Bad bitfield type" end +and check_scattered : 'a. Env.t -> 'a scattered_def -> (tannot def) list * Env.t = + fun env (SD_aux (sdef, (l, _))) -> + match sdef with + | SD_function _ | SD_end _ | SD_mapping _ -> [], env + | SD_variant (id, namescm, typq) -> + [DEF_scattered (SD_aux (SD_variant (id, namescm, typq), (l, None)))], Env.add_scattered_variant id typq env + | SD_unioncl (id, tu) -> + [DEF_scattered (SD_aux (SD_unioncl (id, tu), (l, None)))], + let env = Env.add_variant_clause id tu env in + let typq, _ = Env.get_variant id env in + check_type_union env id typq tu + | SD_funcl (FCL_aux (FCL_Funcl (id, _), (l, _)) as funcl) -> + let typq, typ = Env.get_val_spec id env in + let funcl_env = add_typquant l typq env in + let funcl = check_funcl funcl_env funcl typ in + [DEF_scattered (SD_aux (SD_funcl funcl, (l, None)))], env + | SD_mapcl (id, mapcl) -> + let typq, typ = Env.get_val_spec id env in + let mapcl_env = add_typquant l typq env in + let mapcl = check_mapcl mapcl_env mapcl typ in + [DEF_scattered (SD_aux (SD_mapcl (id, mapcl), (l, None)))], env + and check_def : 'a. Env.t -> 'a def -> (tannot def) list * Env.t = fun env def -> let cd_err () = raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented Case") in @@ -4503,7 +4539,7 @@ and check_def : 'a. Env.t -> 'a def -> (tannot def) list * Env.t = | DEF_pragma (pragma, arg, l) -> [DEF_pragma (pragma, arg, l)], env | DEF_reg_dec (DEC_aux (DEC_alias (id, aspec), (l, annot))) -> cd_err () | DEF_reg_dec (DEC_aux (DEC_typ_alias (typ, id, aspec), (l, tannot))) -> cd_err () - | DEF_scattered _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Scattered given to type checker") + | DEF_scattered sdef -> check_scattered env sdef and check : 'a. Env.t -> 'a defs -> tannot defs * Env.t = fun env (Defs defs) -> -- cgit v1.2.3 From 25ab845211e3df24386a0573b517a01dab879b03 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Thu, 6 Dec 2018 17:16:06 +0000 Subject: Desugar constraints from atyp rather than n_constraint Previously the valid constraints had to be carefully restricted to avoid parser ambiguities between n_constraint and atyp. With the initial check refactored, we can now parse constraints into atyp using ATyp_app for the operators, and changing ATyp_constant into a more general ATyp_lit for true and false. Logically this new structure is more uniform, as atyp is now the parse representation for all Bool-kinded things (constraints), Type-kinded things (regular types), and Int-kinded things (n-expressions), and initial_check.ml now splits all three into n_constraint, typ, and nexp respectively, rather than how it was before with initial_check splitting types and nexps, but constraints already being separate in the parser. --- src/initial_check.ml | 40 +++++++-------- src/lexer.mll | 1 - src/parse_ast.ml | 75 ++++++++++------------------ src/parser.mly | 125 ++++++++++++++++------------------------------- src/pretty_print_sail.ml | 5 +- 5 files changed, 90 insertions(+), 156 deletions(-) (limited to 'src') diff --git a/src/initial_check.ml b/src/initial_check.ml index 926e993a..b57e6b17 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -171,7 +171,7 @@ and to_ast_nexp ctx (P.ATyp_aux (aux, l)) = let aux = match aux with | P.ATyp_id id -> Nexp_id (to_ast_id id) | P.ATyp_var v -> Nexp_var (to_ast_var v) - | P.ATyp_constant c -> Nexp_constant c + | P.ATyp_lit (P.L_aux (P.L_num c, _)) -> Nexp_constant c | P.ATyp_sum (t1, t2) -> Nexp_sum (to_ast_nexp ctx t1, to_ast_nexp ctx t2) | P.ATyp_exp t1 -> Nexp_exp (to_ast_nexp ctx t1) | P.ATyp_neg t1 -> Nexp_neg (to_ast_nexp ctx t1) @@ -189,26 +189,26 @@ and to_ast_order ctx (P.ATyp_aux (aux, l)) = | ATyp_dec -> Ord_aux (Ord_dec, l) | _ -> raise (Reporting.err_typ l "Invalid order in type") -and to_ast_constraint ctx (P.NC_aux (nc, l)) = - let nc = match nc with - | P.NC_equal (t1, t2) -> - NC_equal (to_ast_nexp ctx t1, to_ast_nexp ctx t2) - | P.NC_not_equal (t1, t2) -> - NC_not_equal (to_ast_nexp ctx t1, to_ast_nexp ctx t2) - | P.NC_bounded_ge (t1,t2) -> - NC_bounded_ge (to_ast_nexp ctx t1, to_ast_nexp ctx t2) - | P.NC_bounded_le(t1,t2) -> - NC_bounded_le (to_ast_nexp ctx t1, to_ast_nexp ctx t2) - | P.NC_set(id,bounds) -> - NC_set(to_ast_var id, bounds) - | P.NC_or (nc1, nc2) -> - NC_or (to_ast_constraint ctx nc1, to_ast_constraint ctx nc2) - | P.NC_and (nc1, nc2) -> - NC_and (to_ast_constraint ctx nc1, to_ast_constraint ctx nc2) - | P.NC_true -> NC_true - | P.NC_false -> NC_false +and to_ast_constraint ctx (P.ATyp_aux (aux, l) as atyp) = + let aux = match aux with + | P.ATyp_app (Id_aux (DeIid op, _), [t1; t2]) -> + begin match op with + | "==" -> NC_equal (to_ast_nexp ctx t1, to_ast_nexp ctx t2) + | "!=" -> NC_equal (to_ast_nexp ctx t1, to_ast_nexp ctx t2) + | ">=" -> NC_bounded_ge (to_ast_nexp ctx t1, to_ast_nexp ctx t2) + | "<=" -> NC_bounded_le (to_ast_nexp ctx t1, to_ast_nexp ctx t2) + | ">" -> NC_bounded_ge (to_ast_nexp ctx t1, nsum (to_ast_nexp ctx t2) (nint 1)) + | "<" -> NC_bounded_le (nsum (to_ast_nexp ctx t1) (nint 1), to_ast_nexp ctx t2) + | "&" -> NC_and (to_ast_constraint ctx t1, to_ast_constraint ctx t2) + | "|" -> NC_or (to_ast_constraint ctx t1, to_ast_constraint ctx t2) + | _ -> raise (Reporting.err_typ l ("Invalid operator in constraint")) + end + | P.ATyp_lit (P.L_aux (P.L_true, _)) -> NC_true + | P.ATyp_lit (P.L_aux (P.L_false, _)) -> NC_false + | P.ATyp_nset (id, bounds) -> NC_set (to_ast_var id, bounds) + | _ -> raise (Reporting.err_typ l "Invalid constraint") in - NC_aux (nc, l) + NC_aux (aux, l) let to_ast_quant_item ctx (P.QI_aux (aux, l)) = match aux with diff --git a/src/lexer.mll b/src/lexer.mll index a1f3ace2..f5a982eb 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -217,7 +217,6 @@ rule token = parse | "@" { (At "@") } | "2" ws "^" { TwoCaret } | "^" { (Caret(r"^")) } - | "::<" { ColonColonLt } | "::" { ColonColon(r "::") } (* | "^^" { CaretCaret(r "^^") } *) | "~~" { TildeTilde(r "~~") } diff --git a/src/parse_ast.ml b/src/parse_ast.ml index 79d90635..204389f9 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -122,13 +122,32 @@ kid = type id = - Id_aux of id_aux * l + Id_aux of id_aux * l + +type +lit_aux = (* Literal constant *) + L_unit (* $() : _$ *) + | L_zero (* $_ : _$ *) + | L_one (* $_ : _$ *) + | L_true (* $_ : _$ *) + | L_false (* $_ : _$ *) + | L_num of Big_int.num (* natural number constant *) + | L_hex of string (* bit vector constant, C-style *) + | L_bin of string (* bit vector constant, C-style *) + | L_undef (* undefined value *) + | L_string of string (* string constant *) + | L_real of string + +type +lit = + L_aux of lit_aux * l type atyp_aux = (* expressions of all kinds, to be translated to types, nats, orders, and effects after parsing *) ATyp_id of id (* identifier *) | ATyp_var of kid (* ticked variable *) - | ATyp_constant of Big_int.num (* constant *) + | ATyp_lit of lit (* literal *) + | ATyp_nset of kid * (Big_int.num) list (* set type *) | ATyp_times of atyp * atyp (* product *) | ATyp_sum of atyp * atyp (* sum *) | ATyp_minus of atyp * atyp (* subtraction *) @@ -143,8 +162,7 @@ atyp_aux = (* expressions of all kinds, to be translated to types, nats, orders | ATyp_wild | ATyp_tup of (atyp) list (* Tuple type *) | ATyp_app of id * (atyp) list (* type constructor application *) - | ATyp_exist of kid list * n_constraint * atyp - | ATyp_with of atyp * n_constraint + | ATyp_exist of kid list * atyp * atyp and atyp = ATyp_aux of atyp_aux * l @@ -155,23 +173,6 @@ kinded_id_aux = (* optionally kind-annotated identifier *) KOpt_none of kid (* identifier *) | KOpt_kind of kind * kid (* kind-annotated variable *) - -and -n_constraint_aux = (* constraint over kind $_$ *) - NC_equal of atyp * atyp - | NC_bounded_ge of atyp * atyp - | NC_bounded_le of atyp * atyp - | NC_not_equal of atyp * atyp - | NC_set of kid * (Big_int.num) list - | NC_or of n_constraint * n_constraint - | NC_and of n_constraint * n_constraint - | NC_true - | NC_false - -and -n_constraint = - NC_aux of n_constraint_aux * l - type kinded_id = KOpt_aux of kinded_id_aux * l @@ -179,7 +180,7 @@ kinded_id = type quant_item_aux = (* Either a kinded identifier or a nexp constraint for a typquant *) QI_id of kinded_id (* An optionally kinded identifier *) - | QI_const of n_constraint (* A constraint for this type *) + | QI_const of atyp (* A constraint for this type *) type @@ -197,31 +198,11 @@ type typquant = TypQ_aux of typquant_aux * l - -type -lit_aux = (* Literal constant *) - L_unit (* $() : _$ *) - | L_zero (* $_ : _$ *) - | L_one (* $_ : _$ *) - | L_true (* $_ : _$ *) - | L_false (* $_ : _$ *) - | L_num of Big_int.num (* natural number constant *) - | L_hex of string (* bit vector constant, C-style *) - | L_bin of string (* bit vector constant, C-style *) - | L_undef (* undefined value *) - | L_string of string (* string constant *) - | L_real of string - -type +type typschm_aux = (* type scheme *) TypSchm_ts of typquant * atyp -type -lit = - L_aux of lit_aux * l - - type typschm = TypSchm_aux of typschm_aux * l @@ -285,7 +266,7 @@ exp_aux = (* Expression *) | E_let of letbind * exp (* let expression *) | E_assign of exp * exp (* imperative assignment *) | E_sizeof of atyp - | E_constraint of n_constraint + | E_constraint of atyp | E_exit of exp | E_throw of exp | E_try of exp * pexp list @@ -302,12 +283,6 @@ and fexp_aux = (* Field-expression *) and fexp = FE_aux of fexp_aux * l -and fexps_aux = (* Field-expression list *) - FES_Fexps of (fexp) list * bool - -and fexps = - FES_aux of fexps_aux * l - and opt_default_aux = (* Optional default value for indexed vectors, to define a defualt value for any unspecified positions in a sparse map *) Def_val_empty | Def_val_dec of exp diff --git a/src/parser.mly b/src/parser.mly index 73259210..bb5aa5f1 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -103,7 +103,6 @@ let mk_typschm_opt ts n m = TypSchm_opt_aux ( let mk_typschm_opt_none = TypSchm_opt_aux (TypSchm_opt_none, Unknown) -let mk_nc nc n m = NC_aux (nc, loc n m) let mk_sd s n m = SD_aux (s, loc n m) let mk_sd_doc s str n m = SD_aux (s, Documented (str, loc n m)) let mk_ir r n m = BF_aux (r, loc n m) @@ -140,18 +139,18 @@ type lchain = | LC_lteq | LC_nexp of atyp +let tyop op t1 t2 s e = mk_typ (ATyp_app (Id_aux (DeIid op, loc s e), [t1; t2])) s e + let rec desugar_lchain chain s e = match chain with - | [LC_nexp n1; LC_lteq; LC_nexp n2] -> - mk_nc (NC_bounded_le (n1, n2)) s e - | [LC_nexp n1; LC_lt; LC_nexp n2] -> - mk_nc (NC_bounded_le (mk_typ (ATyp_sum (n1, mk_typ (ATyp_constant (Big_int.of_int 1)) s e)) s e, n2)) s e + | [LC_nexp n1; LC_lteq; LC_nexp n2] -> tyop "<=" n1 n2 s e + | [LC_nexp n1; LC_lt; LC_nexp n2] -> tyop "<" n1 n2 s e | (LC_nexp n1 :: LC_lteq :: LC_nexp n2 :: chain) -> - let nc1 = mk_nc (NC_bounded_le (n1, n2)) s e in - mk_nc (NC_and (nc1, desugar_lchain (LC_nexp n2 :: chain) s e)) s e + let nc1 = tyop "<=" n1 n2 s e in + tyop "&" nc1 (desugar_lchain (LC_nexp n2 :: chain) s e) s e | (LC_nexp n1 :: LC_lt :: LC_nexp n2 :: chain) -> - let nc1 = mk_nc (NC_bounded_le (mk_typ (ATyp_sum (n1, mk_typ (ATyp_constant (Big_int.of_int 1)) s e)) s e, n2)) s e in - mk_nc (NC_and (nc1, desugar_lchain (LC_nexp n2 :: chain) s e)) s e + let nc1 = tyop "<" n1 n2 s e in + tyop "&" nc1 (desugar_lchain (LC_nexp n2 :: chain) s e) s e | _ -> assert false type rchain = @@ -161,20 +160,16 @@ type rchain = let rec desugar_rchain chain s e = match chain with - | [RC_nexp n1; RC_gteq; RC_nexp n2] -> - mk_nc (NC_bounded_ge (n1, n2)) s e - | [RC_nexp n1; RC_gt; RC_nexp n2] -> - mk_nc (NC_bounded_ge (n1, mk_typ (ATyp_sum (n2, mk_typ (ATyp_constant (Big_int.of_int 1)) s e)) s e)) s e + | [RC_nexp n1; RC_gteq; RC_nexp n2] -> tyop ">=" n1 n2 s e + | [RC_nexp n1; RC_gt; RC_nexp n2] -> tyop ">" n1 n2 s e | (RC_nexp n1 :: RC_gteq :: RC_nexp n2 :: chain) -> - let nc1 = mk_nc (NC_bounded_ge (n1, n2)) s e in - mk_nc (NC_and (nc1, desugar_rchain (RC_nexp n2 :: chain) s e)) s e + let nc1 = tyop ">=" n1 n2 s e in + tyop "&" nc1 (desugar_rchain (RC_nexp n2 :: chain) s e) s e | (RC_nexp n1 :: RC_gt :: RC_nexp n2 :: chain) -> - let nc1 = mk_nc (NC_bounded_ge (n1, mk_typ (ATyp_sum (n2, mk_typ (ATyp_constant (Big_int.of_int 1)) s e)) s e)) s e in - mk_nc (NC_and (nc1, desugar_rchain (RC_nexp n2 :: chain) s e)) s e + let nc1 = tyop ">" n1 n2 s e in + tyop "&" nc1 (desugar_rchain (RC_nexp n2 :: chain) s e) s e | _ -> assert false -let future_syntax l = Util.warn (Reporting.loc_to_string l ^ "\n\nThis syntax is currently experimental") - %} /*Terminals with no content*/ @@ -189,7 +184,7 @@ let future_syntax l = Util.warn (Reporting.loc_to_string l ^ "\n\nThis syntax is %nonassoc Then %nonassoc Else -%token Bar Comma Dot Eof Minus Semi Under DotDot ColonColonLt +%token Bar Comma Dot Eof Minus Semi Under DotDot %token Lcurly Rcurly Lparen Rparen Lsquare Rsquare LcurlyBar RcurlyBar LsquareBar RsquareBar %token MinusGt Bidir LtMinus @@ -324,69 +319,35 @@ kid_list: | kid kid_list { $1 :: $2 } -nc: - | nc Bar nc_and - { mk_nc (NC_or ($1, $3)) $startpos $endpos } - | nc_and - { $1 } - -nc_and: - | nc_and Amp atomic_nc - { mk_nc (NC_and ($1, $3)) $startpos $endpos } - | atomic_nc - { $1 } - -atomic_nc: - | True - { mk_nc NC_true $startpos $endpos } - | False - { mk_nc NC_false $startpos $endpos } - | typ0 EqEq typ0 - { mk_nc (NC_equal ($1, $3)) $startpos $endpos } - | typ0 ExclEq typ0 - { mk_nc (NC_not_equal ($1, $3)) $startpos $endpos } - | nc_lchain - { desugar_lchain $1 $startpos $endpos } - | nc_rchain - { desugar_rchain $1 $startpos $endpos } - | Lparen nc Rparen - { $2 } - | kid In Lcurly num_list Rcurly - { mk_nc (NC_set ($1, $4)) $startpos $endpos } - num_list: | Num { [$1] } | Num Comma num_list { $1 :: $3 } -nc_lchain: - | typ0 LtEq typ0 +lchain: + | typ5 LtEq typ5 { [LC_nexp $1; LC_lteq; LC_nexp $3] } - | typ0 Lt typ0 + | typ5 Lt typ5 { [LC_nexp $1; LC_lt; LC_nexp $3] } - | typ0 LtEq nc_lchain + | typ5 LtEq lchain { LC_nexp $1 :: LC_lteq :: $3 } - | typ0 Lt nc_lchain + | typ5 Lt lchain { LC_nexp $1 :: LC_lt :: $3 } -nc_rchain: - | typ0 GtEq typ0 +rchain: + | typ5 GtEq typ5 { [RC_nexp $1; RC_gteq; RC_nexp $3] } - | typ0 Gt typ0 + | typ5 Gt typ5 { [RC_nexp $1; RC_gt; RC_nexp $3] } - | typ0 GtEq nc_rchain + | typ5 GtEq rchain { RC_nexp $1 :: RC_gteq :: $3 } - | typ0 Gt nc_rchain + | typ5 Gt rchain { RC_nexp $1 :: RC_gt :: $3 } tyarg: - | ColonColonLt typ_list Gt - { future_syntax (loc $startpos($1) $endpos($3)); $2, [] } | Lparen typ_list Rparen { [], $2 } - | ColonColonLt typ_list Gt Lparen typ_list Rparen - { future_syntax (loc $startpos($1) $endpos($3)); $2, $5 } typ: | typ0 @@ -427,6 +388,7 @@ typ2: | typ3 op2 typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } | typ2l op2l typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } | typ3 op2r typ2r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3 Bar typ2r { mk_typ (ATyp_app (deinfix (mk_id (Id "|") $startpos($2) $endpos($2)), [$1; $3])) $startpos $endpos } | typ3 { $1 } typ2l: | typ3 op2 typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } @@ -435,12 +397,14 @@ typ2l: typ2r: | typ3 op2 typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } | typ3 op2r typ2r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3 Bar typ2r { mk_typ (ATyp_app (deinfix (mk_id (Id "|") $startpos($2) $endpos($2)), [$1; $3])) $startpos $endpos } | typ3 { $1 } typ3: | typ4 op3 typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } | typ3l op3l typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } | typ4 op3r typ3r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4 Amp typ3r { mk_typ (ATyp_app (deinfix (mk_id (Id "&") $startpos($2) $endpos($2)), [$1; $3])) $startpos $endpos } | typ4 { $1 } typ3l: | typ4 op3 typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } @@ -449,12 +413,17 @@ typ3l: typ3r: | typ4 op3 typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } | typ4 op3r typ3r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4 Amp typ3r { mk_typ (ATyp_app (deinfix (mk_id (Id "&") $startpos($2) $endpos($2)), [$1; $3])) $startpos $endpos } | typ4 { $1 } typ4: | typ5 op4 typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } | typ4l op4l typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } | typ5 op4r typ4r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | lchain { desugar_lchain $1 $startpos $endpos } + | rchain { desugar_rchain $1 $startpos $endpos } + | typ5 EqEq typ5 { mk_typ (ATyp_app (deinfix (mk_id (Id $2) $startpos($2) $endpos($2)), [$1; $3])) $startpos $endpos } + | typ5 ExclEq typ5 { mk_typ (ATyp_app (deinfix (mk_id (Id $2) $startpos($2) $endpos($2)), [$1; $3])) $startpos $endpos } | typ5 { $1 } typ4l: | typ5 op4 typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } @@ -534,6 +503,8 @@ typ8r: | typ9 { $1 } typ9: + | kid In Lcurly num_list Rcurly + { mk_typ (ATyp_nset ($1, $4)) $startpos $endpos } | atomic_typ op9 atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } | typ9l op9l atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } | atomic_typ op9r typ9r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } @@ -554,8 +525,8 @@ atomic_typ: { mk_typ ATyp_wild $startpos $endpos } | kid { mk_typ (ATyp_var $1) $startpos $endpos } - | Num - { mk_typ (ATyp_constant $1) $startpos $endpos } + | lit + { mk_typ (ATyp_lit $1) $startpos $endpos } | Dec { mk_typ ATyp_dec $startpos $endpos } | Inc @@ -573,10 +544,10 @@ atomic_typ: { let v = mk_kid "n" $startpos $endpos in let atom_id = mk_id (Id "atom") $startpos $endpos in let atom_of_v = mk_typ (ATyp_app (atom_id, [mk_typ (ATyp_var v) $startpos $endpos])) $startpos $endpos in - mk_typ (ATyp_exist ([v], NC_aux (NC_set (v, $2), loc $startpos($2) $endpos($2)), atom_of_v)) $startpos $endpos } + mk_typ (ATyp_exist ([v], ATyp_aux (ATyp_nset (v, $2), loc $startpos($2) $endpos($2)), atom_of_v)) $startpos $endpos } | Lcurly kid_list Dot typ Rcurly - { mk_typ (ATyp_exist ($2, NC_aux (NC_true, loc $startpos $endpos), $4)) $startpos $endpos } - | Lcurly kid_list Comma nc Dot typ Rcurly + { mk_typ (ATyp_exist ($2, ATyp_aux (ATyp_lit (L_aux (L_true, loc $startpos $endpos)), loc $startpos $endpos), $4)) $startpos $endpos } + | Lcurly kid_list Comma typ Dot typ Rcurly { mk_typ (ATyp_exist ($2, $4, $6)) $startpos $endpos } typ_list: @@ -606,7 +577,7 @@ kopt_list: { $1 :: $2 } typquant: - | kopt_list Comma nc + | kopt_list Comma typ { let qi_nc = QI_aux (QI_const $3, loc $startpos($3) $endpos($3)) in TypQ_aux (TypQ_tq (List.map qi_id_of_kopt $1 @ [qi_nc]), loc $startpos $endpos) } | kopt_list @@ -1055,7 +1026,7 @@ atomic_exp: { mk_exp (E_exit $3) $startpos $endpos } | Sizeof Lparen typ Rparen { mk_exp (E_sizeof $3) $startpos $endpos } - | Constraint Lparen nc Rparen + | Constraint Lparen typ Rparen { mk_exp (E_constraint $3) $startpos $endpos } | Assert Lparen exp Rparen { mk_exp (E_assert ($3, mk_lit_exp (L_string "") $startpos($4) $endpos($4))) $startpos $endpos } @@ -1175,17 +1146,7 @@ param_kopt_list: { $1 :: $3 } typaram: - | ColonColonLt param_kopt_list Gt Lparen param_kopt_list Rparen Comma nc - { future_syntax (loc $startpos($1) $endpos($3)); - let qi_nc = QI_aux (QI_const $8, loc $startpos($8) $endpos($8)) in - mk_typq ($5 @ $2) [qi_nc] $startpos $endpos } - | ColonColonLt param_kopt_list Gt Lparen param_kopt_list Rparen - { future_syntax (loc $startpos($1) $endpos($3)); - mk_typq ($5 @ $2) [] $startpos $endpos } - | ColonColonLt param_kopt_list Gt - { future_syntax (loc $startpos($1) $endpos($3)); - mk_typq $2 [] $startpos $endpos } - | Lparen param_kopt_list Rparen Comma nc + | Lparen param_kopt_list Rparen Comma typ { let qi_nc = QI_aux (QI_const $5, loc $startpos($5) $endpos($5)) in mk_typq $2 [qi_nc] $startpos $endpos } | Lparen param_kopt_list Rparen diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index f9908c71..5201744b 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -146,9 +146,8 @@ let doc_nc nc = end | _ -> parens' (separate_map (space ^^ bar ^^ space) nc1 disjs) and nc1 (NC_aux (nc_aux, _) as nc) = - match nc_aux with - | NC_and (c1, c2) -> separate space [nc1 c1; string "&"; atomic_nc c2] - | _ -> atomic_nc nc + let conjs = constraint_conj nc in + separate_map (space ^^ string "&" ^^ space) atomic_nc conjs in atomic_nc (constraint_simp nc) -- cgit v1.2.3 From 2c25110ad2f5e636239ba65a2154aae79ffa253c Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Fri, 7 Dec 2018 21:53:29 +0000 Subject: Working on better flow typing for ASL On a new branch because it's completely broken everything for now --- src/ast_util.ml | 168 +++++----- src/ast_util.mli | 42 +-- src/constraint.ml | 229 ++++---------- src/constraint.mli | 34 +- src/initial_check.ml | 22 +- src/lexer.mll | 1 + src/ocaml_backend.ml | 9 +- src/parse_ast.ml | 3 +- src/parser.mly | 12 +- src/pretty_print_coq.ml | 3 +- src/pretty_print_lem.ml | 3 +- src/pretty_print_sail.ml | 10 +- src/rewriter.ml | 2 +- src/rewrites.ml | 7 +- src/spec_analysis.ml | 4 +- src/state.ml | 10 +- src/type_check.ml | 799 +++++++++++++++++------------------------------ src/type_check.mli | 19 +- src/type_error.ml | 7 +- 19 files changed, 514 insertions(+), 870 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index e9153f7a..788008d1 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -370,23 +370,16 @@ let nc_lt n1 n2 = nc_lteq (nsum n1 (nint 1)) n2 let nc_gt n1 n2 = nc_gteq n1 (nsum n2 (nint 1)) let nc_and nc1 nc2 = mk_nc (NC_and (nc1, nc2)) let nc_or nc1 nc2 = mk_nc (NC_or (nc1, nc2)) +let nc_var kid = mk_nc (NC_var kid) let nc_true = mk_nc NC_true let nc_false = mk_nc NC_false -let rec nc_negate (NC_aux (nc, l)) = - match nc with - | NC_bounded_ge (n1, n2) -> nc_lt n1 n2 - | NC_bounded_le (n1, n2) -> nc_gt n1 n2 - | NC_equal (n1, n2) -> nc_neq n1 n2 - | NC_not_equal (n1, n2) -> nc_eq n1 n2 - | NC_and (n1, n2) -> mk_nc (NC_or (nc_negate n1, nc_negate n2)) - | NC_or (n1, n2) -> mk_nc (NC_and (nc_negate n1, nc_negate n2)) - | NC_false -> mk_nc NC_true - | NC_true -> mk_nc NC_false - | NC_set (kid, []) -> nc_false - | NC_set (kid, [int]) -> nc_neq (nvar kid) (nconstant int) - | NC_set (kid, int :: ints) -> - mk_nc (NC_and (nc_neq (nvar kid) (nconstant int), nc_negate (mk_nc (NC_set (kid, ints))))) +let arg_nexp ?loc:(l=Parse_ast.Unknown) n = Typ_arg_aux (Typ_arg_nexp n, l) +let arg_order ?loc:(l=Parse_ast.Unknown) ord = Typ_arg_aux (Typ_arg_order ord, l) +let arg_typ ?loc:(l=Parse_ast.Unknown) typ = Typ_arg_aux (Typ_arg_typ typ, l) +let arg_bool ?loc:(l=Parse_ast.Unknown) nc = Typ_arg_aux (Typ_arg_bool nc, l) + +let nc_not nc = mk_nc (NC_app (mk_id "not", [arg_bool nc])) let mk_typschm typq typ = TypSchm_aux (TypSchm_ts (typq, typ), Parse_ast.Unknown) @@ -437,6 +430,7 @@ let unaux_nexp (Nexp_aux (nexp, _)) = nexp let unaux_order (Ord_aux (ord, _)) = ord let unaux_typ (Typ_aux (typ, _)) = typ let unaux_kind (K_aux (k, _)) = k +let unaux_constraint (NC_aux (nc, _)) = nc let rec map_exp_annot f (E_aux (exp, annot)) = E_aux (map_exp_annot_aux f exp, f annot) and map_exp_annot_aux f = function @@ -628,6 +622,7 @@ let string_of_kind_aux = function | K_type -> "Type" | K_int -> "Int" | K_order -> "Order" + | K_bool -> "Bool" let string_of_kind (K_aux (k, _)) = string_of_kind_aux k @@ -680,6 +675,7 @@ and string_of_typ_arg_aux = function | Typ_arg_nexp n -> string_of_nexp n | Typ_arg_typ typ -> string_of_typ typ | Typ_arg_order o -> string_of_order o + | Typ_arg_bool nc -> string_of_n_constraint nc and string_of_n_constraint = function | NC_aux (NC_equal (n1, n2), _) -> string_of_nexp n1 ^ " = " ^ string_of_nexp n2 | NC_aux (NC_not_equal (n1, n2), _) -> string_of_nexp n1 ^ " != " ^ string_of_nexp n2 @@ -691,6 +687,8 @@ and string_of_n_constraint = function "(" ^ string_of_n_constraint nc1 ^ " & " ^ string_of_n_constraint nc2 ^ ")" | NC_aux (NC_set (kid, ns), _) -> string_of_kid kid ^ " in {" ^ string_of_list ", " Big_int.to_string ns ^ "}" + | NC_aux (NC_app (id, args), _) -> string_of_id id ^ "(" ^ string_of_list ", " string_of_typ_arg args ^ ")" + | NC_aux (NC_var v, _) -> string_of_kid v | NC_aux (NC_true, _) -> "true" | NC_aux (NC_false, _) -> "false" @@ -1142,10 +1140,13 @@ let rec tyvars_of_constraint (NC_aux (nc, _)) = | NC_or (nc1, nc2) | NC_and (nc1, nc2) -> KidSet.union (tyvars_of_constraint nc1) (tyvars_of_constraint nc2) + | NC_app (id, args) -> + List.fold_left (fun s t -> KidSet.union s (tyvars_of_typ_arg t)) KidSet.empty args + | NC_var kid -> KidSet.singleton kid | NC_true | NC_false -> KidSet.empty -let rec tyvars_of_typ (Typ_aux (t,_)) = +and tyvars_of_typ (Typ_aux (t,_)) = match t with | Typ_internal_unknown -> KidSet.empty | Typ_id _ -> KidSet.empty @@ -1166,6 +1167,7 @@ and tyvars_of_typ_arg (Typ_arg_aux (ta,_)) = | Typ_arg_nexp nexp -> tyvars_of_nexp nexp | Typ_arg_typ typ -> tyvars_of_typ typ | Typ_arg_order _ -> KidSet.empty + | Typ_arg_bool nc -> tyvars_of_constraint nc let tyvars_of_quant_item (QI_aux (qi, _)) = match qi with | QI_id (KOpt_aux ((KOpt_none kid | KOpt_kind (_, kid)), _)) -> @@ -1547,10 +1549,26 @@ let unique l = (* 1. Substitutions *) (**************************************************************************) +let order_subst_aux sv subst = function + | Ord_var kid -> + begin match subst with + | Typ_arg_aux (Typ_arg_order ord, _) when Kid.compare kid sv = 0 -> + unaux_order ord + | _ -> Ord_var kid + end + | Ord_inc -> Ord_inc + | Ord_dec -> Ord_dec + +let order_subst sv subst (Ord_aux (ord, l)) = Ord_aux (order_subst_aux sv subst ord, l) + let rec nexp_subst sv subst (Nexp_aux (nexp, l)) = Nexp_aux (nexp_subst_aux sv subst nexp, l) and nexp_subst_aux sv subst = function - | Nexp_id v -> Nexp_id v - | Nexp_var kid -> if Kid.compare kid sv = 0 then subst else Nexp_var kid + | Nexp_var kid -> + begin match subst with + | Typ_arg_aux (Typ_arg_nexp n, _) when Kid.compare kid sv = 0 -> unaux_nexp n + | _ -> Nexp_var kid + end + | Nexp_id id -> Nexp_id id | Nexp_constant c -> Nexp_constant c | Nexp_times (nexp1, nexp2) -> Nexp_times (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2) | Nexp_sum (nexp1, nexp2) -> Nexp_sum (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2) @@ -1564,100 +1582,68 @@ let rec nexp_set_to_or l subst = function | [int] -> NC_equal (subst, nconstant int) | (int :: ints) -> NC_or (mk_nc (NC_equal (subst, nconstant int)), mk_nc (nexp_set_to_or l subst ints)) -let rec nc_subst_nexp sv subst (NC_aux (nc, l)) = NC_aux (nc_subst_nexp_aux l sv subst nc, l) -and nc_subst_nexp_aux l sv subst = function +let rec constraint_subst sv subst (NC_aux (nc, l)) = NC_aux (constraint_subst_aux l sv subst nc, l) +and constraint_subst_aux l sv subst = function | NC_equal (n1, n2) -> NC_equal (nexp_subst sv subst n1, nexp_subst sv subst n2) | NC_bounded_ge (n1, n2) -> NC_bounded_ge (nexp_subst sv subst n1, nexp_subst sv subst n2) | NC_bounded_le (n1, n2) -> NC_bounded_le (nexp_subst sv subst n1, nexp_subst sv subst n2) | NC_not_equal (n1, n2) -> NC_not_equal (nexp_subst sv subst n1, nexp_subst sv subst n2) | NC_set (kid, ints) as set_nc -> - if Kid.compare kid sv = 0 - then nexp_set_to_or l (mk_nexp subst) ints - else set_nc - | NC_or (nc1, nc2) -> NC_or (nc_subst_nexp sv subst nc1, nc_subst_nexp sv subst nc2) - | NC_and (nc1, nc2) -> NC_and (nc_subst_nexp sv subst nc1, nc_subst_nexp sv subst nc2) + begin match subst with + | Typ_arg_aux (Typ_arg_nexp n, _) when Kid.compare kid sv = 0 -> + nexp_set_to_or l n ints + | _ -> set_nc + end + | NC_or (nc1, nc2) -> NC_or (constraint_subst sv subst nc1, constraint_subst sv subst nc2) + | NC_and (nc1, nc2) -> NC_and (constraint_subst sv subst nc1, constraint_subst sv subst nc2) + | NC_app (id, args) -> NC_app (id, List.map (typ_arg_subst sv subst) args) + | NC_var kid -> + begin match subst with + | Typ_arg_aux (Typ_arg_bool nc, _) when Kid.compare kid sv = 0 -> + unaux_constraint nc + | _ -> NC_var kid + end | NC_false -> NC_false | NC_true -> NC_true -let rec typ_subst_nexp sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_nexp_aux sv subst typ, l) -and typ_subst_nexp_aux sv subst = function +and typ_subst sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_aux sv subst typ, l) +and typ_subst_aux sv subst = function | Typ_internal_unknown -> Typ_internal_unknown | Typ_id v -> Typ_id v - | Typ_var kid -> Typ_var kid - | Typ_fn (arg_typs, ret_typ, effs) -> Typ_fn (List.map (typ_subst_nexp sv subst) arg_typs, typ_subst_nexp sv subst ret_typ, effs) - | Typ_bidir (typ1, typ2) -> Typ_bidir (typ_subst_nexp sv subst typ1, typ_subst_nexp sv subst typ2) - | Typ_tup typs -> Typ_tup (List.map (typ_subst_nexp sv subst) typs) - | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_nexp sv subst) args) + | Typ_var kid -> + begin match subst with + | Typ_arg_aux (Typ_arg_typ typ, _) when Kid.compare kid sv = 0 -> + unaux_typ typ + | _ -> Typ_var kid + end + | Typ_fn (arg_typs, ret_typ, effs) -> Typ_fn (List.map (typ_subst sv subst) arg_typs, typ_subst sv subst ret_typ, effs) + | Typ_bidir (typ1, typ2) -> Typ_bidir (typ_subst sv subst typ1, typ_subst sv subst typ2) + | Typ_tup typs -> Typ_tup (List.map (typ_subst sv subst) typs) + | Typ_app (f, args) -> Typ_app (f, List.map (typ_arg_subst sv subst) args) | Typ_exist (kids, nc, typ) when KidSet.mem sv (KidSet.of_list kids) -> Typ_exist (kids, nc, typ) - | Typ_exist (kids, nc, typ) -> Typ_exist (kids, nc_subst_nexp sv subst nc, typ_subst_nexp sv subst typ) -and typ_subst_arg_nexp sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_nexp_aux sv subst arg, l) -and typ_subst_arg_nexp_aux sv subst = function - | Typ_arg_nexp nexp -> Typ_arg_nexp (nexp_subst sv subst nexp) - | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_nexp sv subst typ) - | Typ_arg_order ord -> Typ_arg_order ord + | Typ_exist (kids, nc, typ) -> Typ_exist (kids, constraint_subst sv subst nc, typ_subst sv subst typ) -let rec typ_subst_typ sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_typ_aux sv subst typ, l) -and typ_subst_typ_aux sv subst = function - | Typ_internal_unknown -> Typ_internal_unknown - | Typ_id v -> Typ_id v - | Typ_var kid -> if Kid.compare kid sv = 0 then subst else Typ_var kid - | Typ_fn (arg_typs, ret_typ, effs) -> Typ_fn (List.map (typ_subst_typ sv subst) arg_typs, typ_subst_typ sv subst ret_typ, effs) - | Typ_bidir (typ1, typ2) -> Typ_bidir (typ_subst_typ sv subst typ1, typ_subst_typ sv subst typ2) - | Typ_tup typs -> Typ_tup (List.map (typ_subst_typ sv subst) typs) - | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_typ sv subst) args) - | Typ_exist (kids, nc, typ) -> Typ_exist (kids, nc, typ_subst_typ sv subst typ) -and typ_subst_arg_typ sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_typ_aux sv subst arg, l) -and typ_subst_arg_typ_aux sv subst = function - | Typ_arg_nexp nexp -> Typ_arg_nexp nexp - | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_typ sv subst typ) - | Typ_arg_order ord -> Typ_arg_order ord - -let order_subst_aux sv subst = function - | Ord_var kid -> if Kid.compare kid sv = 0 then subst else Ord_var kid - | Ord_inc -> Ord_inc - | Ord_dec -> Ord_dec - -let order_subst sv subst (Ord_aux (ord, l)) = Ord_aux (order_subst_aux sv subst ord, l) - -let rec typ_subst_order sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_order_aux sv subst typ, l) -and typ_subst_order_aux sv subst = function - | Typ_internal_unknown -> Typ_internal_unknown - | Typ_id v -> Typ_id v - | Typ_var kid -> Typ_var kid - | Typ_fn (arg_typs, ret_typ, effs) -> Typ_fn (List.map (typ_subst_order sv subst) arg_typs, typ_subst_order sv subst ret_typ, effs) - | Typ_bidir (typ1, typ2) -> Typ_bidir (typ_subst_order sv subst typ1, typ_subst_order sv subst typ2) - | Typ_tup typs -> Typ_tup (List.map (typ_subst_order sv subst) typs) - | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_order sv subst) args) - | Typ_exist (kids, nc, typ) -> Typ_exist (kids, nc, typ_subst_order sv subst typ) -and typ_subst_arg_order sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_order_aux sv subst arg, l) -and typ_subst_arg_order_aux sv subst = function - | Typ_arg_nexp nexp -> Typ_arg_nexp nexp - | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_order sv subst typ) +and typ_arg_subst sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_arg_subst_aux sv subst arg, l) +and typ_arg_subst_aux sv subst = function + | Typ_arg_nexp nexp -> Typ_arg_nexp (nexp_subst sv subst nexp) + | Typ_arg_typ typ -> Typ_arg_typ (typ_subst sv subst typ) | Typ_arg_order ord -> Typ_arg_order (order_subst sv subst ord) + | Typ_arg_bool nc -> Typ_arg_bool (constraint_subst sv subst nc) -let rec typ_subst_kid sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_kid_aux sv subst typ, l) -and typ_subst_kid_aux sv subst = function - | Typ_internal_unknown -> Typ_internal_unknown - | Typ_id v -> Typ_id v - | Typ_var kid -> if Kid.compare kid sv = 0 then Typ_var subst else Typ_var kid - | Typ_fn (arg_typs, ret_typ, effs) -> Typ_fn (List.map (typ_subst_kid sv subst) arg_typs, typ_subst_kid sv subst ret_typ, effs) - | Typ_bidir (typ1, typ2) -> Typ_bidir (typ_subst_kid sv subst typ1, typ_subst_kid sv subst typ2) - | Typ_tup typs -> Typ_tup (List.map (typ_subst_kid sv subst) typs) - | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_kid sv subst) args) - | Typ_exist (kids, nc, typ) when KidSet.mem sv (KidSet.of_list kids) -> Typ_exist (kids, nc, typ) - | Typ_exist (kids, nc, typ) -> Typ_exist (kids, nc_subst_nexp sv (Nexp_var subst) nc, typ_subst_kid sv subst typ) -and typ_subst_arg_kid sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_kid_aux sv subst arg, l) -and typ_subst_arg_kid_aux sv subst = function - | Typ_arg_nexp nexp -> Typ_arg_nexp (nexp_subst sv (Nexp_var subst) nexp) - | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_kid sv subst typ) - | Typ_arg_order ord -> Typ_arg_order (order_subst sv (Ord_var subst) ord) +let subst_kid subst sv v x = + x + |> subst sv (mk_typ_arg (Typ_arg_bool (nc_var v))) + |> subst sv (mk_typ_arg (Typ_arg_nexp (nvar v))) + |> subst sv (mk_typ_arg (Typ_arg_order (Ord_aux (Ord_var v, Parse_ast.Unknown)))) + |> subst sv (mk_typ_arg (Typ_arg_typ (mk_typ (Typ_var v)))) let quant_item_subst_kid_aux sv subst = function | QI_id (KOpt_aux (KOpt_none kid, l)) as qid -> if Kid.compare kid sv = 0 then QI_id (KOpt_aux (KOpt_none subst, l)) else qid | QI_id (KOpt_aux (KOpt_kind (k, kid), l)) as qid -> if Kid.compare kid sv = 0 then QI_id (KOpt_aux (KOpt_kind (k, subst), l)) else qid - | QI_const nc -> QI_const (nc_subst_nexp sv (Nexp_var subst) nc) + | QI_const nc -> + QI_const (subst_kid constraint_subst sv subst nc) let quant_item_subst_kid sv subst (QI_aux (quant, l)) = QI_aux (quant_item_subst_kid_aux sv subst quant, l) diff --git a/src/ast_util.mli b/src/ast_util.mli index 19fc017d..73ab4a01 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -97,6 +97,7 @@ val unaux_nexp : nexp -> nexp_aux val unaux_order : order -> order_aux val unaux_typ : typ -> typ_aux val unaux_kind : kind -> kind_aux +val unaux_constraint : n_constraint -> n_constraint_aux val untyp_pat : 'a pat -> 'a pat * typ option val uncast_exp : 'a exp -> 'a exp * typ option @@ -154,7 +155,7 @@ val ntimes : nexp -> nexp -> nexp val npow2 : nexp -> nexp val nvar : kid -> nexp val napp : id -> nexp list -> nexp -val nid : id -> nexp (* NOTE: Nexp_id's don't do anything currently *) +val nid : id -> nexp (* Numeric constraint builders *) val nc_eq : nexp -> nexp -> n_constraint @@ -165,15 +166,16 @@ val nc_lt : nexp -> nexp -> n_constraint val nc_gt : nexp -> nexp -> n_constraint val nc_and : n_constraint -> n_constraint -> n_constraint val nc_or : n_constraint -> n_constraint -> n_constraint +val nc_not : n_constraint -> n_constraint val nc_true : n_constraint val nc_false : n_constraint val nc_set : kid -> Big_int.num list -> n_constraint val nc_int_set : kid -> int list -> n_constraint -(* Negate a n_constraint. Note that there's no NC_not constructor, so - this flips all the inequalites a the n_constraint leaves and uses - de-morgans to switch and to or and vice versa. *) -val nc_negate : n_constraint -> n_constraint +val arg_nexp : ?loc:l -> nexp -> typ_arg +val arg_order : ?loc:l -> order -> typ_arg +val arg_typ : ?loc:l -> typ -> typ_arg +val arg_bool : ?loc:l -> n_constraint -> typ_arg (* Functions for working with type quantifiers *) val quant_add : quant_item -> typquant -> typquant @@ -203,7 +205,6 @@ val def_loc : 'a def -> Parse_ast.l (* For debugging and error messages only: Not guaranteed to produce parseable SAIL, or even print all language constructs! *) -(* TODO: replace with existing pretty-printer *) val string_of_id : id -> string val string_of_kid : kid -> string val string_of_base_effect_aux : base_effect_aux -> string @@ -382,27 +383,16 @@ val unique : l -> l (** Substitutions *) -(* The function X_subst_Y substitutes a Y into something of type X, if - X = Y then the function is just X_subst. Substitutions are always - unwrapped from their aux constructors. *) -val nexp_subst : kid -> nexp_aux -> nexp -> nexp -val nc_subst_nexp : kid -> nexp_aux -> n_constraint -> n_constraint -val order_subst : kid -> order_aux -> order -> order +(* The function X_subst substitutes a type argument into something of + type X. The type of the type argument determines which kind of type + variables willb e replaced *) +val nexp_subst : kid -> typ_arg -> nexp -> nexp +val constraint_subst : kid -> typ_arg -> n_constraint -> n_constraint +val order_subst : kid -> typ_arg -> order -> order +val typ_subst : kid -> typ_arg -> typ -> typ +val typ_arg_subst : kid -> typ_arg -> typ_arg -> typ_arg -(* kid must be Int-kinded *) -val typ_subst_nexp : kid -> nexp_aux -> typ -> typ -val typ_subst_arg_nexp : kid -> nexp_aux -> typ_arg -> typ_arg - -(* kid must be Type-kinded *) -val typ_subst_typ : kid -> typ_aux -> typ -> typ -val typ_subst_arg_typ : kid -> typ_aux -> typ_arg -> typ_arg - -(* kid must be Order-kinded *) -val typ_subst_order : kid -> order_aux -> typ -> typ -val typ_subst_arg_order : kid -> order_aux -> typ_arg -> typ_arg - -val typ_subst_kid : kid -> kid -> typ -> typ -val typ_subst_arg_kid : kid -> kid -> typ_arg -> typ_arg +val subst_kid : (kid -> typ_arg -> 'a -> 'a) -> kid -> kid -> 'a -> 'a val quant_item_subst_kid : kid -> kid -> quant_item -> quant_item val typquant_subst_kid : kid -> kid -> typquant -> typquant diff --git a/src/constraint.ml b/src/constraint.ml index cf861423..460e8c76 100644 --- a/src/constraint.ml +++ b/src/constraint.ml @@ -49,86 +49,10 @@ (**************************************************************************) module Big_int = Nat_big_num +open Ast +open Ast_util open Util -(* ===== Integer Constraints ===== *) - -type nexp_op = string - -type nexp = - | NFun of (nexp_op * nexp list) - | N2n of nexp - | NConstant of Big_int.num - | NVar of int - -let big_int_op : nexp_op -> (Big_int.num -> Big_int.num -> Big_int.num) option = function - | "+" -> Some Big_int.add - | "-" -> Some Big_int.sub - | "*" -> Some Big_int.mul - | _ -> None - -let rec arith constr = - let constr' = match constr with - | NFun (op, [x; y]) -> NFun (op, [arith x; arith y]) - | N2n c -> N2n (arith c) - | c -> c - in - match constr' with - | NFun (op, [NConstant x; NConstant y]) as c -> - begin - match big_int_op op with - | Some op -> NConstant (op x y) - | None -> c - end - | N2n (NConstant x) -> NConstant (Big_int.pow_int_positive 2 (Big_int.to_int x)) - | c -> c - -(* ===== Boolean Constraints ===== *) - -type constraint_bool_op = And | Or - -type constraint_compare_op = Gt | Lt | GtEq | LtEq | Eq | NEq - -let negate_comparison = function - | Gt -> LtEq - | Lt -> GtEq - | GtEq -> Lt - | LtEq -> Gt - | Eq -> NEq - | NEq -> Eq - -type 'a constraint_bool = - | BFun of (constraint_bool_op * 'a constraint_bool * 'a constraint_bool) - | Not of 'a constraint_bool - | CFun of (constraint_compare_op * 'a * 'a) - | Forall of (int list * 'a constraint_bool) - | Boolean of bool - -let rec pairs (xs : 'a list) (ys : 'a list) : ('a * 'b) list = - match xs with - | [] -> [] - | (x :: xs) -> List.map (fun y -> (x, y)) ys @ pairs xs ys - -(* Get a set of variables from a constraint *) -module IntSet = Set.Make( - struct - let compare = Pervasives.compare - type t = int - end) - -let rec nexp_vars : nexp -> IntSet.t = function - | NConstant _ -> IntSet.empty - | NVar v -> IntSet.singleton v - | NFun (_, xs) -> List.fold_left IntSet.union IntSet.empty (List.map nexp_vars xs) - | N2n x -> nexp_vars x - -let rec constraint_vars : nexp constraint_bool -> IntSet.t = function - | BFun (_, x, y) -> IntSet.union (constraint_vars x) (constraint_vars y) - | Not x -> constraint_vars x - | CFun (_, x, y) -> IntSet.union (nexp_vars x) (nexp_vars y) - | Forall (vars, x) -> IntSet.diff (constraint_vars x) (IntSet.of_list vars) - | Boolean _ -> IntSet.empty - (* SMTLIB v2.0 format is based on S-expressions so we have a lightweight representation of those here. *) type sexpr = List of (sexpr list) | Atom of string @@ -139,47 +63,67 @@ let rec pp_sexpr : sexpr -> string = function | List xs -> "(" ^ string_of_list " " pp_sexpr xs ^ ")" | Atom x -> x -let var_decs constr = - constraint_vars constr - |> IntSet.elements - |> List.map (fun var -> sfun "declare-const" [Atom ("v" ^ string_of_int var); Atom "Int"]) - |> string_of_list "\n" pp_sexpr +let zencode_kid kid = Util.zencode_string (string_of_kid kid) -let cop_sexpr op x y = - match op with - | Gt -> sfun ">" [x; y] - | Lt -> sfun "<" [x; y] - | GtEq -> sfun ">=" [x; y] - | LtEq -> sfun "<=" [x; y] - | Eq -> sfun "=" [x; y] - | NEq -> sfun "not" [sfun "=" [x; y]] +(** Each non-Type/Order kind in Sail mapes to a type in the SMT solver *) +let smt_type l = function + | K_int -> Atom "Int" + | K_bool -> Atom "Bool" + | _ -> raise (Reporting.err_unreachable l __POS__ "Tried to pass Type or Order kinded variable to SMT solver") -let rec sexpr_of_nexp = function - | NFun (op, xs) -> sfun op (List.map sexpr_of_nexp xs) - | N2n x -> sfun "^" [Atom "2"; sexpr_of_nexp x] - | NConstant c -> Atom (Big_int.to_string c) (* CHECK: do we do negative constants right? *) - | NVar var -> Atom ("v" ^ string_of_int var) +let smt_var v = Atom ("v" ^ zencode_kid v) -let rec sexpr_of_constraint = function - | BFun (And, x, y) -> sfun "and" [sexpr_of_constraint x; sexpr_of_constraint y] - | BFun (Or, x, y) -> sfun "or" [sexpr_of_constraint x; sexpr_of_constraint y] - | Not x -> sfun "not" [sexpr_of_constraint x] - | CFun (op, x, y) -> cop_sexpr op (sexpr_of_nexp (arith x)) (sexpr_of_nexp (arith y)) - | Forall (vars, x) -> - sfun "forall" [List (List.map (fun v -> List [Atom ("v" ^ string_of_int v); Atom "Int"]) vars); sexpr_of_constraint x] - | Boolean true -> Atom "true" - | Boolean false -> Atom "false" +(** var_decs outputs the list of variables to be used by the SMT + solver in SMTLIB v2.0 format. It takes a kind_aux KBindings, as + returned by Type_check.get_typ_vars *) +let var_decs l (vars : kind_aux KBindings.t) : string = vars + |> KBindings.bindings + |> List.map (fun (v, k) -> sfun "declare-const" [smt_var v; smt_type l k]) + |> string_of_list "\n" pp_sexpr -let smtlib_of_constraints ?get_model:(get_model=false) constr : string = +let rec smt_nexp (Nexp_aux (aux, l) : nexp) : sexpr = + match aux with + | Nexp_id id -> Atom (Util.zencode_string (string_of_id id)) + | Nexp_var v -> smt_var v + | Nexp_constant c -> Atom (Big_int.to_string c) + | Nexp_app (id, nexps) -> sfun (string_of_id id) (List.map smt_nexp nexps) + | Nexp_times (nexp1, nexp2) -> sfun "*" [smt_nexp nexp1; smt_nexp nexp2] + | Nexp_sum (nexp1, nexp2) -> sfun "+" [smt_nexp nexp1; smt_nexp nexp2] + | Nexp_minus (nexp1, nexp2) -> sfun "-" [smt_nexp nexp1; smt_nexp nexp2] + | Nexp_exp nexp -> sfun "^" [Atom "2"; smt_nexp nexp] + | Nexp_neg nexp -> sfun "-" [smt_nexp nexp] + +let rec smt_constraint (NC_aux (aux, l) : n_constraint) : sexpr = + match aux with + | NC_equal (nexp1, nexp2) -> sfun "=" [smt_nexp nexp1; smt_nexp nexp2] + | NC_bounded_le (nexp1, nexp2) -> sfun "<=" [smt_nexp nexp1; smt_nexp nexp2] + | NC_bounded_ge (nexp1, nexp2) -> sfun ">=" [smt_nexp nexp1; smt_nexp nexp2] + | NC_not_equal (nexp1, nexp2) -> sfun "not" [sfun "=" [smt_nexp nexp1; smt_nexp nexp2]] + | NC_set (v, ints) -> + sfun "or" (List.map (fun i -> sfun "=" [smt_var v; Atom (Big_int.to_string i)]) ints) + | NC_or (nc1, nc2) -> sfun "or" [smt_constraint nc1; smt_constraint nc2] + | NC_and (nc1, nc2) -> sfun "and" [smt_constraint nc1; smt_constraint nc2] + | NC_app (id, args) -> + sfun (string_of_id id) (List.map smt_typ_arg args) + | NC_true -> Atom "true" + | NC_false -> Atom "false" + | NC_var v -> smt_var v + +and smt_typ_arg (Typ_arg_aux (aux, l) : typ_arg) : sexpr = + match aux with + | Typ_arg_nexp nexp -> smt_nexp nexp + | Typ_arg_bool nc -> smt_constraint nc + | _ -> + raise (Reporting.err_unreachable l __POS__ "Tried to pass Type or Order kind to SMT function") + +let smtlib_of_constraints ?get_model:(get_model=false) l vars constr : string = "(push)\n" - ^ var_decs constr ^ "\n" - ^ pp_sexpr (sfun "define-fun" [Atom "constraint"; List []; Atom "Bool"; sexpr_of_constraint constr]) + ^ var_decs l vars ^ "\n" + ^ pp_sexpr (sfun "define-fun" [Atom "constraint"; List []; Atom "Bool"; smt_constraint constr]) ^ "\n(assert constraint)\n(check-sat)" ^ (if get_model then "\n(get-model)" else "") ^ "\n(pop)" -type t = nexp constraint_bool - type smt_result = Unknown | Sat | Unsat module DigestMap = Map.Make(Digest) @@ -219,9 +163,9 @@ let save_digests () = DigestMap.iter output !known_problems; close_out out_chan -let call_z3' constraints : smt_result = +let call_z3' l vars constraints : smt_result = let problems = [constraints] in - let z3_file = smtlib_of_constraints constraints in + let z3_file = smtlib_of_constraints l vars constraints in (* prerr_endline (Printf.sprintf "SMTLIB2 constraints are: \n%s%!" z3_file); *) @@ -261,15 +205,15 @@ let call_z3' constraints : smt_result = else (known_problems := DigestMap.add digest Unknown !known_problems; Unknown) end -let call_z3 constraints = +let call_z3 l vars constraints = let t = Profile.start_z3 () in - let result = call_z3' constraints in + let result = call_z3' l vars constraints in Profile.finish_z3 t; result -let rec solve_z3 constraints var = +let rec solve_z3 l vars constraints var = let problems = [constraints] in - let z3_file = smtlib_of_constraints ~get_model:true constraints in + let z3_file = smtlib_of_constraints ~get_model:true l vars constraints in (* prerr_endline (Printf.sprintf "SMTLIB2 constraints are: \n%s%!" z3_file); *) @@ -289,62 +233,13 @@ let rec solve_z3 constraints var = let z3_output = String.concat " " (input_all z3_chan) in let _ = Unix.close_process_in z3_chan in Sys.remove input_file; - let regexp = {|(define-fun v|} ^ string_of_int var ^ {| () Int[ ]+\([0-9]+\))|} in + let regexp = {|(define-fun v|} ^ Util.zencode_string (string_of_kid var) ^ {| () Int[ ]+\([0-9]+\))|} in try let _ = Str.search_forward (Str.regexp regexp) z3_output 0 in let result = Big_int.of_string (Str.matched_group 1 z3_output) in - begin match call_z3 (BFun (And, constraints, CFun (NEq, NConstant result, NVar var))) with + begin match call_z3 l vars (nc_and constraints (nc_neq (nconstant result) (nvar var))) with | Unsat -> Some result | _ -> None end with Not_found -> None - -let string_of constr = smtlib_of_constraints constr - -(* ===== Abstract API for building constraints ===== *) - -(* These functions are exported from constraint.mli, and ensure that - the internal representation of constraints remains opaque. *) - -let implies (x : t) (y : t) : t = - BFun (Or, Not x, y) - -let conj (x : t) (y : t) : t = - BFun (And, x, y) - -let disj (x : t) (y : t) : t = - BFun (Or, x, y) - -let forall (vars : int list) (x : t) : t = - if vars = [] then x else Forall (vars, x) - -let negate (x : t) : t = Not x - -let literal (b : bool) : t = Boolean b - -let lt x y : t = CFun (Lt, x, y) - -let lteq x y : t = CFun (LtEq, x, y) - -let gt x y : t = CFun (Gt, x, y) - -let gteq x y : t = CFun (GtEq, x, y) - -let eq x y : t = CFun (Eq, x, y) - -let neq x y : t = CFun (NEq, x, y) - -let pow2 x : nexp = N2n x - -let add x y : nexp = NFun ("+", [x; y]) - -let sub x y : nexp = NFun ("-", [x; y]) - -let mult x y : nexp = NFun ("*", [x; y]) - -let app f xs : nexp = NFun (f, xs) - -let constant (x : Big_int.num) : nexp = NConstant x - -let variable (v : int) : nexp = NVar v diff --git a/src/constraint.mli b/src/constraint.mli index df9c8b3a..51088245 100644 --- a/src/constraint.mli +++ b/src/constraint.mli @@ -49,40 +49,14 @@ (**************************************************************************) module Big_int = Nat_big_num - -type nexp -type t +open Ast +open Ast_util type smt_result = Unknown | Sat | Unsat val load_digests : unit -> unit val save_digests : unit -> unit -val call_z3 : t -> smt_result - -val solve_z3 : t -> int -> Big_int.num option - -val string_of : t -> string - -val implies : t -> t -> t -val conj : t -> t -> t -val disj : t -> t -> t -val negate : t -> t -val literal : bool -> t -val forall : int list -> t -> t - -val lt : nexp -> nexp -> t -val lteq : nexp -> nexp -> t -val gt : nexp -> nexp -> t -val gteq : nexp -> nexp -> t -val eq : nexp -> nexp -> t -val neq : nexp -> nexp -> t - -val pow2 : nexp -> nexp -val add : nexp -> nexp -> nexp -val sub : nexp -> nexp -> nexp -val mult : nexp -> nexp -> nexp -val app : string -> nexp list -> nexp +val call_z3 : l -> kind_aux KBindings.t -> n_constraint -> smt_result -val constant : Big_int.num -> nexp -val variable : int -> nexp +val solve_z3 : l -> kind_aux KBindings.t -> n_constraint -> kid -> Big_int.num option diff --git a/src/initial_check.ml b/src/initial_check.ml index b57e6b17..e84f655c 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -85,6 +85,7 @@ let to_ast_kind (P.K_aux (k, l)) = | P.K_type -> K_aux (K_type, l) | P.K_int -> K_aux (K_int, l) | P.K_order -> K_aux (K_order, l) + | P.K_bool -> K_aux (K_bool, l) let to_ast_id (P.Id_aux(id, l)) = if string_contains (string_of_parse_id_aux id) '#' && not (!opt_magic_hash) then @@ -143,6 +144,8 @@ let rec to_ast_typ ctx (P.ATyp_aux (aux, l)) = | P.ATyp_tup typs -> Typ_tup (List.map (to_ast_typ ctx) typs) | P.ATyp_app (P.Id_aux (P.Id "int", il), [n]) -> Typ_app (Id_aux (Id "atom", il), [to_ast_typ_arg ctx n K_int]) + | P.ATyp_app (P.Id_aux (P.Id "bool", il), [n]) -> + Typ_app (Id_aux (Id "atom_bool", il), [to_ast_typ_arg ctx n K_bool]) | P.ATyp_app (id, args) -> let id = to_ast_id id in begin match Bindings.find_opt id ctx.type_constructors with @@ -166,6 +169,7 @@ and to_ast_typ_arg ctx (ATyp_aux (_, l) as atyp) = function | K_type -> Typ_arg_aux (Typ_arg_typ (to_ast_typ ctx atyp), l) | K_int -> Typ_arg_aux (Typ_arg_nexp (to_ast_nexp ctx atyp), l) | K_order -> Typ_arg_aux (Typ_arg_order (to_ast_order ctx atyp), l) + | K_bool -> Typ_arg_aux (Typ_arg_bool (to_ast_constraint ctx atyp), l) and to_ast_nexp ctx (P.ATyp_aux (aux, l)) = let aux = match aux with @@ -203,6 +207,17 @@ and to_ast_constraint ctx (P.ATyp_aux (aux, l) as atyp) = | "|" -> NC_or (to_ast_constraint ctx t1, to_ast_constraint ctx t2) | _ -> raise (Reporting.err_typ l ("Invalid operator in constraint")) end + | P.ATyp_app (id, args) -> + let id = to_ast_id id in + begin match Bindings.find_opt id ctx.type_constructors with + | None -> raise (Reporting.err_typ l (sprintf "Could not find type constructor %s" (string_of_id id))) + | Some kinds when List.length args <> List.length kinds -> + raise (Reporting.err_typ l (sprintf "%s : %s -> Bool expected %d arguments, given %d" + (string_of_id id) (format_kind_aux_list kinds) + (List.length kinds) (List.length args))) + | Some kinds -> NC_app (id, List.map2 (to_ast_typ_arg ctx) args kinds) + end + | P.ATyp_var v -> NC_var (to_ast_var v) | P.ATyp_lit (P.L_aux (P.L_true, _)) -> NC_true | P.ATyp_lit (P.L_aux (P.L_false, _)) -> NC_false | P.ATyp_nset (id, bounds) -> NC_set (to_ast_var id, bounds) @@ -490,11 +505,12 @@ let add_constructor id typq ctx = let to_ast_typedef ctx (P.TD_aux (aux, l) : P.type_def) : unit type_def ctx_out = let aux, ctx = match aux with - | P.TD_abbrev (id, namescm_opt, P.TypSchm_aux (P.TypSchm_ts (typq, typ), l)) -> + | P.TD_abbrev (id, typq, kind, typ_arg) -> let id = to_ast_id id in let typq, typq_ctx = to_ast_typquant ctx typq in - let typ = to_ast_typ typq_ctx typ in - TD_abbrev (id, to_ast_namescm namescm_opt, TypSchm_aux (TypSchm_ts (typq, typ), l)), + let kind = to_ast_kind kind in + let typ_arg = to_ast_typ_arg typq_ctx typ_arg (unaux_kind kind) in + TD_abbrev (id, typq, typ_arg), add_constructor id typq ctx | P.TD_record (id, namescm_opt, typq, fields, _) -> diff --git a/src/lexer.mll b/src/lexer.mll index f5a982eb..57580e7a 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -140,6 +140,7 @@ let kw_table = ("ref", (fun _ -> Ref)); ("Int", (fun x -> Int)); ("Order", (fun x -> Order)); + ("Bool", (fun x -> Bool)); ("pure", (fun x -> Pure)); ("register", (fun x -> Register)); ("return", (fun x -> Return)); diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index f3a3fa54..a3d47814 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -602,7 +602,7 @@ let ocaml_typedef ctx (TD_aux (td_aux, _)) = ^//^ (bar ^^ space ^^ ocaml_enum ctx ids)) ^^ ocaml_def_end ^^ ocaml_string_of_enum ctx id ids - | TD_abbrev (id, _, TypSchm_aux (TypSchm_ts (typq, typ), _)) -> + | TD_abbrev (id, typq, Typ_arg_aux (Typ_arg_typ typ, _)) -> separate space [string "type"; ocaml_typquant typq; zencode ctx id; equals; ocaml_typ ctx typ] ^^ ocaml_def_end ^^ ocaml_string_of_abbrev ctx id typq typ @@ -706,7 +706,7 @@ let ocaml_pp_generators ctx defs orig_types required = -> required and add_req_from_td required (TD_aux (td,(l,_))) = match td with - | TD_abbrev (_, _, TypSchm_aux (TypSchm_ts (_,typ),_)) -> + | TD_abbrev (_, _, Typ_arg_aux (Typ_arg_typ typ, _)) -> add_req_from_typ required typ | TD_record (_, _, _, fields, _) -> List.fold_left (fun req (typ,_) -> add_req_from_typ req typ) required fields @@ -723,10 +723,11 @@ let ocaml_pp_generators ctx defs orig_types required = match Bindings.find id typemap with | TD_aux (td,_) -> (match td with - | TD_abbrev (_,_,TypSchm_aux (TypSchm_ts (tqs,typ),_)) -> tqs + | TD_abbrev (_,tqs,Typ_arg_aux (Typ_arg_typ _, _)) -> tqs | TD_record (_,_,tqs,_,_) -> tqs | TD_variant (_,_,tqs,_,_) -> tqs | TD_enum _ -> TypQ_aux (TypQ_no_forall,Unknown) + | TD_abbrev (_, _, _) -> assert false | TD_bitfield _ -> assert false) | exception Not_found -> Bindings.find id Type_check.Env.builtin_typs @@ -844,7 +845,7 @@ let ocaml_pp_generators ctx defs orig_types required = let tqs, body, constructors, builders = let TD_aux (td,(l,_)) = Bindings.find id typemap in match td with - | TD_abbrev (_,_,TypSchm_aux (TypSchm_ts (tqs,typ),_)) -> + | TD_abbrev (_,tqs,Typ_arg_aux (Typ_arg_typ typ, _)) -> tqs, gen_type typ, None, None | TD_variant (_,_,tqs,variants,_) -> tqs, diff --git a/src/parse_ast.ml b/src/parse_ast.ml index 204389f9..c57daa26 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -74,6 +74,7 @@ kind_aux = (* base kind *) K_type (* kind of types *) | K_int (* kind of natural number size expressions *) | K_order (* kind of vector order specifications *) + | K_bool (* kind of constraints *) type @@ -443,7 +444,7 @@ fundef_aux = (* Function definition *) type type_def_aux = (* Type definition body *) - TD_abbrev of id * name_scm_opt * typschm (* type abbreviation *) + TD_abbrev of id * typquant * kind * atyp (* type abbreviation *) | TD_record of id * name_scm_opt * typquant * ((atyp * id)) list * bool (* struct type definition *) | TD_variant of id * name_scm_opt * typquant * (type_union) list * bool (* union type definition *) | TD_enum of id * name_scm_opt * (id) list * bool (* enumeration type definition *) diff --git a/src/parser.mly b/src/parser.mly index bb5aa5f1..fa36591c 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -175,7 +175,7 @@ let rec desugar_rchain chain s e = /*Terminals with no content*/ %token And As Assert Bitzero Bitone By Match Clause Dec Default Effect End Op Where -%token Enum Else False Forall Foreach Overload Function_ Mapping If_ In Inc Let_ Int Order Cast +%token Enum Else False Forall Foreach Overload Function_ Mapping If_ In Inc Let_ Int Order Bool Cast %token Pure Register Return Scattered Sizeof Struct Then True TwoCaret TYPE Typedef %token Undefined Union Newtype With Val Constant Constraint Throw Try Catch Exit Bitfield %token Barr Depend Rreg Wreg Rmem Rmemt Wmem Wmv Wmvt Eamem Exmem Undef Unspec Nondet Escape @@ -563,6 +563,8 @@ kind: { K_aux (K_type, loc $startpos $endpos) } | Order { K_aux (K_order, loc $startpos $endpos) } + | Bool + { K_aux (K_bool, loc $startpos $endpos) } kopt: | Lparen kid Colon kind Rparen @@ -1154,9 +1156,13 @@ typaram: type_def: | Typedef id typaram Eq typ - { mk_td (TD_abbrev ($2, mk_namesectn, mk_typschm $3 $5 $startpos($3) $endpos)) $startpos $endpos } + { mk_td (TD_abbrev ($2, $3, K_aux (K_type, Parse_ast.Unknown), $5)) $startpos $endpos } | Typedef id Eq typ - { mk_td (TD_abbrev ($2, mk_namesectn, mk_typschm mk_typqn $4 $startpos($4) $endpos)) $startpos $endpos } + { mk_td (TD_abbrev ($2, mk_typqn, K_aux (K_type, Parse_ast.Unknown), $4)) $startpos $endpos } + | Typedef id typaram MinusGt kind Eq typ + { mk_td (TD_abbrev ($2, $3, $5, $7)) $startpos $endpos } + | Typedef id Colon kind Eq typ + { mk_td (TD_abbrev ($2, mk_typqn, $4, $6)) $startpos $endpos } | Struct id Eq Lcurly struct_fields Rcurly { mk_td (TD_record ($2, mk_namesectn, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), $5, false)) $startpos $endpos } | Struct id typaram Eq Lcurly struct_fields Rcurly diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 7cc61507..50a97fa8 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -1711,7 +1711,8 @@ let rec doc_range (BF_aux(r,_)) = match r with | BF_concat(ir1,ir2) -> (doc_range ir1) ^^ comma ^^ (doc_range ir2) let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = match td with - | TD_abbrev(id,nm,(TypSchm_aux (TypSchm_ts (typq, _), _) as typschm)) -> + | TD_abbrev(id,typq,Typ_arg_aux (Typ_arg_typ typ, _)) -> + let typschm = TypSchm_aux (TypSchm_ts (typq, typ), l) in doc_op coloneq (separate space [string "Definition"; doc_id_type id; doc_typquant_items empty_ctxt parens typq; diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index be790a1c..e5613961 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -1006,7 +1006,8 @@ let rec doc_range_lem (BF_aux(r,_)) = match r with | BF_concat(ir1,ir2) -> (doc_range ir1) ^^ comma ^^ (doc_range ir2) let doc_typdef_lem (TD_aux(td, (l, annot))) = match td with - | TD_abbrev(id,nm,(TypSchm_aux (TypSchm_ts (typq, _), _) as typschm)) -> + | TD_abbrev(id,typq,Typ_arg_aux (Typ_arg_typ typ, _)) -> + let typschm = TypSchm_aux (TypSchm_ts (typq, typ), l) in doc_op equals (separate space [string "type"; doc_id_lem_type id; doc_typquant_items_lem None typq]) (doc_typschm_lem false typschm) diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index 5201744b..7fb67a06 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -259,7 +259,7 @@ let doc_typschm ?(simple=false) (TypSchm_aux (TypSchm_ts (typq, typ), _)) = doc_ let doc_typschm_typ (TypSchm_aux (TypSchm_ts (TypQ_aux (tq_aux, _), typ), _)) = doc_typ typ -let doc_typschm_quants (TypSchm_aux (TypSchm_ts (TypQ_aux (tq_aux, _), typ), _)) = +let doc_typquant (TypQ_aux (tq_aux, _)) = match tq_aux with | TypQ_no_forall -> None | TypQ_tq [] -> None @@ -562,13 +562,13 @@ let doc_field (typ, id) = let doc_union (Tu_aux (Tu_ty_id (typ, id), l)) = separate space [doc_id id; colon; doc_typ typ] let doc_typdef (TD_aux(td,_)) = match td with - | TD_abbrev (id, _, typschm) -> + | TD_abbrev (id, typq, typ_arg) -> begin - match doc_typschm_quants typschm with + match doc_typquant typq with | Some qdoc -> - doc_op equals (concat [string "type"; space; doc_id id; qdoc]) (doc_typschm_typ typschm) + doc_op equals (concat [string "type"; space; doc_id id; qdoc]) (doc_typ_arg typ_arg) | None -> - doc_op equals (concat [string "type"; space; doc_id id]) (doc_typschm_typ typschm) + doc_op equals (concat [string "type"; space; doc_id id]) (doc_typ_arg typ_arg) end | TD_enum (id, _, ids, _) -> separate space [string "enum"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_id ids) rbrace] diff --git a/src/rewriter.ml b/src/rewriter.ml index 77070025..200121c0 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -94,7 +94,7 @@ let lookup_generated_kid env kid = let generated_kids typ = KidSet.filter is_kid_generated (tyvars_of_typ typ) let resolve_generated_kids env typ = - let subst_kid kid typ = typ_subst_kid kid (lookup_generated_kid env kid) typ in + let subst_kid kid typ = subst_kid typ_subst kid (lookup_generated_kid env kid) typ in KidSet.fold subst_kid (generated_kids typ) typ let rec remove_p_typ = function diff --git a/src/rewrites.ml b/src/rewrites.ml index 0ead9670..82228206 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2300,9 +2300,10 @@ let rewrite_constraint = let rewrite_type_union_typs rw_typ (Tu_aux (Tu_ty_id (typ, id), annot)) = Tu_aux (Tu_ty_id (rw_typ typ, id), annot) -let rewrite_type_def_typs rw_typ rw_typquant rw_typschm (TD_aux (td, annot)) = +let rewrite_type_def_typs rw_typ rw_typquant (TD_aux (td, annot)) = match td with - | TD_abbrev (id, nso, typschm) -> TD_aux (TD_abbrev (id, nso, rw_typschm typschm), annot) + | TD_abbrev (id, typq, Typ_arg_aux (Typ_arg_typ typ, l)) -> + TD_aux (TD_abbrev (id, rw_typquant typq, Typ_arg_aux (Typ_arg_typ (rw_typ typ), l)), annot) | TD_record (id, nso, typq, typ_ids, flag) -> TD_aux (TD_record (id, nso, rw_typquant typq, List.map (fun (typ, id) -> (rw_typ typ, id)) typ_ids, flag), annot) | TD_variant (id, nso, typq, tus, flag) -> @@ -2396,7 +2397,7 @@ let rewrite_simple_types (Defs defs) = in let simple_def = function | DEF_spec vs -> DEF_spec (simple_vs vs) - | DEF_type td -> DEF_type (rewrite_type_def_typs simple_typ simple_typquant simple_typschm td) + | DEF_type td -> DEF_type (rewrite_type_def_typs simple_typ simple_typquant td) | DEF_reg_dec ds -> DEF_reg_dec (rewrite_dec_spec_typs simple_typ ds) | def -> def in diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index 9453e999..84fa8235 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -309,7 +309,9 @@ let fv_of_kind_def consider_var (KD_aux(k,_)) = match k with | KD_nabbrev(_,id,_,nexp) -> init_env (string_of_id id), fv_of_nexp consider_var mt mt nexp let fv_of_type_def consider_var (TD_aux(t,_)) = match t with - | TD_abbrev(id,_,typschm) -> init_env (string_of_id id), snd (fv_of_typschm consider_var mt mt typschm) + | TD_abbrev(id,typq,Typ_arg_aux(Typ_arg_typ typ, l)) -> + let typschm = TypSchm_aux (TypSchm_ts (typq,typ), l) in + init_env (string_of_id id), snd (fv_of_typschm consider_var mt mt typschm) | TD_record(id,_,typq,tids,_) -> let binds = init_env (string_of_id id) in let bounds = if consider_var then typq_bindings typq else mt in diff --git a/src/state.ml b/src/state.ml index 31f5c7eb..00f81bf4 100644 --- a/src/state.ml +++ b/src/state.ml @@ -127,15 +127,9 @@ let generate_initial_regstate defs = | Typ_exist (_, _, typ) -> lookup_init_val vals typ | _ -> raise Not_found in - (* Helper functions to instantiate type arguments *) - let typ_subst_targ kid (Typ_arg_aux (arg, _)) typ = match arg with - | Typ_arg_nexp (Nexp_aux (nexp, _)) -> typ_subst_nexp kid nexp typ - | Typ_arg_typ (Typ_aux (typ', _)) -> typ_subst_typ kid typ' typ - | Typ_arg_order (Ord_aux (ord, _)) -> typ_subst_order kid ord typ - in let typ_subst_quant_item typ (QI_aux (qi, _)) arg = match qi with | QI_id (KOpt_aux ((KOpt_none kid | KOpt_kind (_, kid)), _)) -> - typ_subst_targ kid arg typ + typ_subst kid arg typ | _ -> typ in let typ_subst_typquant tq args typ = @@ -152,7 +146,7 @@ let generate_initial_regstate defs = string_of_id id1 ^ " (" ^ lookup_init_val vals typ1 ^ ")" in Bindings.add id init_val vals - | TD_abbrev (id, _, TypSchm_aux (TypSchm_ts (tq, typ), _)) -> + | TD_abbrev (id, tq, Typ_arg_aux (Typ_arg_typ typ, _)) -> let init_val args = lookup_init_val vals (typ_subst_typquant tq args typ) in Bindings.add id init_val vals | TD_record (id, _, tq, fields, _) -> diff --git a/src/type_check.ml b/src/type_check.ml index f204a558..2c10b8ae 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -167,6 +167,8 @@ and strip_n_constraint_aux = function | NC_set (kid, nums) -> NC_set (strip_kid kid, nums) | NC_or (nc1, nc2) -> NC_or (strip_n_constraint nc1, strip_n_constraint nc2) | NC_and (nc1, nc2) -> NC_and (strip_n_constraint nc1, strip_n_constraint nc2) + | NC_var kid -> NC_var (strip_kid kid) + | NC_app (id, args) -> NC_app (strip_id id, List.map strip_typ_arg args) | NC_true -> NC_true | NC_false -> NC_false and strip_n_constraint = function @@ -177,6 +179,7 @@ and strip_typ_arg_aux = function | Typ_arg_nexp nexp -> Typ_arg_nexp (strip_nexp nexp) | Typ_arg_typ typ -> Typ_arg_typ (strip_typ typ) | Typ_arg_order ord -> Typ_arg_order (strip_order ord) + | Typ_arg_bool nc -> Typ_arg_bool (strip_n_constraint nc) and strip_order = function | Ord_aux (ord_aux, _) -> Ord_aux (strip_order_aux ord_aux, Parse_ast.Unknown) and strip_order_aux = function @@ -256,9 +259,8 @@ module Env : sig val add_typ_var : l -> kid -> kind_aux -> t -> t val get_ret_typ : t -> typ option val add_ret_typ : typ -> t -> t - val add_typ_synonym : id -> (t -> typ_arg list -> typ) -> t -> t - val get_typ_synonym : id -> t -> t -> typ_arg list -> typ - val add_constraint_synonym : id -> kid list -> n_constraint -> t -> t + val add_typ_synonym : id -> (t -> typ_arg list -> typ_arg) -> t -> t + val get_typ_synonym : id -> t -> t -> typ_arg list -> typ_arg val add_num_def : id -> nexp -> t -> t val get_num_def : id -> t -> nexp val add_overloads : id -> id list -> t -> t @@ -282,6 +284,7 @@ module Env : sig val lookup_id : ?raw:bool -> id -> t -> typ lvar val fresh_kid : ?kid:kid -> t -> kid val expand_synonyms : t -> typ -> typ + val expand_constraint_synonyms : t -> n_constraint -> n_constraint val canonicalize : t -> typ -> typ val base_typ_of : t -> typ -> typ val add_smt_op : id -> string -> t -> t @@ -320,7 +323,7 @@ end = struct variants : (typquant * type_union list) Bindings.t; mappings : (typquant * typ * typ) Bindings.t; typ_vars : (Ast.l * kind_aux) KBindings.t; - typ_synonyms : (t -> typ_arg list -> typ) Bindings.t; + typ_synonyms : (t -> typ_arg list -> typ_arg) Bindings.t; num_defs : nexp Bindings.t; overloads : (id list) Bindings.t; flow : (typ -> typ) Bindings.t; @@ -329,7 +332,6 @@ end = struct accessors : (typquant * typ) Bindings.t; externs : (string -> string option) Bindings.t; smt_ops : string Bindings.t; - constraint_synonyms : (kid list * n_constraint) Bindings.t; casts : id list; allow_casts : bool; allow_bindings : bool; @@ -359,7 +361,6 @@ end = struct accessors = Bindings.empty; externs = Bindings.empty; smt_ops = Bindings.empty; - constraint_synonyms = Bindings.empty; casts = []; allow_bindings = true; allow_casts = true; @@ -465,8 +466,8 @@ end = struct let kopts, ncs = quant_split typq in let rec subst_args kopts args = match kopts, args with - | kopt :: kopts, Typ_arg_aux (Typ_arg_nexp arg, _) :: args when is_nat_kopt kopt -> - List.map (nc_subst_nexp (kopt_kid kopt) (unaux_nexp arg)) (subst_args kopts args) + | kopt :: kopts, (Typ_arg_aux (Typ_arg_nexp _, _) as arg) :: args when is_nat_kopt kopt -> + List.map (constraint_subst (kopt_kid kopt) arg) (subst_args kopts args) | kopt :: kopts, Typ_arg_aux (Typ_arg_typ arg, _) :: args when is_typ_kopt kopt -> subst_args kopts args | kopt :: kopts, Typ_arg_aux (Typ_arg_order arg, _) :: args when is_order_kopt kopt -> @@ -480,28 +481,41 @@ end = struct then () else typ_error (id_loc id) ("Could not prove " ^ string_of_list ", " string_of_n_constraint ncs ^ " for type constructor " ^ string_of_id id) - let rec expand_synonyms env (Typ_aux (typ, l) as t) = + let rec expand_constraint_synonyms env (NC_aux (aux, l) as nc) = + match aux with + | NC_or (nc1, nc2) -> NC_aux (NC_or (expand_constraint_synonyms env nc1, expand_constraint_synonyms env nc2), l) + | NC_and (nc1, nc2) -> NC_aux (NC_and (expand_constraint_synonyms env nc1, expand_constraint_synonyms env nc2), l) + | NC_app (id, args) -> + (try + begin match Bindings.find id env.typ_synonyms env args with + | Typ_arg_aux (Typ_arg_bool nc, _) -> expand_constraint_synonyms env nc + | _ -> typ_error l ("Expected Type when expanding synonym " ^ string_of_id id) + end + with Not_found -> NC_aux (NC_app (id, List.map (expand_synonyms_arg env) args), l)) + | NC_true | NC_false | NC_equal _ | NC_not_equal _ | NC_bounded_le _ | NC_bounded_ge _ | NC_var _ | NC_set _ -> nc + + and expand_synonyms env (Typ_aux (typ, l) as t) = match typ with | Typ_internal_unknown -> Typ_aux (Typ_internal_unknown, l) | Typ_tup typs -> Typ_aux (Typ_tup (List.map (expand_synonyms env) typs), l) | Typ_fn (arg_typs, ret_typ, effs) -> Typ_aux (Typ_fn (List.map (expand_synonyms env) arg_typs, expand_synonyms env ret_typ, effs), l) | Typ_bidir (typ1, typ2) -> Typ_aux (Typ_bidir (expand_synonyms env typ1, expand_synonyms env typ2), l) | Typ_app (id, args) -> - begin - try - let synonym = Bindings.find id env.typ_synonyms in - expand_synonyms env (synonym env args) - with - | Not_found -> Typ_aux (Typ_app (id, List.map (expand_synonyms_arg env) args), l) - end + (try + begin match Bindings.find id env.typ_synonyms env args with + | Typ_arg_aux (Typ_arg_typ typ, _) -> expand_synonyms env typ + | _ -> typ_error l ("Expected Type when expanding synonym " ^ string_of_id id) + end + with + | Not_found -> Typ_aux (Typ_app (id, List.map (expand_synonyms_arg env) args), l)) | Typ_id id -> - begin - try - let synonym = Bindings.find id env.typ_synonyms in - expand_synonyms env (synonym env []) - with - | Not_found -> Typ_aux (Typ_id id, l) - end + (try + begin match Bindings.find id env.typ_synonyms env [] with + | Typ_arg_aux (Typ_arg_typ typ, _) -> expand_synonyms env typ + | _ -> typ_error l ("Expected Type when expanding synonym " ^ string_of_id id) + end + with + | Not_found -> Typ_aux (Typ_id id, l)) | Typ_exist (kids, nc, typ) -> (* When expanding an existential synonym we need to take care to add the type variables and constraints to the @@ -524,8 +538,8 @@ end = struct let env = List.fold_left add_typ_var env kids in let kids = List.map rename_kid kids in - let nc = List.fold_left (fun nc kid -> nc_subst_nexp kid (Nexp_var (prepend_kid "syn#" kid)) nc) nc !rebindings in - let typ = List.fold_left (fun typ kid -> typ_subst_nexp kid (Nexp_var (prepend_kid "syn#" kid)) typ) typ !rebindings in + let nc = List.fold_left (fun nc kid -> constraint_subst kid (arg_nexp (nvar (prepend_kid "syn#" kid))) nc) nc !rebindings in + let typ = List.fold_left (fun typ kid -> typ_subst kid (arg_nexp (nvar (prepend_kid "syn#" kid))) typ) typ !rebindings in typ_debug (lazy ("Synonym existential: {" ^ string_of_list " " string_of_kid kids ^ ", " ^ string_of_n_constraint nc ^ ". " ^ string_of_typ typ ^ "}")); let env = { env with constraints = nc :: env.constraints } in Typ_aux (Typ_exist (kids, nc, expand_synonyms env typ), l) @@ -533,6 +547,7 @@ end = struct and expand_synonyms_arg env (Typ_arg_aux (typ_arg, l)) = match typ_arg with | Typ_arg_typ typ -> Typ_arg_aux (Typ_arg_typ (expand_synonyms env typ), l) + | Typ_arg_bool nc -> Typ_arg_aux (Typ_arg_bool (expand_constraint_synonyms env nc), l) | arg -> Typ_arg_aux (arg, l) (** Map over all nexps in a type - excluding those in existential constraints **) @@ -547,7 +562,7 @@ end = struct | Typ_app (id, args) -> Typ_aux (Typ_app (id, List.map (map_nexps_arg f) args), l) and map_nexps_arg f (Typ_arg_aux (arg_aux, l) as arg) = match arg_aux with - | Typ_arg_order _ | Typ_arg_typ _ -> arg + | Typ_arg_order _ | Typ_arg_typ _ | Typ_arg_bool _ -> arg | Typ_arg_nexp n -> Typ_arg_aux (Typ_arg_nexp (f n), l) let canonical env typ = @@ -600,7 +615,6 @@ end = struct (* Check if a type, order, n-expression or constraint is well-formed. Throws a type error if the type is badly formed. *) let rec wf_typ ?exs:(exs=KidSet.empty) env typ = - typ_debug (lazy ("well-formed " ^ string_of_typ typ)); let (Typ_aux (typ_aux, l)) = expand_synonyms env typ in match typ_aux with | Typ_id id when bound_typ_id env id -> @@ -637,8 +651,8 @@ end = struct | Typ_arg_nexp nexp -> wf_nexp ~exs:exs env nexp | Typ_arg_typ typ -> wf_typ ~exs:exs env typ | Typ_arg_order ord -> wf_order env ord + | Typ_arg_bool nc -> wf_constraint ~exs:exs env nc and wf_nexp ?exs:(exs=KidSet.empty) env (Nexp_aux (nexp_aux, l) as nexp) = - typ_debug (lazy ("well-formed nexp " ^ string_of_nexp nexp)); match nexp_aux with | Nexp_id _ -> () | Nexp_var kid when KidSet.mem kid exs -> () @@ -671,22 +685,29 @@ end = struct end | Ord_inc | Ord_dec -> () and wf_constraint ?exs:(exs=KidSet.empty) env (NC_aux (nc_aux, l) as nc) = - typ_debug (lazy ("well-formed constraint " ^ string_of_n_constraint nc)); match nc_aux with | NC_equal (n1, n2) -> wf_nexp ~exs:exs env n1; wf_nexp ~exs:exs env n2 | NC_not_equal (n1, n2) -> wf_nexp ~exs:exs env n1; wf_nexp ~exs:exs env n2 | NC_bounded_ge (n1, n2) -> wf_nexp ~exs:exs env n1; wf_nexp ~exs:exs env n2 | NC_bounded_le (n1, n2) -> wf_nexp ~exs:exs env n1; wf_nexp ~exs:exs env n2 | NC_set (kid, _) when KidSet.mem kid exs -> () - | NC_set (kid, _) -> begin - match get_typ_var kid env with - | K_int -> () - | kind -> typ_error l ("Set constraint is badly formed, " - ^ string_of_kid kid ^ " has kind " - ^ string_of_kind_aux kind ^ " but should have kind Int") - end + | NC_set (kid, _) -> + begin match get_typ_var kid env with + | K_int -> () + | kind -> typ_error l ("Set constraint is badly formed, " + ^ string_of_kid kid ^ " has kind " + ^ string_of_kind_aux kind ^ " but should have kind Int") + end | NC_or (nc1, nc2) -> wf_constraint ~exs:exs env nc1; wf_constraint ~exs:exs env nc2 | NC_and (nc1, nc2) -> wf_constraint ~exs:exs env nc1; wf_constraint ~exs:exs env nc2 + | NC_app (id, args) -> List.iter (wf_typ_arg ~exs:exs env) args + | NC_var kid -> + begin match get_typ_var kid env with + | K_bool -> () + | kind -> typ_error l ("Set constraint is badly formed, " + ^ string_of_kid kid ^ " has kind " + ^ string_of_kind_aux kind ^ " but should have kind Bool") + end | NC_true | NC_false -> () let counter = ref 0 @@ -699,7 +720,7 @@ end = struct let freshen_kid env kid (typq, typ) = let fresh = fresh_kid ~kid:kid env in if KidSet.mem kid (KidSet.of_list (List.map kopt_kid (quant_kopts typq))) then - (typquant_subst_kid kid fresh typq, typ_subst_kid kid fresh typ) + (typquant_subst_kid kid fresh typq, subst_kid typ_subst kid fresh typ) else (typq, typ) @@ -733,8 +754,8 @@ end = struct match expand_synonyms env typ with | Typ_aux (Typ_exist (kids, nc, typ), _) -> let fresh_kids = List.map (fun kid -> (kid, fresh_existential ~name:(string_of_id (id_of_kid kid)) ())) kids in - let nc = List.fold_left (fun nc (kid, fresh) -> nc_subst_nexp kid (Nexp_var fresh) nc) nc fresh_kids in - let typ = List.fold_left (fun typ (kid, fresh) -> typ_subst_nexp kid (Nexp_var fresh) typ) typ fresh_kids in + let nc = List.fold_left (fun nc (kid, fresh) -> constraint_subst kid (arg_nexp (nvar fresh)) nc) nc fresh_kids in + let typ = List.fold_left (fun typ (kid, fresh) -> typ_subst kid (arg_nexp (nvar fresh)) typ) typ fresh_kids in Some (List.map snd fresh_kids, nc, typ) | _ -> None @@ -1067,16 +1088,6 @@ end = struct let get_typ_synonym id env = Bindings.find id env.typ_synonyms - let add_constraint_synonym id kids nc env = - if Bindings.mem id env.constraint_synonyms - then typ_error (id_loc id) ("Constraint synonym " ^ string_of_id id ^ " already exists") - else - begin - typ_print (lazy (adding ^ "constraint synonym " ^ string_of_id id)); - wf_constraint ~exs:(KidSet.of_list kids) env nc; - { env with constraint_synonyms = Bindings.add id (kids, nc) env.constraint_synonyms } - end - let get_default_order env = match env.default_order with | None -> typ_error Parse_ast.Unknown ("No default order has been set") @@ -1154,8 +1165,8 @@ let destruct_exist env typ = match Env.expand_synonyms env typ with | Typ_aux (Typ_exist (kids, nc, typ), _) -> let fresh_kids = List.map (fun kid -> (kid, fresh_existential ~name:(string_of_id (id_of_kid kid)) ())) kids in - let nc = List.fold_left (fun nc (kid, fresh) -> nc_subst_nexp kid (Nexp_var fresh) nc) nc fresh_kids in - let typ = List.fold_left (fun typ (kid, fresh) -> typ_subst_nexp kid (Nexp_var fresh) typ) typ fresh_kids in + let nc = List.fold_left (fun nc (kid, fresh) -> constraint_subst kid (arg_nexp (nvar fresh)) nc) nc fresh_kids in + let typ = List.fold_left (fun typ (kid, fresh) -> typ_subst kid (arg_nexp (nvar fresh)) typ) typ fresh_kids in Some (List.map snd fresh_kids, nc, typ) | _ -> None @@ -1282,65 +1293,18 @@ this is equivalent to which is then a problem we can feed to the constraint solver expecting unsat. *) -let rec nexp_constraint env var_of (Nexp_aux (nexp, l)) = - match nexp with - | Nexp_id v -> nexp_constraint env var_of (Env.get_num_def v env) - | Nexp_var kid -> Constraint.variable (var_of kid) - | Nexp_constant c -> Constraint.constant c - | Nexp_times (nexp1, nexp2) -> Constraint.mult (nexp_constraint env var_of nexp1) (nexp_constraint env var_of nexp2) - | Nexp_sum (nexp1, nexp2) -> Constraint.add (nexp_constraint env var_of nexp1) (nexp_constraint env var_of nexp2) - | Nexp_minus (nexp1, nexp2) -> Constraint.sub (nexp_constraint env var_of nexp1) (nexp_constraint env var_of nexp2) - | Nexp_exp nexp -> Constraint.pow2 (nexp_constraint env var_of nexp) - | Nexp_neg nexp -> Constraint.sub (Constraint.constant (Big_int.of_int 0)) (nexp_constraint env var_of nexp) - | Nexp_app (id, nexps) -> Constraint.app (Env.get_smt_op id env) (List.map (nexp_constraint env var_of) nexps) - -let rec nc_constraint env var_of (NC_aux (nc, l)) = - match nc with - | NC_equal (nexp1, nexp2) -> Constraint.eq (nexp_constraint env var_of nexp1) (nexp_constraint env var_of nexp2) - | NC_not_equal (nexp1, nexp2) -> Constraint.neq (nexp_constraint env var_of nexp1) (nexp_constraint env var_of nexp2) - | NC_bounded_ge (nexp1, nexp2) -> Constraint.gteq (nexp_constraint env var_of nexp1) (nexp_constraint env var_of nexp2) - | NC_bounded_le (nexp1, nexp2) -> Constraint.lteq (nexp_constraint env var_of nexp1) (nexp_constraint env var_of nexp2) - | NC_set (_, []) -> Constraint.literal false - | NC_set (kid, (int :: ints)) -> - List.fold_left Constraint.disj - (Constraint.eq (nexp_constraint env var_of (nvar kid)) (Constraint.constant int)) - (List.map (fun i -> Constraint.eq (nexp_constraint env var_of (nvar kid)) (Constraint.constant i)) ints) - | NC_or (nc1, nc2) -> Constraint.disj (nc_constraint env var_of nc1) (nc_constraint env var_of nc2) - | NC_and (nc1, nc2) -> Constraint.conj (nc_constraint env var_of nc1) (nc_constraint env var_of nc2) - | NC_false -> Constraint.literal false - | NC_true -> Constraint.literal true - -let rec nc_constraints env var_of ncs = - match ncs with - | [] -> Constraint.literal true - | [nc] -> nc_constraint env var_of nc - | (nc :: ncs) -> - Constraint.conj (nc_constraint env var_of nc) (nc_constraints env var_of ncs) - -let prove_z3' env constr = - let module Bindings = Map.Make(Kid) in - let bindings = ref Bindings.empty in - let fresh_var kid = - let n = Bindings.cardinal !bindings in - bindings := Bindings.add kid n !bindings; - n - in - let var_of kid = - try Bindings.find kid !bindings with - | Not_found -> fresh_var kid - in - let constr = Constraint.conj (nc_constraints env var_of (Env.get_constraints env)) (constr var_of) in - match Constraint.call_z3 constr with +let prove_z3 env (NC_aux (_, l) as nc) = + let vars = Env.get_typ_vars env in + let vars = KBindings.filter (fun _ k -> match k with K_int | K_bool -> true | _ -> false) vars in + let ncs = Env.get_constraints env in + match Constraint.call_z3 l vars (List.fold_left nc_and (nc_not nc) ncs) with | Constraint.Unsat -> typ_debug (lazy "unsat"); true | Constraint.Sat -> typ_debug (lazy "sat"); false | Constraint.Unknown -> typ_debug (lazy "unknown"); false -let prove_z3 env nc = - typ_print (lazy (Util.("Prove " |> red |> clear) ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_n_constraint nc)); - prove_z3' env (fun var_of -> Constraint.negate (nc_constraint env var_of nc)) +let solve env nexp = failwith "WIP" -let solve env nexp = - typ_print (lazy ("Solve " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_nexp nexp ^ " = ?")); + (* typ_print (lazy ("Solve " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_nexp nexp ^ " = ?")); match nexp with | Nexp_aux (Nexp_constant n,_) -> Some n | _ -> @@ -1359,8 +1323,11 @@ let solve env nexp = (nc_constraint env var_of (nc_eq (nvar (mk_kid "solve#")) nexp)) in Constraint.solve_z3 constr (var_of (mk_kid "solve#")) + *) -let prove env (NC_aux (nc_aux, _) as nc) = +let prove env nc = + typ_print (lazy (Util.("Prove " |> red |> clear) ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_n_constraint nc)); + let (NC_aux (nc_aux, _) as nc) = Env.expand_constraint_synonyms env nc in let compare_const f (Nexp_aux (n1, _)) (Nexp_aux (n2, _)) = match n1, n2 with | Nexp_constant c1, Nexp_constant c2 when f c1 c2 -> true @@ -1499,61 +1466,91 @@ let typ_identical env typ1 typ2 = in typ_identical' (Env.expand_synonyms env typ1) (Env.expand_synonyms env typ2) -type uvar = - | U_nexp of nexp - | U_order of order - | U_typ of typ +exception Unification_error of l * string;; + +let unify_error l str = raise (Unification_error (l, str)) + +let merge_unifiers l kid uvar1 uvar2 = + match uvar1, uvar2 with + | Some (Typ_arg_aux (Typ_arg_nexp n1, _)), Some (Typ_arg_aux (Typ_arg_nexp n2, _)) -> + if nexp_identical n1 n2 then + Some (arg_nexp n1) + else + unify_error l ("Multiple non-identical unifiers for " ^ string_of_kid kid + ^ ": " ^ string_of_nexp n1 ^ " and " ^ string_of_nexp n2) + | Some _, Some _ -> unify_error l "Multiple non-identical non-nexp unifiers" + | None, Some u2 -> Some u2 + | Some u1, None -> Some u1 + | None, None -> None + +let merge_uvars l unifiers1 unifiers2 = + KBindings.merge (merge_unifiers l) unifiers1 unifiers2 + +let rec unify_typ l env goals (Typ_aux (aux1, _) as typ1) (Typ_aux (aux2, _) as typ2) = + match aux1, aux2 with + | Typ_var v, _ when KidSet.mem v goals -> KBindings.singleton v (arg_typ typ2) -let uvar_subst_nexp sv subst = function - | U_nexp nexp -> U_nexp (nexp_subst sv subst nexp) - | U_typ typ -> U_typ (typ_subst_nexp sv subst typ) - | U_order ord -> U_order ord + | Typ_app (range, [Typ_arg_aux (Typ_arg_nexp n1, _); Typ_arg_aux (Typ_arg_nexp n2, _)]), + Typ_app (atom, [Typ_arg_aux (Typ_arg_nexp m, _)]) + when string_of_id range = "range" && string_of_id atom = "atom" -> + merge_uvars l (unify_nexp l env goals n1 m) (unify_nexp l env goals n2 m) -let uvar_subst_typ sv subst = function - | U_nexp nexp -> U_nexp nexp - | U_typ typ -> U_typ (typ_subst_typ sv subst typ) - | U_order ord -> U_order ord + | Typ_app (id1, args1), Typ_app (id2, args2) when List.length args1 = List.length args2 && Id.compare id1 id2 = 0 -> + List.fold_left (merge_uvars l) KBindings.empty (List.map2 (unify_typ_arg l env goals) args1 args2) -let uvar_subst_order sv subst = function - | U_nexp nexp -> U_nexp nexp - | U_typ typ -> U_typ (typ_subst_order sv subst typ) - | U_order ord -> U_order (order_subst sv subst ord) + | Typ_id id1, Typ_id id2 when Id.compare id1 id2 = 0 -> KBindings.empty -exception Unification_error of l * string;; + | Typ_tup typs1, Typ_tup typs2 when List.length typs1 = List.length typs2 -> + List.fold_left (merge_uvars l) KBindings.empty (List.map2 (unify_typ l env goals) typs1 typs2) -let unify_error l str = raise (Unification_error (l, str)) + | _, _ -> unify_error l ("Cound not unify " ^ string_of_typ typ1 ^ " and " ^ string_of_typ typ2) + +and unify_typ_arg l env goals (Typ_arg_aux (aux1, _) as typ_arg1) (Typ_arg_aux (aux2, _) as typ_arg2) = + match aux1, aux2 with + | Typ_arg_typ typ1, Typ_arg_typ typ2 -> unify_typ l env goals typ1 typ2 + | Typ_arg_nexp nexp1, Typ_arg_nexp nexp2 -> unify_nexp l env goals nexp1 nexp2 + | Typ_arg_order ord1, Typ_arg_order ord2 -> unify_order l goals ord1 ord2 + | _, _ -> unify_error l ("Could not unify type arguments " ^ string_of_typ_arg typ_arg1 ^ " and " ^ string_of_typ_arg typ_arg2) + +and unify_order l goals (Ord_aux (aux1, _) as ord1) (Ord_aux (aux2, _) as ord2) = + typ_print (lazy (Util.("Unify order " |> magenta |> clear) ^ string_of_order ord1 ^ " and " ^ string_of_order ord2)); + match aux1, aux2 with + | Ord_var v, _ when KidSet.mem v goals -> KBindings.singleton v (arg_order ord2) + | Ord_inc, Ord_inc -> KBindings.empty + | Ord_dec, Ord_dec -> KBindings.empty + | _, _ -> unify_error l ("Cound not unify " ^ string_of_order ord1 ^ " and " ^ string_of_order ord2) -let rec unify_nexps l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (nexp_aux2, _) as nexp2) = +and unify_nexp l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (nexp_aux2, _) as nexp2) = typ_debug (lazy ("UNIFYING NEXPS " ^ string_of_nexp nexp1 ^ " AND " ^ string_of_nexp nexp2 ^ " FOR GOALS " ^ string_of_list ", " string_of_kid (KidSet.elements goals))); if KidSet.is_empty (KidSet.inter (nexp_frees nexp1) goals) then begin if prove env (NC_aux (NC_equal (nexp1, nexp2), Parse_ast.Unknown)) - then None + then KBindings.empty else unify_error l ("Nexp " ^ string_of_nexp nexp1 ^ " and " ^ string_of_nexp nexp2 ^ " are not equal") end else match nexp_aux1 with | Nexp_id v -> unify_error l "Unimplemented Nexp_id in unify nexp" - | Nexp_var kid when KidSet.mem kid goals -> Some (kid, nexp2) + | Nexp_var kid when KidSet.mem kid goals -> KBindings.singleton kid (arg_nexp nexp2) | Nexp_constant c1 -> begin match nexp_aux2 with - | Nexp_constant c2 -> if c1 = c2 then None else unify_error l "Constants are not the same" + | Nexp_constant c2 -> if c1 = c2 then KBindings.empty else unify_error l "Constants are not the same" | _ -> unify_error l "Unification error" end | Nexp_sum (n1a, n1b) -> if KidSet.is_empty (nexp_frees n1b) - then unify_nexps l env goals n1a (nminus nexp2 n1b) + then unify_nexp l env goals n1a (nminus nexp2 n1b) else if KidSet.is_empty (nexp_frees n1a) - then unify_nexps l env goals n1b (nminus nexp2 n1a) + then unify_nexp l env goals n1b (nminus nexp2 n1a) else unify_error l ("Both sides of Int expression " ^ string_of_nexp nexp1 ^ " contain free type variables so it cannot be unified with " ^ string_of_nexp nexp2) | Nexp_minus (n1a, n1b) -> if KidSet.is_empty (nexp_frees n1b) - then unify_nexps l env goals n1a (nsum nexp2 n1b) - else unify_error l ("Cannot unify minus Int expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) + then unify_nexp l env goals n1a (nsum nexp2 n1b) + else unify_error l ("Cannot unify minus Int expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) | Nexp_times (n1a, n1b) -> (* If we have SMT operations div and mod, then we can use the property that @@ -1564,20 +1561,20 @@ let rec unify_nexps l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (ne if Env.have_smt_op (mk_id "div") env && Env.have_smt_op (mk_id "mod") env then let valid n c = prove env (nc_eq (napp (mk_id "mod") [n; c]) (nint 0)) && prove env (nc_neq c (nint 0)) in if KidSet.is_empty (nexp_frees n1b) && valid nexp2 n1b then - unify_nexps l env goals n1a (napp (mk_id "div") [nexp2; n1b]) + unify_nexp l env goals n1a (napp (mk_id "div") [nexp2; n1b]) else if KidSet.is_empty (nexp_frees n1a) && valid nexp2 n1a then - unify_nexps l env goals n1b (napp (mk_id "div") [nexp2; n1a]) + unify_nexp l env goals n1b (napp (mk_id "div") [nexp2; n1a]) else unify_error l ("Cannot unify Int expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) else if KidSet.is_empty (nexp_frees n1a) then begin match nexp_aux2 with | Nexp_times (n2a, n2b) when prove env (NC_aux (NC_equal (n1a, n2a), Parse_ast.Unknown)) -> - unify_nexps l env goals n1b n2b + unify_nexp l env goals n1b n2b | Nexp_constant c2 -> begin match n1a with | Nexp_aux (Nexp_constant c1,_) when Big_int.equal (Big_int.modulus c2 c1) Big_int.zero -> - unify_nexps l env goals n1b (mk_nexp (Nexp_constant (Big_int.div c2 c1))) + unify_nexp l env goals n1b (nconstant (Big_int.div c2 c1)) | _ -> unify_error l ("Cannot unify Int expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) end | _ -> unify_error l ("Cannot unify Int expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) @@ -1586,148 +1583,30 @@ let rec unify_nexps l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (ne begin match nexp_aux2 with | Nexp_times (n2a, n2b) when prove env (NC_aux (NC_equal (n1b, n2b), Parse_ast.Unknown)) -> - unify_nexps l env goals n1a n2a + unify_nexp l env goals n1a n2a | _ -> unify_error l ("Cannot unify Int expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) end else unify_error l ("Cannot unify Int expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) | _ -> unify_error l ("Cannot unify Int expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) -let string_of_uvar = function - | U_nexp n -> string_of_nexp n - | U_order o -> string_of_order o - | U_typ typ -> string_of_typ typ - -let unify_order l (Ord_aux (ord_aux1, _) as ord1) (Ord_aux (ord_aux2, _) as ord2) = - typ_debug (lazy ("UNIFYING ORDERS " ^ string_of_order ord1 ^ " AND " ^ string_of_order ord2)); - match ord_aux1, ord_aux2 with - | Ord_var kid, _ -> KBindings.singleton kid (U_order ord2) - | Ord_inc, Ord_inc -> KBindings.empty - | Ord_dec, Ord_dec -> KBindings.empty - | _, _ -> unify_error l (string_of_order ord1 ^ " cannot be unified with " ^ string_of_order ord2) +let unify l env typ1 typ2 goals = + typ_print (lazy (Util.("Unify " |> magenta |> clear) ^ string_of_typ typ1 ^ " and " ^ string_of_typ typ2)); + let typ1, typ2 = Env.expand_synonyms env typ1, Env.expand_synonyms env typ2 in + unify_typ l env goals typ1 typ2 let subst_unifiers unifiers typ = - let subst_unifier typ (kid, uvar) = - match uvar with - | U_nexp nexp -> typ_subst_nexp kid (unaux_nexp nexp) typ - | U_order ord -> typ_subst_order kid (unaux_order ord) typ - | U_typ subst -> typ_subst_typ kid (unaux_typ subst) typ - in - List.fold_left subst_unifier typ (KBindings.bindings unifiers) - -let subst_args_unifiers unifiers typ_args = - let subst_unifier typ_args (kid, uvar) = - match uvar with - | U_nexp nexp -> List.map (typ_subst_arg_nexp kid (unaux_nexp nexp)) typ_args - | U_order ord -> List.map (typ_subst_arg_order kid (unaux_order ord)) typ_args - | U_typ subst -> List.map (typ_subst_arg_typ kid (unaux_typ subst)) typ_args - in - List.fold_left subst_unifier typ_args (KBindings.bindings unifiers) - -let subst_uvar_unifiers unifiers uvar = - let subst_unifier uvar' (kid, uvar) = - match uvar with - | U_nexp nexp -> uvar_subst_nexp kid (unaux_nexp nexp) uvar' - | U_order ord -> uvar_subst_order kid (unaux_order ord) uvar' - | U_typ subst -> uvar_subst_typ kid (unaux_typ subst) uvar' - in - List.fold_left subst_unifier uvar (KBindings.bindings unifiers) - -let merge_unifiers l kid uvar1 uvar2 = - match uvar1, uvar2 with - | Some (U_nexp n1), Some (U_nexp n2) -> - if nexp_identical n1 n2 then Some (U_nexp n1) - else unify_error l ("Multiple non-identical unifiers for " ^ string_of_kid kid - ^ ": " ^ string_of_nexp n1 ^ " and " ^ string_of_nexp n2) - | Some _, Some _ -> unify_error l "Multiple non-identical non-nexp unifiers" - | None, Some u2 -> Some u2 - | Some u1, None -> Some u1 - | None, None -> None + List.fold_left (fun typ (v, arg) -> typ_subst v arg typ) typ (KBindings.bindings unifiers) -let rec unify l env typ1 typ2 = - typ_print (lazy (Util.("Unify " |> magenta |> clear) ^ string_of_typ typ1 ^ " with " ^ string_of_typ typ2)); - let goals = KidSet.inter (KidSet.diff (typ_frees typ1) (typ_frees typ2)) (typ_frees typ1) in - - let rec unify_typ l (Typ_aux (typ1_aux, _) as typ1) (Typ_aux (typ2_aux, _) as typ2) = - typ_debug (lazy ("UNIFYING TYPES " ^ string_of_typ typ1 ^ " AND " ^ string_of_typ typ2)); - match typ1_aux, typ2_aux with - | Typ_internal_unknown, _ - | _, Typ_internal_unknown when Env.allow_unknowns env -> KBindings.empty - | Typ_id v1, Typ_id v2 -> - if Id.compare v1 v2 = 0 then KBindings.empty - else unify_error l (string_of_typ typ1 ^ " cannot be unified with " ^ string_of_typ typ2) - | Typ_id v1, Typ_app (f2, []) -> - if Id.compare v1 f2 = 0 then KBindings.empty - else unify_error l (string_of_typ typ1 ^ " cannot be unified with " ^ string_of_typ typ2) - | Typ_app (f1, []), Typ_id v2 -> - if Id.compare f1 v2 = 0 then KBindings.empty - else unify_error l (string_of_typ typ1 ^ " cannot be unified with " ^ string_of_typ typ2) - | Typ_var kid, _ when KidSet.mem kid goals -> KBindings.singleton kid (U_typ typ2) - | Typ_var kid1, Typ_var kid2 when Kid.compare kid1 kid2 = 0 -> KBindings.empty - | Typ_tup typs1, Typ_tup typs2 -> - begin - try List.fold_left (KBindings.merge (merge_unifiers l)) KBindings.empty (List.map2 (unify_typ l) typs1 typs2) with - | Invalid_argument _ -> unify_error l (string_of_typ typ1 ^ " cannot be unified with " ^ string_of_typ typ2 - ^ " tuple type is of different length") - end - | Typ_app (f1, [arg1]), Typ_app (f2, [arg2a; arg2b]) - when Id.compare (mk_id "atom") f1 = 0 && Id.compare (mk_id "range") f2 = 0 -> - unify_typ_arg_list 0 KBindings.empty [] [] [arg1; arg1] [arg2a; arg2b] - | Typ_app (f1, [arg1a; arg1b]), Typ_app (f2, [arg2]) - when Id.compare (mk_id "range") f1 = 0 && Id.compare (mk_id "atom") f2 = 0 -> - unify_typ_arg_list 0 KBindings.empty [] [] [arg1a; arg1b] [arg2; arg2] - | Typ_app (f1, args1), Typ_app (f2, args2) when Id.compare f1 f2 = 0 -> - unify_typ_arg_list 0 KBindings.empty [] [] args1 args2 - | _, _ -> unify_error l (string_of_typ typ1 ^ " cannot be unified with " ^ string_of_typ typ2) - - and unify_typ_arg_list unified acc uargs1 uargs2 args1 args2 = - match args1, args2 with - | [], [] when unified = 0 && List.length uargs1 > 0 -> - unify_error l "Could not unify arg lists" (*FIXME improve error *) - | [], [] when unified > 0 && List.length uargs1 > 0 -> unify_typ_arg_list 0 acc [] [] uargs1 uargs2 - | [], [] when List.length uargs1 = 0 -> acc - | (a1 :: a1s), (a2 :: a2s) -> - begin - let unifiers, success = - try unify_typ_args l a1 a2, true with - | Unification_error _ -> KBindings.empty, false - in - let a1s = subst_args_unifiers unifiers a1s in - let a2s = subst_args_unifiers unifiers a2s in - let uargs1 = subst_args_unifiers unifiers uargs1 in - let uargs2 = subst_args_unifiers unifiers uargs2 in - if success - then unify_typ_arg_list (unified + 1) (KBindings.merge (merge_unifiers l) unifiers acc) uargs1 uargs2 a1s a2s - else unify_typ_arg_list unified acc (a1 :: uargs1) (a2 :: uargs2) a1s a2s - end - | _, _ -> unify_error l "Cannot unify type lists of different length" - - and unify_typ_args l (Typ_arg_aux (typ_arg_aux1, _) as typ_arg1) (Typ_arg_aux (typ_arg_aux2, _) as typ_arg2) = - match typ_arg_aux1, typ_arg_aux2 with - | Typ_arg_nexp n1, Typ_arg_nexp n2 -> - begin - match unify_nexps l env goals (nexp_simp n1) (nexp_simp n2) with - | Some (kid, unifier) -> KBindings.singleton kid (U_nexp (nexp_simp unifier)) - | None -> KBindings.empty - end - | Typ_arg_typ typ1, Typ_arg_typ typ2 -> unify_typ l typ1 typ2 - | Typ_arg_order ord1, Typ_arg_order ord2 -> unify_order l ord1 ord2 - | _, _ -> unify_error l (string_of_typ_arg typ_arg1 ^ " cannot be unified with type argument " ^ string_of_typ_arg typ_arg2) - in - - match destruct_exist env typ2 with - | Some (kids, nc, typ2) -> - let typ1, typ2 = Env.expand_synonyms env typ1, Env.expand_synonyms env typ2 in - let (unifiers, _, _) = unify l env typ1 typ2 in - typ_debug (lazy (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers))); - unifiers, kids, Some nc - | None -> - let typ1, typ2 = Env.expand_synonyms env typ1, Env.expand_synonyms env typ2 in - unify_typ l typ1 typ2, [], None +let instantiate_quant (v, arg) (QI_aux (aux, l) as qi) = + match aux with + | QI_id kopt when Kid.compare (kopt_kid kopt) v = 0 -> + typ_debug (lazy ("Instantiated " ^ string_of_quant_item qi)); + None + | QI_id _ -> Some qi + | QI_const nc -> Some (QI_aux (QI_const (constraint_subst v arg nc), l)) -let merge_uvars l unifiers1 unifiers2 = - try KBindings.merge (merge_unifiers l) unifiers1 unifiers2 - with - | Unification_error (_, m) -> typ_error l ("Could not merge unification variables: " ^ m) +let instantiate_quants quants unifier = + List.map (instantiate_quant unifier) quants |> Util.option_these (**************************************************************************) (* 3.5. Subtyping with existentials *) @@ -1750,16 +1629,6 @@ let destruct_atom_kid env typ = when string_of_id f = "range" && Kid.compare kid1 kid2 = 0 -> Some kid1 | _ -> None -let nc_subst_uvar kid uvar nc = - match uvar with - | U_nexp nexp -> nc_subst_nexp kid (unaux_nexp nexp) nc - | _ -> nc - -let uv_nexp_constraint env (kid, uvar) = - match uvar with - | U_nexp nexp -> Env.add_constraint (nc_eq (nvar kid) nexp) env - | _ -> env - (* The kid_order function takes a set of Int-kinded kids, and returns a list of those kids in the order they appear in a type, as well as a set containing all the kids that did not occur in the type. We @@ -1809,8 +1678,8 @@ let rec alpha_equivalent env typ1 typ2 = | Typ_exist (kids, nc, typ) -> let (kids, _) = kid_order (KidSet.of_list kids) typ in let kids = List.map (fun kid -> (kid, new_kid ())) kids in - let nc = List.fold_left (fun nc (kid, nk) -> nc_subst_nexp kid (Nexp_var nk) nc) nc kids in - let typ = List.fold_left (fun nc (kid, nk) -> typ_subst_nexp kid (Nexp_var nk) nc) typ kids in + let nc = List.fold_left (fun nc (kid, nk) -> constraint_subst kid (arg_nexp (nvar nk)) nc) nc kids in + let typ = List.fold_left (fun nc (kid, nk) -> typ_subst kid (arg_nexp (nvar nk)) nc) typ kids in let kids = List.map snd kids in Typ_exist (kids, nc, typ) | Typ_app (id, args) -> @@ -1836,6 +1705,11 @@ let unwrap_exist env typ = | Some (kids, nc, typ) -> (kids, nc, typ) | None -> ([], nc_true, typ) +let unifier_constraint env (v, arg) = + match arg with + | Typ_arg_aux (Typ_arg_nexp nexp, _) -> Env.add_constraint (nc_eq (nvar v) nexp) env + | _ -> env + let rec subtyp l env (Typ_aux (typ_aux1, _) as typ1) (Typ_aux (typ_aux2, _) as typ2) = typ_print (lazy (("Subtype " |> Util.green |> Util.clear) ^ string_of_typ typ1 ^ " and " ^ string_of_typ typ2)); match typ_aux1, typ_aux2 with @@ -1854,12 +1728,9 @@ let rec subtyp l env (Typ_aux (typ_aux1, _) as typ1) (Typ_aux (typ_aux2, _) as t let env = add_existential l kids1 nc1 env in let env = add_typ_vars l (KidSet.elements (KidSet.inter (nexp_frees nexp2) (KidSet.of_list kids2))) env in let kids2 = KidSet.elements (KidSet.diff (KidSet.of_list kids2) (nexp_frees nexp2)) in + if not (kids2 = []) then typ_error l "Universally quantified constraint generated" else (); let env = Env.add_constraint (nc_eq nexp1 nexp2) env in - let constr var_of = - Constraint.forall (List.map var_of kids2) - (nc_constraint env var_of (nc_negate nc2)) - in - if prove_z3' env constr then () + if prove env nc2 then () else typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env)) | _, _ -> match destruct_exist env typ1, unwrap_exist env (Env.canonicalize env typ2) with @@ -1869,24 +1740,14 @@ let rec subtyp l env (Typ_aux (typ_aux1, _) as typ1) (Typ_aux (typ_aux2, _) as t typ_debug (lazy "Subtype check with unification"); let env = add_typ_vars l kids env in let kids' = KidSet.elements (KidSet.diff (KidSet.of_list kids) (typ_frees typ2)) in - let unifiers, existential_kids, existential_nc = - try unify l env typ2 typ1 with + if not (kids' = []) then typ_error l "Universally quantified constraint generated" else (); + let unifiers = + try unify l env typ2 typ1 (KidSet.of_list kids) with | Unification_error (_, m) -> typ_error l m in - let nc = List.fold_left (fun nc (kid, uvar) -> nc_subst_uvar kid uvar nc) nc (KBindings.bindings unifiers) in - let env = List.fold_left uv_nexp_constraint env (KBindings.bindings unifiers) in - let env = match existential_kids, existential_nc with - | [], None -> env - | _, Some enc -> - let env = List.fold_left (fun env kid -> Env.add_typ_var l kid K_int env) env existential_kids in - Env.add_constraint enc env - | _, None -> assert false (* Cannot have existential_kids without existential_nc *) - in - let constr var_of = - Constraint.forall (List.map var_of kids') - (nc_constraint env var_of (nc_negate nc)) - in - if prove_z3' env constr then () + let nc = List.fold_left (fun nc (kid, uvar) -> constraint_subst kid uvar nc) nc (KBindings.bindings unifiers) in + let env = List.fold_left unifier_constraint env (KBindings.bindings unifiers) in + if prove env nc then () else typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env)) let typ_equality l env typ1 typ2 = @@ -1967,40 +1828,13 @@ let is_typ_kid kid = function | KOpt_aux (KOpt_kind (K_aux (K_type, _), kid'), _) -> Kid.compare kid kid' = 0 | _ -> false -let rec instantiate_quants quants kid uvar = match quants with - | [] -> [] - | ((QI_aux (QI_id kinded_id, _) as quant) :: quants) -> - typ_debug (lazy ("instantiating quant " ^ string_of_quant_item quant)); - begin - match uvar with - | U_nexp nexp -> - if is_nat_kid kid kinded_id - then instantiate_quants quants kid uvar - else quant :: instantiate_quants quants kid uvar - | U_order ord -> - if is_order_kid kid kinded_id - then instantiate_quants quants kid uvar - else quant :: instantiate_quants quants kid uvar - | U_typ typ -> - if is_typ_kid kid kinded_id - then instantiate_quants quants kid uvar - else quant :: instantiate_quants quants kid uvar - end - | ((QI_aux (QI_const nc, l)) :: quants) -> - begin - match uvar with - | U_nexp nexp -> - QI_aux (QI_const (nc_subst_nexp kid (unaux_nexp nexp) nc), l) :: instantiate_quants quants kid uvar - | _ -> (QI_aux (QI_const nc, l)) :: instantiate_quants quants kid uvar - end - let instantiate_simple_equations = let rec find_eqs kid (NC_aux (nc,_)) = match nc with | NC_equal (Nexp_aux (Nexp_var kid',_), nexp) when Kid.compare kid kid' == 0 && not (KidSet.mem kid (nexp_frees nexp)) -> - [U_nexp nexp] + [arg_nexp nexp] | NC_and (nexp1, nexp2) -> find_eqs kid nexp1 @ find_eqs kid nexp2 | _ -> [] @@ -2275,7 +2109,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ | ((E_aux (E_if (cond, (E_aux (E_throw _, _) | E_aux (E_block [E_aux (E_throw _, _)], _)), _), _) as exp) :: exps) -> let texp = crule check_exp env exp (mk_typ (Typ_id (mk_id "unit"))) in let cond' = crule check_exp env cond (mk_typ (Typ_id (mk_id "bool"))) in - let env = add_opt_constraint (option_map nc_negate (assert_constraint env false cond')) env in + let env = add_opt_constraint (option_map nc_not (assert_constraint env false cond')) env in texp :: check_block l env exps typ | (exp :: exps) -> let texp = crule check_exp env exp (mk_typ (Typ_id (mk_id "unit"))) in @@ -2318,7 +2152,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ in let check_fexp (FE_aux (FE_Fexp (field, exp), (l, ()))) = let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field env in - let unifiers, _, _ (* FIXME *) = try unify l env rectyp_q typ with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in + let unifiers = try unify l env rectyp_q typ (tyvars_of_typ rectyp_q) with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in let field_typ' = subst_unifiers unifiers field_typ in let checked_exp = crule check_exp env exp field_typ' in FE_aux (FE_Fexp (field, checked_exp), (l, None)) @@ -2333,7 +2167,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ in let check_fexp (FE_aux (FE_Fexp (field, exp), (l, ()))) = let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field env in - let unifiers, _, _ (* FIXME *) = try unify l env rectyp_q typ with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in + let unifiers = try unify l env rectyp_q typ (tyvars_of_typ rectyp_q) with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in let field_typ' = subst_unifiers unifiers field_typ in let checked_exp = crule check_exp env exp field_typ' in FE_aux (FE_Fexp (field, checked_exp), (l, None)) @@ -2413,7 +2247,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ | E_if (cond, then_branch, else_branch), _ -> let cond' = crule check_exp env cond (mk_typ (Typ_id (mk_id "bool"))) in let then_branch' = crule check_exp (add_opt_constraint (assert_constraint env true cond') env) then_branch typ in - let else_branch' = crule check_exp (add_opt_constraint (option_map nc_negate (assert_constraint env false cond')) env) else_branch typ in + let else_branch' = crule check_exp (add_opt_constraint (option_map nc_not (assert_constraint env false cond')) env) else_branch typ in annot_exp (E_if (cond', then_branch', else_branch')) typ | E_exit exp, _ -> let checked_exp = crule check_exp env exp (mk_typ (Typ_id (mk_id "unit"))) in @@ -2563,7 +2397,7 @@ and type_coercion env (E_aux (_, (l, _)) as annotated_exp) typ = required that exp_typ unifies with typ. Returns the annotated coercion as with type_coercion and also a set of unifiers, or throws a unification error *) -and type_coercion_unify env (E_aux (_, (l, _)) as annotated_exp) typ = +and type_coercion_unify env goals (E_aux (_, (l, _)) as annotated_exp) typ = let strip exp_aux = strip_exp (E_aux (exp_aux, (Parse_ast.Unknown, None))) in let annot_exp exp typ' = E_aux (exp, (l, Some ((env, typ', no_effect), Some typ))) in let switch_typ exp typ = match exp with @@ -2576,8 +2410,8 @@ and type_coercion_unify env (E_aux (_, (l, _)) as annotated_exp) typ = typ_print (lazy ("Casting with " ^ string_of_id cast ^ " expression " ^ string_of_exp annotated_exp ^ " for unification")); try let inferred_cast = irule infer_exp (Env.no_casts env) (strip (E_app (cast, [annotated_exp]))) in - let ityp = typ_of inferred_cast in - annot_exp (E_cast (ityp, inferred_cast)) ityp, unify l env typ ityp + let ityp, env = bind_existential l (typ_of inferred_cast) env in + inferred_cast, unify l env typ ityp goals, env with | Type_error (_, err) -> try_casts casts | Unification_error (_, err) -> try_casts casts @@ -2586,7 +2420,8 @@ and type_coercion_unify env (E_aux (_, (l, _)) as annotated_exp) typ = begin try typ_debug (lazy "PERFORMING COERCING UNIFICATION"); - annotated_exp, unify l env typ (typ_of annotated_exp) + let atyp, env = bind_existential l (typ_of annotated_exp) env in + annotated_exp, unify l env typ atyp goals, env with | Unification_error (_, m) when Env.allow_casts env -> let casts = filter_casts env (typ_of annotated_exp) typ (Env.get_casts env) in @@ -2708,11 +2543,11 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) | Typ_aux (Typ_fn ([arg_typ], ret_typ, _), _) -> begin try + let goals = List.fold_left KidSet.union KidSet.empty (List.map tyvars_of_quant_item quants) in typ_debug (lazy ("Unifying " ^ string_of_bind (typq, ctor_typ) ^ " for pattern " ^ string_of_typ typ)); - let unifiers, _, _ (* FIXME! *) = unify l env ret_typ typ in - typ_debug (lazy (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers))); + let unifiers = unify l env ret_typ typ goals in let arg_typ' = subst_unifiers unifiers arg_typ in - let quants' = List.fold_left (fun qs (kid, uvar) -> instantiate_quants qs kid uvar) quants (KBindings.bindings unifiers) in + let quants' = List.fold_left instantiate_quants quants (KBindings.bindings unifiers) in if (match quants' with [] -> false | _ -> true) then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in pattern " ^ string_of_pat pat) else (); @@ -2742,12 +2577,10 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) try typ_debug (lazy ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for pattern " ^ string_of_typ typ)); - let unifiers, _, _ (* FIXME! *) = unify l env typ2 typ in - - typ_debug (lazy ("unifiers: " ^ string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers))); - + (* FIXME: There's no obvious goals here *) + let unifiers = unify l env typ2 typ (tyvars_of_typ typ2) in let arg_typ' = subst_unifiers unifiers typ1 in - let quants' = List.fold_left (fun qs (kid, uvar) -> instantiate_quants qs kid uvar) quants (KBindings.bindings unifiers) in + let quants' = List.fold_left instantiate_quants quants (KBindings.bindings unifiers) in if (match quants' with [] -> false | _ -> true) then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in pattern " ^ string_of_pat pat) else (); @@ -2763,10 +2596,9 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) try typ_debug (lazy "Unifying mapping forwards failed, trying backwards."); typ_debug (lazy ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for pattern " ^ string_of_typ typ)); - let unifiers, _, _ (* FIXME! *) = unify l env typ1 typ in - typ_debug (lazy (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers))); + let unifiers = unify l env typ1 typ (tyvars_of_typ typ1) in let arg_typ' = subst_unifiers unifiers typ2 in - let quants' = List.fold_left (fun qs (kid, uvar) -> instantiate_quants qs kid uvar) quants (KBindings.bindings unifiers) in + let quants' = List.fold_left instantiate_quants quants (KBindings.bindings unifiers) in if (match quants' with [] -> false | _ -> true) then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in pattern " ^ string_of_pat pat) else (); @@ -2955,7 +2787,7 @@ and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as | Typ_aux (Typ_id rectyp_id, _) | Typ_aux (Typ_app (rectyp_id, _), _) when Env.is_record rectyp_id env -> let eff = if is_register then mk_effect [BE_wreg] else no_effect in let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field env in - let unifiers, _, _ (* FIXME *) = try unify l env rectyp_q regtyp with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in + let unifiers = try unify l env rectyp_q regtyp (tyvars_of_typ rectyp_q) with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in let field_typ' = subst_unifiers unifiers field_typ in let checked_exp = crule check_exp env exp field_typ' in annot_assign (annot_lexp (LEXP_field (annot_lexp_effect inferred_flexp regtyp eff, field)) field_typ') checked_exp, env @@ -3190,7 +3022,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = in let check_fexp (FE_aux (FE_Fexp (field, exp), (l, ()))) = let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field env in - let unifiers, _, _ (* FIXME *) = try unify l env rectyp_q typ with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in + let unifiers = try unify l env rectyp_q typ (tyvars_of_typ rectyp_q) with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in let field_typ' = subst_unifiers unifiers field_typ in let inferred_exp = crule check_exp env exp field_typ' in FE_aux (FE_Fexp (field, inferred_exp), (l, None)) @@ -3261,7 +3093,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = | E_if (cond, then_branch, else_branch) -> let cond' = crule check_exp env cond (mk_typ (Typ_id (mk_id "bool"))) in let then_branch' = irule infer_exp (add_opt_constraint (assert_constraint env true cond') env) then_branch in - let else_branch' = crule check_exp (add_opt_constraint (option_map nc_negate (assert_constraint env false cond')) env) else_branch (typ_of then_branch') in + let else_branch' = crule check_exp (add_opt_constraint (option_map nc_not (assert_constraint env false cond')) env) else_branch (typ_of then_branch') in annot_exp (E_if (cond', then_branch', else_branch')) (typ_of then_branch') | E_vector_access (v, n) -> infer_exp env (E_aux (E_app (mk_id "vector_access", [v; n]), (l, ()))) | E_vector_update (v, n, exp) -> infer_exp env (E_aux (E_app (mk_id "vector_update", [v; n; exp]), (l, ()))) @@ -3337,160 +3169,104 @@ and instantiation_of_without_type (E_aux (exp_aux, (l, _)) as exp) = | E_app (f, xs) -> snd (infer_funapp' l (Env.no_casts env) f (Env.get_val_spec f env) (List.map strip_exp xs) None) | _ -> invalid_arg ("instantiation_of expected application, got " ^ string_of_exp exp) -and infer_funapp' l env f (typq, f_typ) xs ret_ctx_typ = - let annot_exp exp typ eff = E_aux (exp, (l, Some ((env, typ, eff), ret_ctx_typ))) in - let switch_annot env typ = function - | (E_aux (exp, (l, Some (_, _, eff)))) -> E_aux (exp, (l, Some (env, typ, eff))) - | _ -> failwith "Cannot switch annot for unannotated function" - in - let all_unifiers = ref KBindings.empty in - let ex_goal = ref None in - let prove_goal env = match !ex_goal with - | Some goal when prove env goal -> () - | Some goal -> typ_error l ("Could not prove existential goal: " ^ string_of_n_constraint goal) - | None -> () - in +and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ = + let annot_exp exp typ eff = E_aux (exp, (l, Some ((env, typ, eff), expected_ret_typ))) in + let is_bound env kid = KBindings.mem kid (Env.get_typ_vars env) in + + (* First we record all the type variables when we start checking the + application, so we can distinguish them from existentials + introduced by instantiating function arguments later. *) let universals = Env.get_typ_vars env in let universal_constraints = Env.get_constraints env in - let is_bound kid env = KBindings.mem kid (Env.get_typ_vars env) in - let rec number n = function - | [] -> [] - | (x :: xs) -> (n, x) :: number (n + 1) xs - in - let solve_quant env = function - | QI_aux (QI_id _, _) -> false - | QI_aux (QI_const nc, _) -> prove env nc - in - let record_unifiers unifiers = - let previous_unifiers = !all_unifiers in - let updated_unifiers = KBindings.map (subst_uvar_unifiers unifiers) previous_unifiers in - all_unifiers := merge_uvars l updated_unifiers unifiers; - in - let rec instantiate env quants typs ret_typ args = - match typs, args with - | (utyps, []), (uargs, []) -> - begin - typ_debug (lazy ("Got unresolved args: " ^ string_of_list ", " (fun (_, exp) -> string_of_exp exp) uargs)); - if List.for_all (solve_quant env) quants - then - let iuargs = List.map2 (fun utyp (n, uarg) -> (n, crule check_exp env uarg utyp)) utyps uargs in - (iuargs, ret_typ, env) - else typ_raise l (Err_unresolved_quants (f, quants, Env.get_locals env, Env.get_constraints env)) - end - | (utyps, (typ :: typs)), (uargs, ((n, arg) :: args)) - when List.for_all (fun kid -> is_bound kid env) (KidSet.elements (typ_frees typ)) -> - begin - let carg = crule check_exp env arg typ in - let (iargs, ret_typ', env) = instantiate env quants (utyps, typs) ret_typ (uargs, args) in - ((n, carg) :: iargs, ret_typ', env) - end - | (utyps, (typ :: typs)), (uargs, ((n, arg) :: args)) -> - begin - typ_debug (lazy ("INSTANTIATE: " ^ string_of_exp arg ^ " with " ^ string_of_typ typ)); - let iarg = irule infer_exp env arg in - typ_debug (lazy ("INFER: " ^ string_of_exp arg ^ " type " ^ string_of_typ (typ_of iarg))); - try - (* If we get an existential when instantiating, we prepend - the identifier of the exisitential with the tag argN# to - denote that it was bound by the Nth argument to the - function. *) - let ex_tag = "arg" ^ string_of_int n ^ "#" in - let iarg, (unifiers, ex_kids, ex_nc) = type_coercion_unify env iarg typ in - typ_debug (lazy (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers))); - typ_debug (lazy ("EX KIDS: " ^ string_of_list ", " string_of_kid ex_kids)); - let env = match ex_kids, ex_nc with - | [], None -> env - | _, Some enc -> - let enc = List.fold_left (fun nc kid -> nc_subst_nexp kid (Nexp_var (prepend_kid ex_tag kid)) nc) enc ex_kids in - let env = List.fold_left (fun env kid -> Env.add_typ_var l (prepend_kid ex_tag kid) K_int env) env ex_kids in - Env.add_constraint enc env - | _, None -> assert false (* Cannot have ex_kids without ex_nc *) - in - let tag_unifier uvar = List.fold_left (fun uvar kid -> uvar_subst_nexp kid (Nexp_var (prepend_kid ex_tag kid)) uvar) uvar ex_kids in - let unifiers = KBindings.map tag_unifier unifiers in - record_unifiers unifiers; - let utyps' = List.map (subst_unifiers unifiers) utyps in - let typs' = List.map (subst_unifiers unifiers) typs in - let quants' = List.fold_left (fun qs (kid, uvar) -> instantiate_quants qs kid uvar) quants (KBindings.bindings unifiers) in - let ret_typ' = subst_unifiers unifiers ret_typ in - let (iargs, ret_typ'', env) = instantiate env quants' (utyps', typs') ret_typ' (uargs, args) in - ((n, iarg) :: iargs, ret_typ'', env) - with - | Unification_error (l, str) -> - typ_print (lazy ("Unification error: " ^ str)); - instantiate env quants (typ :: utyps, typs) ret_typ ((n, arg) :: uargs, args) - end - | (_, []), _ -> typ_error l ("Function " ^ string_of_id f ^ " applied to too many arguments") - | _, (_, []) -> typ_error l ("Function " ^ string_of_id f ^ " not applied to enough arguments") - in - let instantiate_ret env quants typs ret_typ = - match ret_ctx_typ with - | None -> (quants, typs, ret_typ, env) - | Some rct when is_exist (Env.expand_synonyms env rct) -> (quants, typs, ret_typ, env) - | Some rct -> - begin - typ_debug (lazy ("RCT is " ^ string_of_typ rct)); - typ_debug (lazy ("INSTANTIATE RETURN:" ^ string_of_typ ret_typ)); - let unifiers, ex_kids, ex_nc = - try unify l env ret_typ rct with - | Unification_error _ -> typ_debug (lazy "UERROR"); KBindings.empty, [], None - in - typ_debug (lazy (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers))); - if ex_kids = [] then () else (typ_debug (lazy ("EX GOAL: " ^ string_of_option string_of_n_constraint ex_nc)); ex_goal := ex_nc); - record_unifiers unifiers; - let env = List.fold_left (fun env kid -> Env.add_typ_var l kid K_int env) env ex_kids in - let typs' = List.map (subst_unifiers unifiers) typs in - let quants' = List.fold_left (fun qs (kid, uvar) -> instantiate_quants qs kid uvar) quants (KBindings.bindings unifiers) in - let ret_typ' = - match ex_nc with - | None -> subst_unifiers unifiers ret_typ - | Some nc -> mk_typ (Typ_exist (ex_kids, nc, subst_unifiers unifiers ret_typ)) - in - (quants', typs', ret_typ', env) - end - in + let quants, typ_args, typ_ret, eff = match Env.expand_synonyms env f_typ with - | Typ_aux (Typ_fn (typ_args, typ_ret, eff), _) -> quant_items typq, typ_args, typ_ret, eff + | Typ_aux (Typ_fn (typ_args, typ_ret, eff), _) -> ref (quant_items typq), typ_args, ref typ_ret, eff | _ -> typ_error l (string_of_typ f_typ ^ " is not a function type") in - let unifiers = instantiate_simple_equations quants in - typ_debug (lazy "Instantiating from equations"); - typ_debug (lazy (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers))); all_unifiers := unifiers; - let typ_args = List.map (subst_unifiers unifiers) typ_args in - let quants = List.fold_left (fun qs (kid, uvar) -> instantiate_quants qs kid uvar) quants (KBindings.bindings unifiers) in - let typ_ret = subst_unifiers unifiers typ_ret in - let quants, typ_args, typ_ret, env = - instantiate_ret env quants typ_args typ_ret + + typ_debug (lazy ("Quantifiers " ^ Util.string_of_list ", " string_of_quant_item !quants)); + + if not (List.length typ_args = List.length xs) then + typ_error l (Printf.sprintf "Function %s applied to %d args, expected %d" (string_of_id f) (List.length xs) (List.length typ_args)) + else (); + + let instantiate_quant (v, arg) (QI_aux (aux, l) as qi) = + match aux with + | QI_id kopt when Kid.compare (kopt_kid kopt) v = 0 -> None + | QI_id _ -> Some qi + | QI_const nc -> Some (QI_aux (QI_const (constraint_subst v arg nc), l)) in - let (xs_instantiated, typ_ret, env) = instantiate env quants ([], typ_args) typ_ret ([], number 0 xs) in - let xs_reordered = List.map snd (List.sort (fun (n, _) (m, _) -> compare n m) xs_instantiated) in - prove_goal env; + let typ_args = match expected_ret_typ with + | None -> typ_args + | Some expect when is_exist (Env.expand_synonyms env expect) || is_exist !typ_ret -> typ_args + | Some expect -> + let goals = List.fold_left KidSet.union KidSet.empty (List.map tyvars_of_quant_item !quants) in + try + let unifiers = unify l env !typ_ret expect goals |> KBindings.bindings in + typ_debug (lazy (Util.("Unifiers " |> magenta |> clear) + ^ Util.string_of_list ", " (fun (v, arg) -> string_of_kid v ^ " => " ^ string_of_typ_arg arg) unifiers)); + List.iter (fun unifier -> quants := instantiate_quants !quants unifier) unifiers; + List.iter (fun (v, arg) -> typ_ret := typ_subst v arg !typ_ret) unifiers; + List.map (fun typ -> List.fold_left (fun typ (v, arg) -> typ_subst v arg typ) typ unifiers) typ_args + with Unification_error _ -> typ_args + in + + (* We now iterate throught the function arguments, checking them and + instantiating quantifiers. *) + let instantiate env arg typ remaining_typs = + if KidSet.for_all (is_bound env) (tyvars_of_typ typ) then + crule check_exp env arg typ, remaining_typs, env + else + let goals = List.fold_left KidSet.union KidSet.empty (List.map tyvars_of_quant_item !quants) in + let inferred_arg = irule infer_exp env arg in + let inferred_arg, unifiers, env = + try type_coercion_unify env goals inferred_arg typ with + | Unification_error (l, m) -> typ_error l m + in + let unifiers = KBindings.bindings unifiers in + typ_debug (lazy (Util.("Unifiers " |> magenta |> clear) + ^ Util.string_of_list ", " (fun (v, arg) -> string_of_kid v ^ " => " ^ string_of_typ_arg arg) unifiers)); + List.iter (fun unifier -> quants := instantiate_quants !quants unifier) unifiers; + List.iter (fun (v, arg) -> typ_ret := typ_subst v arg !typ_ret) unifiers; + let remaining_typs = + List.map (fun typ -> List.fold_left (fun typ (v, arg) -> typ_subst v arg typ) typ unifiers) remaining_typs + in + inferred_arg, remaining_typs, env + in + let fold_instantiate (xs, args, env) x = + match args with + | arg :: remaining_args -> + let x, remaining_args, env = instantiate env x arg remaining_args in + (x :: xs, remaining_args, env) + | [] -> raise (Reporting.err_unreachable l __POS__ "Empty arguments during instantiation") + in + let xs, _, env = List.fold_left fold_instantiate ([], typ_args, env) xs in + let xs = List.rev xs in + + if not (List.for_all (solve_quant env) !quants) then + typ_raise l (Err_unresolved_quants (f, !quants, Env.get_locals env, Env.get_constraints env)) + else (); let ty_vars = List.map fst (KBindings.bindings (Env.get_typ_vars env)) in let existentials = List.filter (fun kid -> not (KBindings.mem kid universals)) ty_vars in let num_new_ncs = List.length (Env.get_constraints env) - List.length universal_constraints in - let ex_constraints = take num_new_ncs (Env.get_constraints env) in + let ex_constraints = take num_new_ncs (Env.get_constraints env) in typ_debug (lazy ("Existentials: " ^ string_of_list ", " string_of_kid existentials)); typ_debug (lazy ("Existential constraints: " ^ string_of_list ", " string_of_n_constraint ex_constraints)); let typ_ret = - if KidSet.is_empty (KidSet.of_list existentials) || KidSet.is_empty (typ_frees typ_ret) - then (typ_debug (lazy "Returning Existential"); typ_ret) - else mk_typ (Typ_exist (existentials, List.fold_left nc_and nc_true ex_constraints, typ_ret)) + if KidSet.is_empty (KidSet.of_list existentials) || KidSet.is_empty (typ_frees !typ_ret) + then !typ_ret + else mk_typ (Typ_exist (existentials, List.fold_left nc_and nc_true ex_constraints, !typ_ret)) in let typ_ret = simp_typ typ_ret in - let exp = annot_exp (E_app (f, xs_reordered)) typ_ret eff in - typ_debug (lazy ("RETURNING: " ^ string_of_typ (typ_of exp))); - match ret_ctx_typ with - | None -> - exp, !all_unifiers - | Some rct -> - let exp = type_coercion env exp rct in - typ_debug (lazy ("RETURNING AFTER COERCION " ^ string_of_typ (typ_of exp))); - exp, !all_unifiers + let exp = annot_exp (E_app (f, xs)) typ_ret eff in + typ_debug (lazy ("RETURNING: " ^ string_of_exp exp)); + + exp, KBindings.empty (* FIXME *) and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) (Typ_aux (typ_aux, _) as typ) = let (Typ_aux (typ_aux, _) as typ), env = bind_existential l typ env in @@ -3589,10 +3365,9 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) ( begin try typ_debug (lazy ("Unifying " ^ string_of_bind (typq, ctor_typ) ^ " for mapping-pattern " ^ string_of_typ typ)); - let unifiers, _, _ (* FIXME! *) = unify l env ret_typ typ in - typ_debug (lazy (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers))); + let unifiers = unify l env ret_typ typ (tyvars_of_typ ret_typ) in let arg_typ' = subst_unifiers unifiers arg_typ in - let quants' = List.fold_left (fun qs (kid, uvar) -> instantiate_quants qs kid uvar) quants (KBindings.bindings unifiers) in + let quants' = List.fold_left instantiate_quants quants (KBindings.bindings unifiers) in if (match quants' with [] -> false | _ -> true) then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in mapping-pattern " ^ string_of_mpat mpat) else (); @@ -3620,10 +3395,9 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) ( begin try typ_debug (lazy ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for mapping-pattern " ^ string_of_typ typ)); - let unifiers, _, _ (* FIXME! *) = unify l env typ2 typ in - typ_debug (lazy (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers))); + let unifiers = unify l env typ2 typ (tyvars_of_typ typ2) in let arg_typ' = subst_unifiers unifiers typ1 in - let quants' = List.fold_left (fun qs (kid, uvar) -> instantiate_quants qs kid uvar) quants (KBindings.bindings unifiers) in + let quants' = List.fold_left instantiate_quants quants (KBindings.bindings unifiers) in if (match quants' with [] -> false | _ -> true) then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in mapping-pattern " ^ string_of_mpat mpat) else (); @@ -3638,10 +3412,9 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) ( try typ_debug (lazy "Unifying mapping forwards failed, trying backwards."); typ_debug (lazy ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for mapping-pattern " ^ string_of_typ typ)); - let unifiers, _, _ (* FIXME! *) = unify l env typ1 typ in - typ_debug (lazy (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers))); + let unifiers = unify l env typ1 typ (tyvars_of_typ typ1) in let arg_typ' = subst_unifiers unifiers typ2 in - let quants' = List.fold_left (fun qs (kid, uvar) -> instantiate_quants qs kid uvar) quants (KBindings.bindings unifiers) in + let quants' = List.fold_left instantiate_quants quants (KBindings.bindings unifiers) in if (match quants' with [] -> false | _ -> true) then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in mapping-pattern " ^ string_of_mpat mpat) else (); @@ -4420,30 +4193,33 @@ let check_type_union env variant typq (Tu_aux (tu, l)) = |> Env.add_val_spec v (typq, typ') (* FIXME: This code is duplicated with general kind-checking code in environment, can they be merged? *) -let mk_synonym typq typ = +let mk_synonym typq typ_arg = let kopts, ncs = quant_split typq in let rec subst_args kopts args = match kopts, args with | kopt :: kopts, Typ_arg_aux (Typ_arg_nexp arg, _) :: args when is_nat_kopt kopt -> - let typ, ncs = subst_args kopts args in - typ_subst_nexp (kopt_kid kopt) (unaux_nexp arg) typ, - List.map (nc_subst_nexp (kopt_kid kopt) (unaux_nexp arg)) ncs + let typ_arg, ncs = subst_args kopts args in + typ_arg_subst (kopt_kid kopt) (arg_nexp arg) typ_arg, + List.map (constraint_subst (kopt_kid kopt) (arg_nexp arg)) ncs | kopt :: kopts, Typ_arg_aux (Typ_arg_typ arg, _) :: args when is_typ_kopt kopt -> - let typ, ncs = subst_args kopts args in - typ_subst_typ (kopt_kid kopt) (unaux_typ arg) typ, ncs + let typ_arg, ncs = subst_args kopts args in + typ_arg_subst (kopt_kid kopt) (arg_typ arg) typ_arg, ncs | kopt :: kopts, Typ_arg_aux (Typ_arg_order arg, _) :: args when is_order_kopt kopt -> - let typ, ncs = subst_args kopts args in - typ_subst_order (kopt_kid kopt) (unaux_order arg) typ, ncs - | [], [] -> typ, ncs + let typ_arg, ncs = subst_args kopts args in + typ_arg_subst (kopt_kid kopt) (arg_order arg) typ_arg, ncs + | kopt :: kopts, Typ_arg_aux (Typ_arg_bool arg, _) :: args when is_order_kopt kopt -> + let typ_arg, ncs = subst_args kopts args in + typ_arg_subst (kopt_kid kopt) (arg_bool arg) typ_arg, ncs + | [], [] -> typ_arg, ncs | _, Typ_arg_aux (_, l) :: _ -> typ_error l "Synonym applied to bad arguments" | _, _ -> typ_error Parse_ast.Unknown "Synonym applied to bad arguments" in fun env args -> - let typ, ncs = subst_args kopts args in + let typ_arg, ncs = subst_args kopts args in if List.for_all (prove env) ncs - then typ + then typ_arg else typ_error Parse_ast.Unknown ("Could not prove constraints " ^ string_of_list ", " string_of_n_constraint ncs - ^ " in type synonym " ^ string_of_typ typ + ^ " in type synonym " ^ string_of_typ_arg typ_arg ^ " with " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env)) let check_kinddef env (KD_aux (kdef, (l, _))) = @@ -4458,8 +4234,11 @@ let rec check_typedef : 'a. Env.t -> 'a type_def -> (tannot def) list * Env.t = fun env (TD_aux (tdef, (l, _))) -> let td_err () = raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented Typedef") in match tdef with - | TD_abbrev (id, nmscm, (TypSchm_aux (TypSchm_ts (typq, typ), _))) -> - [DEF_type (TD_aux (tdef, (l, None)))], Env.add_typ_synonym id (mk_synonym typq typ) env + | TD_abbrev (id, typq, (Typ_arg_aux (Typ_arg_typ _, _) as typ_arg)) -> + [DEF_type (TD_aux (tdef, (l, None)))], Env.add_typ_synonym id (mk_synonym typq typ_arg) env + (* For type synonyms for non-Type kinds we omit them from the AST *) + | TD_abbrev (id, typq, typ_arg) -> + [], Env.add_typ_synonym id (mk_synonym typq typ_arg) env | TD_record (id, nmscm, typq, fields, _) -> [DEF_type (TD_aux (tdef, (l, None)))], Env.add_record id typq fields env | TD_variant (id, nmscm, typq, arms, _) -> diff --git a/src/type_check.mli b/src/type_check.mli index f08272de..7dc2da30 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -149,7 +149,7 @@ module Env : sig won't throw any exceptions. *) val get_ret_typ : t -> typ option - val get_typ_synonym : id -> t -> (t -> typ_arg list -> typ) + val get_typ_synonym : id -> t -> (t -> typ_arg list -> typ_arg) val get_overloads : id -> t -> id list @@ -357,28 +357,21 @@ val destruct_numeric : Env.t -> typ -> (kid list * n_constraint * nexp) option val destruct_vector : Env.t -> typ -> (nexp * order * typ) option -type uvar = - | U_nexp of nexp - | U_order of order - | U_typ of typ +val subst_unifiers : typ_arg KBindings.t -> typ -> typ -val string_of_uvar : uvar -> string - -val subst_unifiers : uvar KBindings.t -> typ -> typ - -val unify : l -> Env.t -> typ -> typ -> uvar KBindings.t * kid list * n_constraint option +val unify : l -> Env.t -> typ -> typ -> typ_arg KBindings.t * kid list * n_constraint option val alpha_equivalent : Env.t -> typ -> typ -> bool (** Throws Invalid_argument if the argument is not a E_app expression *) -val instantiation_of : tannot exp -> uvar KBindings.t +val instantiation_of : tannot exp -> typ_arg KBindings.t (** Doesn't use the type of the expression when calculating instantiations. May fail if the arguments aren't sufficient to calculate all unifiers. *) -val instantiation_of_without_type : tannot exp -> uvar KBindings.t +val instantiation_of_without_type : tannot exp -> typ_arg KBindings.t (* Type variable instantiations that inference will extract from constraints *) -val instantiate_simple_equations : quant_item list -> uvar KBindings.t +val instantiate_simple_equations : quant_item list -> typ_arg KBindings.t val propagate_exp_effect : tannot exp -> tannot exp diff --git a/src/type_error.ml b/src/type_error.ml index 7551970f..0fa238ed 100644 --- a/src/type_error.ml +++ b/src/type_error.ml @@ -198,13 +198,16 @@ let rec analyze_unresolved_quant locals ncs = function empty let rec pp_type_error = function - | Err_no_casts (exp, typ_from, typ_to, trigger, _) -> + | Err_no_casts (exp, typ_from, typ_to, trigger, reasons) -> let coercion = group (string "Tried performing type coercion from" ^/^ Pretty_print_sail.doc_typ typ_from ^/^ string "to" ^/^ Pretty_print_sail.doc_typ typ_to ^/^ string "on" ^/^ Pretty_print_sail.doc_exp exp) in - coercion ^^ hardline ^^ (string "Failed because" ^/^ pp_type_error trigger) + coercion ^^ hardline + ^^ (string "Coercion failed because:" ^//^ pp_type_error trigger) + ^^ hardline + ^^ (string "Possible reasons:" ^//^ separate_map hardline pp_type_error reasons) | Err_no_overloading (id, errs) -> string ("No overloadings for " ^ string_of_id id ^ ", tried:") ^//^ -- cgit v1.2.3 From d8f0854ca9d80d3af8d6a4aaec778643eda9421c Mon Sep 17 00:00:00 2001 From: Alasdair Date: Sat, 8 Dec 2018 01:06:28 +0000 Subject: Compiling again Change Typ_arg_ to A_. We use it a lot more now typ_arg is used instead of uvar as the result of unify. Plus A_ could either stand for argument, or Any/A type which is quite appropriate in most use cases. Restore instantiation info in infer_funapp'. Ideally we would save this instead of recomputing it ever time we need it. However I checked and there are over 300 places in the code that would need to be changed to add an extra argument to E_app. Still some issues causing specialisation to fail however. Improve the error message when we swap how we infer/check an l-expression, as this could previously cause the actual cause of a type-checking failure to be effectively hidden. --- src/ast_util.ml | 122 +++++++++--------- src/ast_util.mli | 3 + src/c_backend.ml | 22 ++-- src/constraint.ml | 6 +- src/initial_check.ml | 12 +- src/monomorphise.ml | 150 +++++++++++----------- src/ocaml_backend.ml | 38 +++--- src/pretty_print_common.ml | 16 +-- src/pretty_print_coq.ml | 101 ++++++++------- src/pretty_print_lem.ml | 64 +++++----- src/pretty_print_sail.ml | 10 +- src/return_analysis.ml | 2 +- src/rewrites.ml | 50 ++++---- src/spec_analysis.ml | 10 +- src/specialize.ml | 79 +++++------- src/specialize.mli | 4 +- src/state.ml | 32 ++--- src/type_check.ml | 308 ++++++++++++++++++++++++--------------------- src/type_check.mli | 9 +- src/type_error.ml | 24 ++-- 20 files changed, 550 insertions(+), 512 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index 788008d1..f6b8317d 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -315,7 +315,7 @@ let rec constraint_disj (NC_aux (nc_aux, l) as nc) = | _ -> [nc] let mk_typ typ = Typ_aux (typ, Parse_ast.Unknown) -let mk_typ_arg arg = Typ_arg_aux (arg, Parse_ast.Unknown) +let mk_typ_arg arg = A_aux (arg, Parse_ast.Unknown) let mk_kid str = Kid_aux (Var ("'" ^ str), Parse_ast.Unknown) let mk_infix_id str = Id_aux (DeIid str, Parse_ast.Unknown) @@ -330,23 +330,23 @@ let unit_typ = mk_id_typ (mk_id "unit") let bit_typ = mk_id_typ (mk_id "bit") let real_typ = mk_id_typ (mk_id "real") let app_typ id args = mk_typ (Typ_app (id, args)) -let register_typ typ = mk_typ (Typ_app (mk_id "register", [mk_typ_arg (Typ_arg_typ typ)])) +let register_typ typ = mk_typ (Typ_app (mk_id "register", [mk_typ_arg (A_typ typ)])) let atom_typ nexp = - mk_typ (Typ_app (mk_id "atom", [mk_typ_arg (Typ_arg_nexp (nexp_simp nexp))])) + mk_typ (Typ_app (mk_id "atom", [mk_typ_arg (A_nexp (nexp_simp nexp))])) let range_typ nexp1 nexp2 = - mk_typ (Typ_app (mk_id "range", [mk_typ_arg (Typ_arg_nexp (nexp_simp nexp1)); - mk_typ_arg (Typ_arg_nexp (nexp_simp nexp2))])) + mk_typ (Typ_app (mk_id "range", [mk_typ_arg (A_nexp (nexp_simp nexp1)); + mk_typ_arg (A_nexp (nexp_simp nexp2))])) let bool_typ = mk_id_typ (mk_id "bool") let string_typ = mk_id_typ (mk_id "string") -let list_typ typ = mk_typ (Typ_app (mk_id "list", [mk_typ_arg (Typ_arg_typ typ)])) +let list_typ typ = mk_typ (Typ_app (mk_id "list", [mk_typ_arg (A_typ typ)])) let tuple_typ typs = mk_typ (Typ_tup typs) let function_typ arg_typs ret_typ eff = mk_typ (Typ_fn (arg_typs, ret_typ, eff)) let vector_typ n ord typ = mk_typ (Typ_app (mk_id "vector", - [mk_typ_arg (Typ_arg_nexp (nexp_simp n)); - mk_typ_arg (Typ_arg_order ord); - mk_typ_arg (Typ_arg_typ typ)])) + [mk_typ_arg (A_nexp (nexp_simp n)); + mk_typ_arg (A_order ord); + mk_typ_arg (A_typ typ)])) let exc_typ = mk_id_typ (mk_id "exception") @@ -374,10 +374,10 @@ let nc_var kid = mk_nc (NC_var kid) let nc_true = mk_nc NC_true let nc_false = mk_nc NC_false -let arg_nexp ?loc:(l=Parse_ast.Unknown) n = Typ_arg_aux (Typ_arg_nexp n, l) -let arg_order ?loc:(l=Parse_ast.Unknown) ord = Typ_arg_aux (Typ_arg_order ord, l) -let arg_typ ?loc:(l=Parse_ast.Unknown) typ = Typ_arg_aux (Typ_arg_typ typ, l) -let arg_bool ?loc:(l=Parse_ast.Unknown) nc = Typ_arg_aux (Typ_arg_bool nc, l) +let arg_nexp ?loc:(l=Parse_ast.Unknown) n = A_aux (A_nexp n, l) +let arg_order ?loc:(l=Parse_ast.Unknown) ord = A_aux (A_order ord, l) +let arg_typ ?loc:(l=Parse_ast.Unknown) typ = A_aux (A_typ typ, l) +let arg_bool ?loc:(l=Parse_ast.Unknown) nc = A_aux (A_bool nc, l) let nc_not nc = mk_nc (NC_app (mk_id "not", [arg_bool nc])) @@ -426,6 +426,14 @@ let quant_map_items f = function | TypQ_aux (TypQ_no_forall, l) -> TypQ_aux (TypQ_no_forall, l) | TypQ_aux (TypQ_tq qis, l) -> TypQ_aux (TypQ_tq (List.map f qis), l) +let is_quant_kopt = function + | QI_aux (QI_id _, _) -> true + | _ -> false + +let is_quant_constraint = function + | QI_aux (QI_const _, _) -> true + | _ -> false + let unaux_nexp (Nexp_aux (nexp, _)) = nexp let unaux_order (Ord_aux (ord, _)) = ord let unaux_typ (Typ_aux (typ, _)) = typ @@ -670,12 +678,12 @@ and string_of_typ_aux = function | Typ_exist (kids, nc, typ) -> "{" ^ string_of_list " " string_of_kid kids ^ ", " ^ string_of_n_constraint nc ^ ". " ^ string_of_typ typ ^ "}" and string_of_typ_arg = function - | Typ_arg_aux (typ_arg, l) -> string_of_typ_arg_aux typ_arg + | A_aux (typ_arg, l) -> string_of_typ_arg_aux typ_arg and string_of_typ_arg_aux = function - | Typ_arg_nexp n -> string_of_nexp n - | Typ_arg_typ typ -> string_of_typ typ - | Typ_arg_order o -> string_of_order o - | Typ_arg_bool nc -> string_of_n_constraint nc + | A_nexp n -> string_of_nexp n + | A_typ typ -> string_of_typ typ + | A_order o -> string_of_order o + | A_bool nc -> string_of_n_constraint nc and string_of_n_constraint = function | NC_aux (NC_equal (n1, n2), _) -> string_of_nexp n1 ^ " = " ^ string_of_nexp n2 | NC_aux (NC_not_equal (n1, n2), _) -> string_of_nexp n1 ^ " != " ^ string_of_nexp n2 @@ -993,13 +1001,13 @@ module Typ = struct | Typ_bidir _, _ -> -1 | _, Typ_bidir _ -> 1 | Typ_tup _, _ -> -1 | _, Typ_tup _ -> 1 | Typ_exist _, _ -> -1 | _, Typ_exist _ -> 1 - and arg_compare (Typ_arg_aux (ta1,_)) (Typ_arg_aux (ta2,_)) = + and arg_compare (A_aux (ta1,_)) (A_aux (ta2,_)) = match ta1, ta2 with - | Typ_arg_nexp n1, Typ_arg_nexp n2 -> Nexp.compare n1 n2 - | Typ_arg_typ t1, Typ_arg_typ t2 -> compare t1 t2 - | Typ_arg_order o1, Typ_arg_order o2 -> order_compare o1 o2 - | Typ_arg_nexp _, _ -> -1 | _, Typ_arg_nexp _ -> 1 - | Typ_arg_typ _, _ -> -1 | _, Typ_arg_typ _ -> 1 + | A_nexp n1, A_nexp n2 -> Nexp.compare n1 n2 + | A_typ t1, A_typ t2 -> compare t1 t2 + | A_order o1, A_order o2 -> order_compare o1 o2 + | A_nexp _, _ -> -1 | _, A_nexp _ -> 1 + | A_typ _, _ -> -1 | _, A_typ _ -> 1 end module TypMap = Map.Make(Typ) @@ -1055,21 +1063,21 @@ let is_ref_typ (Typ_aux (typ_aux, _)) = match typ_aux with let rec is_vector_typ = function | Typ_aux (Typ_app (Id_aux (Id "vector",_), [_;_;_]), _) -> true - | Typ_aux (Typ_app (Id_aux (Id "register",_), [Typ_arg_aux (Typ_arg_typ rtyp,_)]), _) -> + | Typ_aux (Typ_app (Id_aux (Id "register",_), [A_aux (A_typ rtyp,_)]), _) -> is_vector_typ rtyp | _ -> false let typ_app_args_of = function | Typ_aux (Typ_app (Id_aux (Id c,_), targs), l) -> - (c, List.map (fun (Typ_arg_aux (a,_)) -> a) targs, l) + (c, List.map (fun (A_aux (a,_)) -> a) targs, l) | Typ_aux (_, l) as typ -> raise (Reporting.err_typ l ("typ_app_args_of called on non-app type " ^ string_of_typ typ)) let rec vector_typ_args_of typ = match typ_app_args_of typ with - | ("vector", [Typ_arg_nexp len; Typ_arg_order ord; Typ_arg_typ etyp], l) -> + | ("vector", [A_nexp len; A_order ord; A_typ etyp], l) -> (nexp_simp len, ord, etyp) - | ("register", [Typ_arg_typ rtyp], _) -> vector_typ_args_of rtyp + | ("register", [A_typ rtyp], _) -> vector_typ_args_of rtyp | (_, _, l) -> raise (Reporting.err_typ l ("vector_typ_args_of called on non-vector type " ^ string_of_typ typ)) @@ -1162,12 +1170,12 @@ and tyvars_of_typ (Typ_aux (t,_)) = | Typ_exist (kids, nc, t) -> let s = KidSet.union (tyvars_of_typ t) (tyvars_of_constraint nc) in List.fold_left (fun s k -> KidSet.remove k s) s kids -and tyvars_of_typ_arg (Typ_arg_aux (ta,_)) = +and tyvars_of_typ_arg (A_aux (ta,_)) = match ta with - | Typ_arg_nexp nexp -> tyvars_of_nexp nexp - | Typ_arg_typ typ -> tyvars_of_typ typ - | Typ_arg_order _ -> KidSet.empty - | Typ_arg_bool nc -> tyvars_of_constraint nc + | A_nexp nexp -> tyvars_of_nexp nexp + | A_typ typ -> tyvars_of_typ typ + | A_order _ -> KidSet.empty + | A_bool nc -> tyvars_of_constraint nc let tyvars_of_quant_item (QI_aux (qi, _)) = match qi with | QI_id (KOpt_aux ((KOpt_none kid | KOpt_kind (_, kid)), _)) -> @@ -1184,7 +1192,7 @@ let rec undefined_of_typ mwords l annot (Typ_aux (typ_aux, _) as typ) = | Typ_app (_,[size;_;_]) when mwords && is_bitvector_typ typ -> wrap (E_app (mk_id "undefined_bitvector", undefined_of_typ_args mwords l annot size)) typ - | Typ_app (atom, [Typ_arg_aux (Typ_arg_nexp i, _)]) when string_of_id atom = "atom" -> + | Typ_app (atom, [A_aux (A_nexp i, _)]) when string_of_id atom = "atom" -> wrap (E_sizeof i) typ | Typ_app (id, args) -> wrap (E_app (prepend_id "undefined_" id, @@ -1199,11 +1207,11 @@ let rec undefined_of_typ mwords l annot (Typ_aux (typ_aux, _) as typ) = case when re-writing those functions. *) wrap (E_id (prepend_id "typ_" (id_of_kid kid))) typ | Typ_internal_unknown | Typ_bidir _ | Typ_fn _ | Typ_exist _ -> assert false (* Typ_exist should be re-written *) -and undefined_of_typ_args mwords l annot (Typ_arg_aux (typ_arg_aux, _) as typ_arg) = +and undefined_of_typ_args mwords l annot (A_aux (typ_arg_aux, _) as typ_arg) = match typ_arg_aux with - | Typ_arg_nexp n -> [E_aux (E_sizeof n, (l, annot (atom_typ n)))] - | Typ_arg_typ typ -> [undefined_of_typ mwords l annot typ] - | Typ_arg_order _ -> [] + | A_nexp n -> [E_aux (E_sizeof n, (l, annot (atom_typ n)))] + | A_typ typ -> [undefined_of_typ mwords l annot typ] + | A_order _ -> [] let destruct_pexp (Pat_aux (pexp,ann)) = match pexp with @@ -1426,13 +1434,13 @@ let rec locate_typ f (Typ_aux (typ_aux, l)) = in Typ_aux (typ_aux, f l) -and locate_typ_arg f (Typ_arg_aux (typ_arg_aux, l)) = +and locate_typ_arg f (A_aux (typ_arg_aux, l)) = let typ_arg_aux = match typ_arg_aux with - | Typ_arg_nexp nexp -> Typ_arg_nexp (locate_nexp f nexp) - | Typ_arg_typ typ -> Typ_arg_typ (locate_typ f typ) - | Typ_arg_order ord -> Typ_arg_order (locate_order f ord) + | A_nexp nexp -> A_nexp (locate_nexp f nexp) + | A_typ typ -> A_typ (locate_typ f typ) + | A_order ord -> A_order (locate_order f ord) in - Typ_arg_aux (typ_arg_aux, f l) + A_aux (typ_arg_aux, f l) let rec locate_typ_pat f (TP_aux (tp_aux, l)) = let tp_aux = match tp_aux with @@ -1552,7 +1560,7 @@ let unique l = let order_subst_aux sv subst = function | Ord_var kid -> begin match subst with - | Typ_arg_aux (Typ_arg_order ord, _) when Kid.compare kid sv = 0 -> + | A_aux (A_order ord, _) when Kid.compare kid sv = 0 -> unaux_order ord | _ -> Ord_var kid end @@ -1565,7 +1573,7 @@ let rec nexp_subst sv subst (Nexp_aux (nexp, l)) = Nexp_aux (nexp_subst_aux sv s and nexp_subst_aux sv subst = function | Nexp_var kid -> begin match subst with - | Typ_arg_aux (Typ_arg_nexp n, _) when Kid.compare kid sv = 0 -> unaux_nexp n + | A_aux (A_nexp n, _) when Kid.compare kid sv = 0 -> unaux_nexp n | _ -> Nexp_var kid end | Nexp_id id -> Nexp_id id @@ -1590,7 +1598,7 @@ and constraint_subst_aux l sv subst = function | NC_not_equal (n1, n2) -> NC_not_equal (nexp_subst sv subst n1, nexp_subst sv subst n2) | NC_set (kid, ints) as set_nc -> begin match subst with - | Typ_arg_aux (Typ_arg_nexp n, _) when Kid.compare kid sv = 0 -> + | A_aux (A_nexp n, _) when Kid.compare kid sv = 0 -> nexp_set_to_or l n ints | _ -> set_nc end @@ -1599,7 +1607,7 @@ and constraint_subst_aux l sv subst = function | NC_app (id, args) -> NC_app (id, List.map (typ_arg_subst sv subst) args) | NC_var kid -> begin match subst with - | Typ_arg_aux (Typ_arg_bool nc, _) when Kid.compare kid sv = 0 -> + | A_aux (A_bool nc, _) when Kid.compare kid sv = 0 -> unaux_constraint nc | _ -> NC_var kid end @@ -1612,7 +1620,7 @@ and typ_subst_aux sv subst = function | Typ_id v -> Typ_id v | Typ_var kid -> begin match subst with - | Typ_arg_aux (Typ_arg_typ typ, _) when Kid.compare kid sv = 0 -> + | A_aux (A_typ typ, _) when Kid.compare kid sv = 0 -> unaux_typ typ | _ -> Typ_var kid end @@ -1623,19 +1631,19 @@ and typ_subst_aux sv subst = function | Typ_exist (kids, nc, typ) when KidSet.mem sv (KidSet.of_list kids) -> Typ_exist (kids, nc, typ) | Typ_exist (kids, nc, typ) -> Typ_exist (kids, constraint_subst sv subst nc, typ_subst sv subst typ) -and typ_arg_subst sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_arg_subst_aux sv subst arg, l) +and typ_arg_subst sv subst (A_aux (arg, l)) = A_aux (typ_arg_subst_aux sv subst arg, l) and typ_arg_subst_aux sv subst = function - | Typ_arg_nexp nexp -> Typ_arg_nexp (nexp_subst sv subst nexp) - | Typ_arg_typ typ -> Typ_arg_typ (typ_subst sv subst typ) - | Typ_arg_order ord -> Typ_arg_order (order_subst sv subst ord) - | Typ_arg_bool nc -> Typ_arg_bool (constraint_subst sv subst nc) + | A_nexp nexp -> A_nexp (nexp_subst sv subst nexp) + | A_typ typ -> A_typ (typ_subst sv subst typ) + | A_order ord -> A_order (order_subst sv subst ord) + | A_bool nc -> A_bool (constraint_subst sv subst nc) let subst_kid subst sv v x = x - |> subst sv (mk_typ_arg (Typ_arg_bool (nc_var v))) - |> subst sv (mk_typ_arg (Typ_arg_nexp (nvar v))) - |> subst sv (mk_typ_arg (Typ_arg_order (Ord_aux (Ord_var v, Parse_ast.Unknown)))) - |> subst sv (mk_typ_arg (Typ_arg_typ (mk_typ (Typ_var v)))) + |> subst sv (mk_typ_arg (A_bool (nc_var v))) + |> subst sv (mk_typ_arg (A_nexp (nvar v))) + |> subst sv (mk_typ_arg (A_order (Ord_aux (Ord_var v, Parse_ast.Unknown)))) + |> subst sv (mk_typ_arg (A_typ (mk_typ (Typ_var v)))) let quant_item_subst_kid_aux sv subst = function | QI_id (KOpt_aux (KOpt_none kid, l)) as qid -> diff --git a/src/ast_util.mli b/src/ast_util.mli index 73ab4a01..fe36dfb6 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -184,6 +184,9 @@ val quant_kopts : typquant -> kinded_id list val quant_split : typquant -> kinded_id list * n_constraint list val quant_map_items : (quant_item -> quant_item) -> typquant -> typquant +val is_quant_kopt : quant_item -> bool +val is_quant_constraint : quant_item -> bool + (* Functions to map over the annotations in sub-expressions *) val map_exp_annot : ('a annot -> 'b annot) -> 'a exp -> 'b exp val map_pat_annot : ('a annot -> 'b annot) -> 'a pat -> 'b pat diff --git a/src/c_backend.ml b/src/c_backend.ml index fa21f96d..535a0b67 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -155,16 +155,16 @@ let rec ctyp_of_typ ctx typ = | _ -> CT_int end - | Typ_app (id, [Typ_arg_aux (Typ_arg_typ typ, _)]) when string_of_id id = "list" -> + | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" -> CT_list (ctyp_of_typ ctx typ) (* When converting a sail bitvector type into C, we have three options in order of efficiency: - If the length is obviously static and smaller than 64, use the fixed bits type (aka uint64_t), fbits. - If the length is less than 64, then use a small bits type, sbits. - If the length may be larger than 64, use a large bits type lbits. *) - | Typ_app (id, [Typ_arg_aux (Typ_arg_nexp n, _); - Typ_arg_aux (Typ_arg_order ord, _); - Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id vtyp_id, _)), _)]) + | Typ_app (id, [A_aux (A_nexp n, _); + A_aux (A_order ord, _); + A_aux (A_typ (Typ_aux (Typ_id vtyp_id, _)), _)]) when string_of_id id = "vector" && string_of_id vtyp_id = "bit" -> let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in begin match nexp_simp n with @@ -173,14 +173,14 @@ let rec ctyp_of_typ ctx typ = | _ -> CT_lbits direction end - | Typ_app (id, [Typ_arg_aux (Typ_arg_nexp n, _); - Typ_arg_aux (Typ_arg_order ord, _); - Typ_arg_aux (Typ_arg_typ typ, _)]) + | Typ_app (id, [A_aux (A_nexp n, _); + A_aux (A_order ord, _); + A_aux (A_typ typ, _)]) when string_of_id id = "vector" -> let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in CT_vector (direction, ctyp_of_typ ctx typ) - | Typ_app (id, [Typ_arg_aux (Typ_arg_typ typ, _)]) when string_of_id id = "register" -> + | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "register" -> CT_ref (ctyp_of_typ ctx typ) | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.records -> CT_struct (id, Bindings.find id ctx.records |> Bindings.bindings) @@ -822,7 +822,7 @@ let rec compile_aval l ctx = function [iclear (CT_lbits true) gs] (* If we have a bitvector value, that isn't a literal then we need to set bits individually. *) - | AV_vector (avals, Typ_aux (Typ_app (id, [_; Typ_arg_aux (Typ_arg_order ord, _); Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id bit_id, _)), _)]), _)) + | AV_vector (avals, Typ_aux (Typ_app (id, [_; A_aux (A_order ord, _); A_aux (A_typ (Typ_aux (Typ_id bit_id, _)), _)]), _)) when string_of_id bit_id = "bit" && string_of_id id = "vector" && List.length avals <= 64 -> let len = List.length avals in let direction = match ord with @@ -849,7 +849,7 @@ let rec compile_aval l ctx = function [] (* Compiling a vector literal that isn't a bitvector *) - | AV_vector (avals, Typ_aux (Typ_app (id, [_; Typ_arg_aux (Typ_arg_order ord, _); Typ_arg_aux (Typ_arg_typ typ, _)]), _)) + | AV_vector (avals, Typ_aux (Typ_app (id, [_; A_aux (A_order ord, _); A_aux (A_typ typ, _)]), _)) when string_of_id id = "vector" -> let len = List.length avals in let direction = match ord with @@ -878,7 +878,7 @@ let rec compile_aval l ctx = function | AV_list (avals, Typ_aux (typ, _)) -> let ctyp = match typ with - | Typ_app (id, [Typ_arg_aux (Typ_arg_typ typ, _)]) when string_of_id id = "list" -> ctyp_of_typ ctx typ + | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" -> ctyp_of_typ ctx typ | _ -> c_error "Invalid list type" in let gs = gensym () in diff --git a/src/constraint.ml b/src/constraint.ml index 460e8c76..f512eb8a 100644 --- a/src/constraint.ml +++ b/src/constraint.ml @@ -109,10 +109,10 @@ let rec smt_constraint (NC_aux (aux, l) : n_constraint) : sexpr = | NC_false -> Atom "false" | NC_var v -> smt_var v -and smt_typ_arg (Typ_arg_aux (aux, l) : typ_arg) : sexpr = +and smt_typ_arg (A_aux (aux, l) : typ_arg) : sexpr = match aux with - | Typ_arg_nexp nexp -> smt_nexp nexp - | Typ_arg_bool nc -> smt_constraint nc + | A_nexp nexp -> smt_nexp nexp + | A_bool nc -> smt_constraint nc | _ -> raise (Reporting.err_unreachable l __POS__ "Tried to pass Type or Order kind to SMT function") diff --git a/src/initial_check.ml b/src/initial_check.ml index e84f655c..0f1af63d 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -166,10 +166,10 @@ let rec to_ast_typ ctx (P.ATyp_aux (aux, l)) = Typ_aux (aux, l) and to_ast_typ_arg ctx (ATyp_aux (_, l) as atyp) = function - | K_type -> Typ_arg_aux (Typ_arg_typ (to_ast_typ ctx atyp), l) - | K_int -> Typ_arg_aux (Typ_arg_nexp (to_ast_nexp ctx atyp), l) - | K_order -> Typ_arg_aux (Typ_arg_order (to_ast_order ctx atyp), l) - | K_bool -> Typ_arg_aux (Typ_arg_bool (to_ast_constraint ctx atyp), l) + | K_type -> A_aux (A_typ (to_ast_typ ctx atyp), l) + | K_int -> A_aux (A_nexp (to_ast_nexp ctx atyp), l) + | K_order -> A_aux (A_order (to_ast_order ctx atyp), l) + | K_bool -> A_aux (A_bool (to_ast_constraint ctx atyp), l) and to_ast_nexp ctx (P.ATyp_aux (aux, l)) = let aux = match aux with @@ -801,8 +801,8 @@ let quant_item_typ = function | QI_aux (QI_id kopt, _) when is_typ_kopt kopt -> [mk_typ (Typ_var (kopt_kid kopt))] | _ -> [] let quant_item_arg = function - | QI_aux (QI_id kopt, _) when is_nat_kopt kopt -> [mk_typ_arg (Typ_arg_nexp (nvar (kopt_kid kopt)))] - | QI_aux (QI_id kopt, _) when is_typ_kopt kopt -> [mk_typ_arg (Typ_arg_typ (mk_typ (Typ_var (kopt_kid kopt))))] + | QI_aux (QI_id kopt, _) when is_nat_kopt kopt -> [mk_typ_arg (A_nexp (nvar (kopt_kid kopt)))] + | QI_aux (QI_id kopt, _) when is_typ_kopt kopt -> [mk_typ_arg (A_typ (mk_typ (Typ_var (kopt_kid kopt))))] | _ -> [] let undefined_typschm id typq = let qis = quant_items typq in diff --git a/src/monomorphise.ml b/src/monomorphise.ml index 41a27be7..74ef8376 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -143,11 +143,11 @@ let subst_src_typ substs t = let substs = List.fold_left (fun sub v -> KBindings.remove v sub) substs kids in re (Typ_exist (kids,nc,s_styp substs t)) | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" - and s_starg substs (Typ_arg_aux (ta,l) as targ) = + and s_starg substs (A_aux (ta,l) as targ) = match ta with - | Typ_arg_nexp ne -> Typ_arg_aux (Typ_arg_nexp (subst_nexp substs ne),l) - | Typ_arg_typ t -> Typ_arg_aux (Typ_arg_typ (s_styp substs t),l) - | Typ_arg_order _ -> targ + | A_nexp ne -> A_aux (A_nexp (subst_nexp substs ne),l) + | A_typ t -> A_aux (A_typ (s_styp substs t),l) + | A_order _ -> targ in s_styp substs t let make_vector_lit sz i = @@ -339,14 +339,14 @@ let rec inst_src_type insts (Typ_aux (ty,l) as typ) = | _ -> insts', Typ_aux (Typ_exist (kids', nc, t'), l) end | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" -and inst_src_typ_arg insts (Typ_arg_aux (ta,l) as tyarg) = +and inst_src_typ_arg insts (A_aux (ta,l) as tyarg) = match ta with - | Typ_arg_nexp _ - | Typ_arg_order _ + | A_nexp _ + | A_order _ -> insts, tyarg - | Typ_arg_typ typ -> + | A_typ typ -> let insts', typ' = inst_src_type insts typ in - insts', Typ_arg_aux (Typ_arg_typ typ',l) + insts', A_aux (A_typ typ',l) let rec contains_exist (Typ_aux (ty,l)) = match ty with @@ -359,12 +359,12 @@ let rec contains_exist (Typ_aux (ty,l)) = | Typ_app (_,args) -> List.exists contains_exist_arg args | Typ_exist _ -> true | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" -and contains_exist_arg (Typ_arg_aux (arg,_)) = +and contains_exist_arg (A_aux (arg,_)) = match arg with - | Typ_arg_nexp _ - | Typ_arg_order _ + | A_nexp _ + | A_order _ -> false - | Typ_arg_typ typ -> contains_exist typ + | A_typ typ -> contains_exist typ let rec size_nvars_nexp (Nexp_aux (ne,_)) = match ne with @@ -402,8 +402,8 @@ let split_src_type id ty (TypQ_aux (q,ql)) = List.concat insts, Typ_aux (Typ_tup tys,l)) (cross' tys) in (kidset_bigunion vars, insttys) | Typ_app (Id_aux (Id "vector",_), - [Typ_arg_aux (Typ_arg_nexp sz,_); - _;Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_)]) -> + [A_aux (A_nexp sz,_); + _;A_aux (A_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_)]) -> (KidSet.of_list (size_nvars_nexp sz), [[],typ]) | Typ_app (_, tas) -> (KidSet.empty,[[],typ]) (* We only support sizes for bitvectors mentioned explicitly, not any buried @@ -525,7 +525,7 @@ let refine_constructor refinements l env id args = match Type_check.destruct_exist env constr_ty with | None -> None | Some (kids,nc,constr_ty) -> - let (bindings,_,_) = Type_check.unify l env constr_ty arg_ty in + let bindings = Type_check.unify l env (tyvars_of_typ constr_ty) constr_ty arg_ty in let find_kid kid = try Some (KBindings.find kid bindings) with Not_found -> None in let bindings = List.map find_kid kids in let matches_refinement (mapping,_,_) = @@ -533,7 +533,7 @@ let refine_constructor refinements l env id args = (fun v (_,w) -> match v,w with | _,None -> true - | Some (U_nexp (Nexp_aux (Nexp_constant n, _))),Some m -> Big_int.equal n m + | Some (A_aux (A_nexp (Nexp_aux (Nexp_constant n, _)), _)),Some m -> Big_int.equal n m | _,_ -> false) bindings mapping in match List.find matches_refinement irefinements with @@ -699,25 +699,25 @@ let fabricate_nexp_exist env l typ kids nc typ' = match kids,nc,Env.expand_synonyms env typ' with | ([kid],NC_aux (NC_set (kid',i::_),_), Typ_aux (Typ_app (Id_aux (Id "atom",_), - [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid'',_)),_)]),_)) + [A_aux (A_nexp (Nexp_aux (Nexp_var kid'',_)),_)]),_)) when Kid.compare kid kid' = 0 && Kid.compare kid kid'' = 0 -> Nexp_aux (Nexp_constant i,Unknown) | ([kid],NC_aux (NC_true,_), Typ_aux (Typ_app (Id_aux (Id "atom",_), - [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid'',_)),_)]),_)) + [A_aux (A_nexp (Nexp_aux (Nexp_var kid'',_)),_)]),_)) when Kid.compare kid kid'' = 0 -> nint 32 | ([kid],NC_aux (NC_set (kid',i::_),_), Typ_aux (Typ_app (Id_aux (Id "range",_), - [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid'',_)),_); - Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid''',_)),_)]),_)) + [A_aux (A_nexp (Nexp_aux (Nexp_var kid'',_)),_); + A_aux (A_nexp (Nexp_aux (Nexp_var kid''',_)),_)]),_)) when Kid.compare kid kid' = 0 && Kid.compare kid kid'' = 0 && Kid.compare kid kid''' = 0 -> Nexp_aux (Nexp_constant i,Unknown) | ([kid],NC_aux (NC_true,_), Typ_aux (Typ_app (Id_aux (Id "range",_), - [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid'',_)),_); - Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid''',_)),_)]),_)) + [A_aux (A_nexp (Nexp_aux (Nexp_var kid'',_)),_); + A_aux (A_nexp (Nexp_aux (Nexp_var kid''',_)),_)]),_)) when Kid.compare kid kid'' = 0 && Kid.compare kid kid''' = 0 -> nint 32 @@ -734,7 +734,7 @@ let fabricate_nexp l tannot = let atom_typ_kid kid = function | Typ_aux (Typ_app (Id_aux (Id "atom",_), - [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid',_)),_)]),_) -> + [A_aux (A_nexp (Nexp_aux (Nexp_var kid',_)),_)]),_) -> Kid.compare kid kid' = 0 | _ -> false @@ -850,7 +850,7 @@ let try_app (l,ann) (id,args) = E_aux (E_lit L_aux (L_num i,_), _); E_aux (E_lit L_aux (L_num len,_), _)] -> (match Env.base_typ_of (env_of_annot annot) (typ_of_annot annot) with - | Typ_aux (Typ_app (_,[_;Typ_arg_aux (Typ_arg_order ord,_);_]),_) -> + | Typ_aux (Typ_app (_,[_;A_aux (A_order ord,_);_]),_) -> (match slice_lit lit i len ord with | Some lit' -> Some (E_aux (E_lit lit',(l,ann))) | None -> None) @@ -1698,7 +1698,7 @@ let split_defs all_errors splits defs = [L_zero; L_one] | _ -> cannot ("don't know about type " ^ string_of_id id)) - | Typ_app (Id_aux (Id "vector",_), [Typ_arg_aux (Typ_arg_nexp len,_);_;Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_)]) -> + | Typ_app (Id_aux (Id "vector",_), [A_aux (A_nexp len,_);_;A_aux (A_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_)]) -> (match len with | Nexp_aux (Nexp_constant sz,_) -> let lits = make_vectors (Big_int.to_int sz) in @@ -1709,7 +1709,7 @@ let split_defs all_errors splits defs = cannot ("length not constant, " ^ string_of_nexp len) ) (* set constrained numbers *) - | Typ_app (Id_aux (Id "atom",_), [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (value,_) as nexp),_)]) -> + | Typ_app (Id_aux (Id "atom",_), [A_aux (A_nexp (Nexp_aux (value,_) as nexp),_)]) -> begin let mk_lit kid i = let lit = L_aux (L_num i,new_l) in @@ -1844,7 +1844,7 @@ let split_defs all_errors splits defs = let kid_subst = match orig_typ with | Typ_aux (Typ_app (Id_aux (Id "atom",_), - [Typ_arg_aux (Typ_arg_nexp + [A_aux (A_nexp (Nexp_aux (Nexp_var var,_)),_)]),_) -> [var,nconstant j] | _ -> [] @@ -2188,18 +2188,18 @@ let rec sizes_of_typ (Typ_aux (t,l)) = | Typ_exist (kids,_,typ) -> List.fold_left (fun s k -> KidSet.remove k s) (sizes_of_typ typ) kids | Typ_app (Id_aux (Id "vector",_), - [Typ_arg_aux (Typ_arg_nexp size,_); - _;Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_)]) -> + [A_aux (A_nexp size,_); + _;A_aux (A_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_)]) -> KidSet.of_list (size_nvars_nexp size) | Typ_app (_,tas) -> kidset_bigunion (List.map sizes_of_typarg tas) | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" -and sizes_of_typarg (Typ_arg_aux (ta,_)) = +and sizes_of_typarg (A_aux (ta,_)) = match ta with - Typ_arg_nexp _ - | Typ_arg_order _ + A_nexp _ + | A_order _ -> KidSet.empty - | Typ_arg_typ typ -> sizes_of_typ typ + | A_typ typ -> sizes_of_typ typ let sizes_of_annot (l, tannot) = match destruct_tannot tannot with @@ -2262,17 +2262,17 @@ let replace_with_the_value bound_nexps (E_aux (_,(l,_)) as exp) = let mk_exp nexp l l' = let nexp = replace_size nexp in E_aux (E_cast (wrap (Typ_aux (Typ_app (Id_aux (Id "itself",Generated Unknown), - [Typ_arg_aux (Typ_arg_nexp nexp,l')]),Generated Unknown)), + [A_aux (A_nexp nexp,l')]),Generated Unknown)), E_aux (E_app (Id_aux (Id "make_the_value",Generated Unknown),[exp]),(Generated l,empty_tannot))), (Generated l,empty_tannot)) in match typ with | Typ_aux (Typ_app (Id_aux (Id "range",_), - [Typ_arg_aux (Typ_arg_nexp nexp,l');Typ_arg_aux (Typ_arg_nexp nexp',_)]),_) + [A_aux (A_nexp nexp,l');A_aux (A_nexp nexp',_)]),_) when nexp_identical nexp nexp' -> mk_exp nexp l l' | Typ_aux (Typ_app (Id_aux (Id "atom",_), - [Typ_arg_aux (Typ_arg_nexp nexp,l')]),_) -> + [A_aux (A_nexp nexp,l')]),_) -> mk_exp nexp l l' | _ -> raise (Reporting.err_unreachable l __POS__ "atom stopped being an atom?") @@ -2281,13 +2281,13 @@ let replace_type env typ = let Typ_aux (t,l) = Env.expand_synonyms env typ in match t with | Typ_app (Id_aux (Id "range",_), - [Typ_arg_aux (Typ_arg_nexp nexp,l');Typ_arg_aux (Typ_arg_nexp _,_)]) -> + [A_aux (A_nexp nexp,l');A_aux (A_nexp _,_)]) -> Typ_aux (Typ_app (Id_aux (Id "itself",Generated Unknown), - [Typ_arg_aux (Typ_arg_nexp nexp,l')]),Generated l) + [A_aux (A_nexp nexp,l')]),Generated l) | Typ_app (Id_aux (Id "atom",_), - [Typ_arg_aux (Typ_arg_nexp nexp,l')]) -> + [A_aux (A_nexp nexp,l')]) -> Typ_aux (Typ_app (Id_aux (Id "itself",Generated Unknown), - [Typ_arg_aux (Typ_arg_nexp nexp,l')]),Generated l) + [A_aux (A_nexp nexp,l')]),Generated l) | _ -> raise (Reporting.err_unreachable l __POS__ "atom stopped being an atom?") @@ -2308,12 +2308,12 @@ let rewrite_size_parameters env (Defs defs) = let nmap = match Env.base_typ_of env typ with Typ_aux (Typ_app(Id_aux (Id "range",_), - [Typ_arg_aux (Typ_arg_nexp nexp,_); - Typ_arg_aux (Typ_arg_nexp nexp',_)]),_) + [A_aux (A_nexp nexp,_); + A_aux (A_nexp nexp',_)]),_) when Nexp.compare nexp nexp' = 0 && not (NexpMap.mem nexp nmap) -> NexpMap.add nexp i nmap | Typ_aux (Typ_app(Id_aux (Id "atom", _), - [Typ_arg_aux (Typ_arg_nexp nexp,_)]), _) + [A_aux (A_nexp nexp,_)]), _) when not (NexpMap.mem nexp nmap) -> NexpMap.add nexp i nmap | _ -> nmap @@ -2331,7 +2331,7 @@ in *) match destruct_tannot tannot with | Some (env,typ,_) -> begin match Env.base_typ_of env typ with - | Typ_aux (Typ_app (Id_aux (Id "vector",_), [Typ_arg_aux (Typ_arg_nexp size,_);_;_]),_) + | Typ_aux (Typ_app (Id_aux (Id "vector",_), [A_aux (A_nexp size,_);_;_]),_) when not (is_nexp_constant size) -> begin match NexpMap.find size nexp_map with @@ -2845,14 +2845,16 @@ let rec deps_of_nc kid_deps (NC_aux (nc,l)) = let deps_of_typ l kid_deps arg_deps typ = deps_of_tyvars l kid_deps arg_deps (tyvars_of_typ typ) -let deps_of_uvar l fn_id env arg_deps = function - | U_nexp (Nexp_aux (Nexp_var kid,_)) +let deps_of_typ_arg l fn_id env arg_deps (A_aux (aux, _)) = + match aux with + | A_nexp (Nexp_aux (Nexp_var kid,_)) when List.exists (fun k -> Kid.compare kid k == 0) env.top_kids -> Parents (CallerKidSet.singleton (fn_id,kid)) - | U_nexp nexp -> InFun (deps_of_nexp l env.kid_deps arg_deps nexp) - | U_order _ -> InFun dempty - | U_typ typ -> InFun (deps_of_typ l env.kid_deps arg_deps typ) - + | A_nexp nexp -> InFun (deps_of_nexp l env.kid_deps arg_deps nexp) + | A_order _ -> InFun dempty + | A_typ typ -> InFun (deps_of_typ l env.kid_deps arg_deps typ) + | A_bool nc -> InFun (deps_of_nc env.kid_deps nc) + let mk_subrange_pattern vannot vstart vend = let (len,ord,typ) = vector_typ_args_of (Env.base_typ_of (env_of_annot vannot) (typ_of_annot vannot)) in match ord with @@ -2937,8 +2939,8 @@ let simplify_size_nexp env typ_env (Nexp_aux (ne,l) as nexp) = | kid -> Nexp_aux (Nexp_var kid,Generated l) | exception Not_found -> nexp -let simplify_size_uvar env typ_env = function - | U_nexp nexp -> U_nexp (simplify_size_nexp env typ_env nexp) +let simplify_size_typ_arg env typ_env = function + | A_aux (A_nexp nexp, l) -> A_aux (A_nexp (simplify_size_nexp env typ_env nexp), l) | x -> x (* Takes an environment of dependencies on vars, type vars, and flow control, @@ -3030,10 +3032,10 @@ let rec analyse_exp fn_id env assigns (E_aux (e,(l,annot)) as exp) = | _ -> Unknown (l, "Effects from function application") in let kid_inst = instantiation_of exp in - let kid_inst = KBindings.map (simplify_size_uvar env typ_env) kid_inst in + let kid_inst = KBindings.map (simplify_size_typ_arg env typ_env) kid_inst in (* Change kids in instantiation to the canonical ones from the type signature *) let kid_inst = KBindings.fold (fun kid -> KBindings.add (orig_kid kid)) kid_inst KBindings.empty in - let kid_deps = KBindings.map (deps_of_uvar l fn_id env deps) kid_inst in + let kid_deps = KBindings.map (deps_of_typ_arg l fn_id env deps) kid_inst in let rdep,r' = if Id.compare fn_id id == 0 then let bad = Unknown (l,"Recursive call of " ^ string_of_id id) in @@ -3265,7 +3267,7 @@ let initial_env fn_id fn_l (TypQ_aux (tq,_)) pat body set_assertions = let env = env_of_annot annot in let Typ_aux (typ,_) = Env.base_typ_of env (typ_of_annot annot) in match typ with - | Typ_app (Id_aux (Id "atom",_),[Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid,_)),_)]) -> + | Typ_app (Id_aux (Id "atom",_),[A_aux (A_nexp (Nexp_aux (Nexp_var kid,_)),_)]) -> equal_kids env kid | _ -> KidSet.empty in @@ -3287,7 +3289,7 @@ let initial_env fn_id fn_l (TypQ_aux (tq,_)) pat body set_assertions = in let eqn_instantiations = Type_check.instantiate_simple_equations qs in let eqn_kid_deps = KBindings.map (function - | U_nexp nexp -> Some (nexp_frees nexp) + | A_aux (A_nexp nexp, _) -> Some (nexp_frees nexp) | _ -> None) eqn_instantiations in let arg i pat = @@ -3944,15 +3946,15 @@ let make_bitvector_cast_fns cast_name env quant_kids src_typ target_typ = P_aux (P_typ (src_typ, P_aux (P_tup ps,(Generated src_l, src_ann))),(Generated src_l, src_ann)), E_aux (E_tuple es,(Generated tar_l, tar_ann)) | Typ_app (Id_aux (Id "vector",_), - [Typ_arg_aux (Typ_arg_nexp size,_); _; - Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_)]), + [A_aux (A_nexp size,_); _; + A_aux (A_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_)]), Typ_app (Id_aux (Id "vector",_) as t_id, - [Typ_arg_aux (Typ_arg_nexp size',l_size'); t_ord; - Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_) as t_bit]) -> begin + [A_aux (A_nexp size',l_size'); t_ord; + A_aux (A_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_) as t_bit]) -> begin match simplify_size_nexp env quant_kids size, simplify_size_nexp env quant_kids size' with | Some size, Some size' when Nexp.compare size size' <> 0 -> let var = fresh () in - let tar_typ' = Typ_aux (Typ_app (t_id, [Typ_arg_aux (Typ_arg_nexp size',l_size');t_ord;t_bit]), + let tar_typ' = Typ_aux (Typ_app (t_id, [A_aux (A_nexp size',l_size');t_ord;t_bit]), tar_l) in let () = at_least_one := Some tar_typ' in P_aux (P_id var,(Generated src_l,src_ann)), @@ -4052,7 +4054,7 @@ let add_bitvector_casts (Defs defs) = let matched_typ = Env.base_typ_of env (typ_of_annot ann') in match e',matched_typ with | E_sizeof (Nexp_aux (Nexp_var kid,_)), _ - | _, Typ_aux (Typ_app (Id_aux (Id "atom",_), [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid,_)),_)]),_) -> + | _, Typ_aux (Typ_app (Id_aux (Id "atom",_), [A_aux (A_nexp (Nexp_aux (Nexp_var kid,_)),_)]),_) -> let map_case pexp = let pat,guard,body,ann = destruct_pexp pexp in let body = match pat, guard with @@ -4176,16 +4178,16 @@ let replace_nexp_in_typ env typ orig new_nexp = let fs, targs = List.split (List.map aux_targ targs) in List.exists (fun x -> x) fs, Typ_aux (Typ_app (id, targs),l) | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" - and aux_targ (Typ_arg_aux (ta,l) as typ_arg) = + and aux_targ (A_aux (ta,l) as typ_arg) = match ta with - | Typ_arg_nexp nexp -> + | A_nexp nexp -> if prove env (nc_eq nexp orig) - then true, Typ_arg_aux (Typ_arg_nexp new_nexp,l) + then true, A_aux (A_nexp new_nexp,l) else false, typ_arg - | Typ_arg_typ typ -> + | A_typ typ -> let f, typ = aux typ in - f, Typ_arg_aux (Typ_arg_typ typ,l) - | Typ_arg_order _ -> false, typ_arg + f, A_aux (A_typ typ,l) + | A_order _ -> false, typ_arg in aux typ let fresh_nexp_kid nexp = @@ -4277,13 +4279,13 @@ let rewrite_toplevel_nexps (Defs defs) = Typ_aux (Typ_exist (kids,(* TODO? *) nc, aux typ'),l) | Typ_app (id,targs) -> Typ_aux (Typ_app (id,List.map aux_targ targs),l) | _ -> typ_full - and aux_targ (Typ_arg_aux (ta,l) as ta_full) = + and aux_targ (A_aux (ta,l) as ta_full) = match ta with - | Typ_arg_typ typ -> Typ_arg_aux (Typ_arg_typ (aux typ),l) - | Typ_arg_order _ -> ta_full - | Typ_arg_nexp nexp -> + | A_typ typ -> A_aux (A_typ (aux typ),l) + | A_order _ -> ta_full + | A_nexp nexp -> match find_nexp env nexp_map nexp with - | (kid,_) -> Typ_arg_aux (Typ_arg_nexp (nvar kid),l) + | (kid,_) -> A_aux (A_nexp (nvar kid),l) | exception Not_found -> ta_full in aux typ in diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index a3d47814..cfd79290 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -103,10 +103,10 @@ let rec ocaml_string_typ (Typ_aux (typ_aux, l)) arg = | Typ_id id when string_of_id id = "exception" -> string "Printexc.to_string" ^^ space ^^ arg | Typ_id id -> ocaml_string_of id ^^ space ^^ arg | Typ_app (id, []) -> ocaml_string_of id ^^ space ^^ arg - | Typ_app (id, [Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id eid, _)), _)]) + | Typ_app (id, [A_aux (A_typ (Typ_aux (Typ_id eid, _)), _)]) when string_of_id id = "list" && string_of_id eid = "bit" -> string "string_of_bits" ^^ space ^^ arg - | Typ_app (id, [Typ_arg_aux (Typ_arg_typ typ, _)]) when string_of_id id = "list" -> + | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" -> let farg = gensym () in separate space [string "string_of_list \", \""; parens (separate space [string "fun"; farg; string "->"; ocaml_string_typ typ farg]); arg] | Typ_app (_, _) -> string "\"APP\"" @@ -147,9 +147,9 @@ let rec ocaml_typ ctx (Typ_aux (typ_aux, l)) = | Typ_var kid -> zencode_kid kid | Typ_exist _ -> assert false | Typ_internal_unknown -> raise (Reporting.err_unreachable l __POS__ "escaped Typ_internal_unknown") -and ocaml_typ_arg ctx (Typ_arg_aux (typ_arg_aux, _) as typ_arg) = +and ocaml_typ_arg ctx (A_aux (typ_arg_aux, _) as typ_arg) = match typ_arg_aux with - | Typ_arg_typ typ -> ocaml_typ ctx typ + | A_typ typ -> ocaml_typ ctx typ | _ -> failwith ("OCaml: unexpected type argument " ^ string_of_typ_arg typ_arg) let ocaml_typquant typq = @@ -602,7 +602,7 @@ let ocaml_typedef ctx (TD_aux (td_aux, _)) = ^//^ (bar ^^ space ^^ ocaml_enum ctx ids)) ^^ ocaml_def_end ^^ ocaml_string_of_enum ctx id ids - | TD_abbrev (id, typq, Typ_arg_aux (Typ_arg_typ typ, _)) -> + | TD_abbrev (id, typq, A_aux (A_typ typ, _)) -> separate space [string "type"; ocaml_typquant typq; zencode ctx id; equals; ocaml_typ ctx typ] ^^ ocaml_def_end ^^ ocaml_string_of_abbrev ctx id typq typ @@ -698,15 +698,15 @@ let ocaml_pp_generators ctx defs orig_types required = string_of_typ full_typ)) | Typ_app (id,args) -> List.fold_left add_req_from_typarg (add_req_from_id required id) args - and add_req_from_typarg required (Typ_arg_aux (arg,_)) = + and add_req_from_typarg required (A_aux (arg,_)) = match arg with - | Typ_arg_typ typ -> add_req_from_typ required typ - | Typ_arg_nexp _ - | Typ_arg_order _ + | A_typ typ -> add_req_from_typ required typ + | A_nexp _ + | A_order _ -> required and add_req_from_td required (TD_aux (td,(l,_))) = match td with - | TD_abbrev (_, _, Typ_arg_aux (Typ_arg_typ typ, _)) -> + | TD_abbrev (_, _, A_aux (A_typ typ, _)) -> add_req_from_typ required typ | TD_record (_, _, _, fields, _) -> List.fold_left (fun req (typ,_) -> add_req_from_typ req typ) required fields @@ -723,7 +723,7 @@ let ocaml_pp_generators ctx defs orig_types required = match Bindings.find id typemap with | TD_aux (td,_) -> (match td with - | TD_abbrev (_,tqs,Typ_arg_aux (Typ_arg_typ _, _)) -> tqs + | TD_abbrev (_,tqs,A_aux (A_typ _, _)) -> tqs | TD_record (_,_,tqs,_,_) -> tqs | TD_variant (_,_,tqs,_,_) -> tqs | TD_enum _ -> TypQ_aux (TypQ_no_forall,Unknown) @@ -743,10 +743,10 @@ let ocaml_pp_generators ctx defs orig_types required = let name = "gen_" ^ type_name id in let make_tyarg kindedid = if is_nat_kopt kindedid - then mk_typ_arg (Typ_arg_nexp (nvar (kopt_kid kindedid))) + then mk_typ_arg (A_nexp (nvar (kopt_kid kindedid))) else if is_order_kopt kindedid - then mk_typ_arg (Typ_arg_order (mk_ord (Ord_var (kopt_kid kindedid)))) - else mk_typ_arg (Typ_arg_typ (mk_typ (Typ_var (kopt_kid kindedid)))) + then mk_typ_arg (A_order (mk_ord (Ord_var (kopt_kid kindedid)))) + else mk_typ_arg (A_typ (mk_typ (Typ_var (kopt_kid kindedid)))) in let targs = List.map make_tyarg tquants in let gen_tyvars_pp, out_typ = match gen_tyvars with @@ -778,20 +778,20 @@ let ocaml_pp_generators ctx defs orig_types required = | _ -> space ^^ separate space args_pp in string ("g.gen_" ^ typ_str) ^^ args_pp - and typearg (Typ_arg_aux (arg,_)) = + and typearg (A_aux (arg,_)) = match arg with - | Typ_arg_nexp (Nexp_aux (nexp,l) as full_nexp) -> + | A_nexp (Nexp_aux (nexp,l) as full_nexp) -> (match nexp with | Nexp_constant c -> string (Big_int.to_string c) (* TODO: overflow *) | Nexp_var v -> mk_arg v | _ -> raise (Reporting.err_todo l ("Unsupported nexp for generators: " ^ string_of_nexp full_nexp))) - | Typ_arg_order (Ord_aux (ord,_)) -> + | A_order (Ord_aux (ord,_)) -> (match ord with | Ord_var v -> mk_arg v | Ord_inc -> string "true" | Ord_dec -> string "false") - | Typ_arg_typ typ -> parens (string "fun g -> " ^^ gen_type typ) + | A_typ typ -> parens (string "fun g -> " ^^ gen_type typ) in let make_subgen (Typ_aux (typ,l) as full_typ) = let typ_str, args_pp = @@ -845,7 +845,7 @@ let ocaml_pp_generators ctx defs orig_types required = let tqs, body, constructors, builders = let TD_aux (td,(l,_)) = Bindings.find id typemap in match td with - | TD_abbrev (_,tqs,Typ_arg_aux (Typ_arg_typ typ, _)) -> + | TD_abbrev (_,tqs,A_aux (A_typ typ, _)) -> tqs, gen_type typ, None, None | TD_variant (_,_,tqs,variants,_) -> tqs, diff --git a/src/pretty_print_common.ml b/src/pretty_print_common.ml index 1fb35158..0f1dee90 100644 --- a/src/pretty_print_common.ml +++ b/src/pretty_print_common.ml @@ -140,10 +140,10 @@ let doc_typ, doc_atomic_typ, doc_nexp, doc_nexp_constraint = | _ -> app_typ ty and app_typ ((Typ_aux (t, _)) as ty) = match t with | Typ_app(Id_aux (Id "range", _), [ - Typ_arg_aux(Typ_arg_nexp (Nexp_aux(Nexp_constant n, _)), _); - Typ_arg_aux(Typ_arg_nexp m, _);]) -> + A_aux(A_nexp (Nexp_aux(Nexp_constant n, _)), _); + A_aux(A_nexp m, _);]) -> (squarebars (if Big_int.equal n Big_int.zero then nexp m else doc_op colon (doc_int n) (nexp m))) - | Typ_app(Id_aux (Id "atom", _), [Typ_arg_aux(Typ_arg_nexp n,_)]) -> + | Typ_app(Id_aux (Id "atom", _), [A_aux(A_nexp n,_)]) -> (squarecolons (nexp n)) | Typ_app(id,args) -> (* trailing space to avoid >> token in case of nested app types *) @@ -158,13 +158,13 @@ let doc_typ, doc_atomic_typ, doc_nexp, doc_nexp_constraint = group (parens (typ ty)) | Typ_internal_unknown -> string "UNKNOWN" - and doc_typ_arg (Typ_arg_aux(t,_)) = match t with + and doc_typ_arg (A_aux(t,_)) = match t with (* Be careful here because typ_arg is implemented as nexp in the * parser - in practice falling through app_typ after all the proper nexp - * cases; so Typ_arg_typ has the same precedence as a Typ_app *) - | Typ_arg_typ t -> app_typ t - | Typ_arg_nexp n -> nexp n - | Typ_arg_order o -> doc_ord o + * cases; so A_typ has the same precedence as a Typ_app *) + | A_typ t -> app_typ t + | A_nexp n -> nexp n + | A_order o -> doc_ord o (* same trick to handle precedence of nexp *) and nexp ne = sum_typ ne diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 50a97fa8..025156cc 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -268,7 +268,7 @@ let rec coq_nvars_of_typ (Typ_aux (t,l)) = | Typ_tup ts -> List.fold_left (fun s t -> KidSet.union s (trec t)) KidSet.empty ts - | Typ_app(Id_aux (Id "register", _), [Typ_arg_aux (Typ_arg_typ etyp, _)]) -> + | Typ_app(Id_aux (Id "register", _), [A_aux (A_typ etyp, _)]) -> trec etyp | Typ_app(Id_aux (Id "implicit", _),_) (* TODO: update when complex atom types are sorted out *) @@ -280,11 +280,11 @@ let rec coq_nvars_of_typ (Typ_aux (t,l)) = | Typ_exist (kids,_,t) -> trec t | Typ_bidir _ -> unreachable l __POS__ "Coq doesn't support bidir types" | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" -and coq_nvars_of_typ_arg (Typ_arg_aux (ta,_)) = +and coq_nvars_of_typ_arg (A_aux (ta,_)) = match ta with - | Typ_arg_nexp nexp -> tyvars_of_nexp (orig_nexp nexp) - | Typ_arg_typ typ -> coq_nvars_of_typ typ - | Typ_arg_order _ -> KidSet.empty + | A_nexp nexp -> tyvars_of_nexp (orig_nexp nexp) + | A_typ typ -> coq_nvars_of_typ typ + | A_order _ -> KidSet.empty (* Follows Coq precedence levels *) let rec doc_nc_prop ctx nc = @@ -353,8 +353,8 @@ let doc_nc_exp ctx nc = let maybe_expand_range_type (Typ_aux (typ,l) as full_typ) = match typ with - | Typ_app(Id_aux (Id "range", _), [Typ_arg_aux(Typ_arg_nexp low,_); - Typ_arg_aux(Typ_arg_nexp high,_)]) -> + | Typ_app(Id_aux (Id "range", _), [A_aux(A_nexp low,_); + A_aux(A_nexp high,_)]) -> (* TODO: avoid name clashes *) let kid = mk_kid "rangevar" in let var = nvar kid in @@ -411,16 +411,16 @@ let doc_typ, doc_atomic_typ = | _ -> app_typ atyp_needed ty and app_typ atyp_needed ((Typ_aux (t, l)) as ty) = match t with | Typ_app(Id_aux (Id "vector", _), [ - Typ_arg_aux (Typ_arg_nexp m, _); - Typ_arg_aux (Typ_arg_order ord, _); - Typ_arg_aux (Typ_arg_typ elem_typ, _)]) -> + A_aux (A_nexp m, _); + A_aux (A_order ord, _); + A_aux (A_typ elem_typ, _)]) -> (* TODO: remove duplication with exists, below *) let tpp = match elem_typ with | Typ_aux (Typ_id (Id_aux (Id "bit",_)),_) -> (* TODO: coq-compatible simplification *) string "mword " ^^ doc_nexp ctx m | _ -> string "vec" ^^ space ^^ typ elem_typ ^^ space ^^ doc_nexp ctx m in if atyp_needed then parens tpp else tpp - | Typ_app(Id_aux (Id "register", _), [Typ_arg_aux (Typ_arg_typ etyp, _)]) -> + | Typ_app(Id_aux (Id "register", _), [A_aux (A_typ etyp, _)]) -> let tpp = string "register_ref regstate register_value " ^^ typ etyp in if atyp_needed then parens tpp else tpp | Typ_app(Id_aux (Id "range", _), _) @@ -430,7 +430,7 @@ let doc_typ, doc_atomic_typ = | None -> raise (Reporting.err_unreachable l __POS__ "Bad range type")) | Typ_app(Id_aux (Id "implicit", _),_) -> (string "Z") - | Typ_app(Id_aux (Id "atom", _), [Typ_arg_aux(Typ_arg_nexp n,_)]) -> + | Typ_app(Id_aux (Id "atom", _), [A_aux(A_nexp n,_)]) -> (string "Z") | Typ_app(id,args) -> let tpp = (doc_id_type id) ^^ space ^^ (separate_map space doc_typ_arg args) in @@ -457,7 +457,7 @@ let doc_typ, doc_atomic_typ = in match ty' with | Typ_aux (Typ_app (Id_aux (Id "atom",_), - [Typ_arg_aux (Typ_arg_nexp nexp,_)]),_) -> + [A_aux (A_nexp nexp,_)]),_) -> begin match nexp, kids with | (Nexp_aux (Nexp_var kid,_)), [kid'] when Kid.compare kid kid' == 0 -> braces (separate space [doc_var ctx kid; colon; string "Z"; @@ -469,9 +469,9 @@ let doc_typ, doc_atomic_typ = ampersand; doc_arithfact ctx ~exists:kids nc]) end | Typ_aux (Typ_app (Id_aux (Id "vector",_), - [Typ_arg_aux (Typ_arg_nexp m, _); - Typ_arg_aux (Typ_arg_order ord, _); - Typ_arg_aux (Typ_arg_typ elem_typ, _)]),_) -> + [A_aux (A_nexp m, _); + A_aux (A_order ord, _); + A_aux (A_typ elem_typ, _)]),_) -> (* TODO: proper handling of m, complex elem type, dedup with above *) let var = mk_kid "_vec" in (* TODO collision avoid *) let kid_set = KidSet.of_list kids in @@ -515,10 +515,10 @@ let doc_typ, doc_atomic_typ = end*) | Typ_bidir _ -> unreachable l __POS__ "Coq doesn't support bidir types" | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" - and doc_typ_arg (Typ_arg_aux(t,_)) = match t with - | Typ_arg_typ t -> app_typ true t - | Typ_arg_nexp n -> doc_nexp ctx n - | Typ_arg_order o -> empty + and doc_typ_arg (A_aux(t,_)) = match t with + | A_typ t -> app_typ true t + | A_nexp n -> doc_nexp ctx n + | A_order o -> empty in typ', atomic_typ in (fun ctx -> (fst (fns ctx))), (fun ctx -> (snd (fns ctx))) @@ -530,10 +530,10 @@ let contains_t_pp_var ctxt (Typ_aux (t,a) as typ) = (* TODO: should we resurrect this? let replace_typ_size ctxt env (Typ_aux (t,a)) = match t with - | Typ_app (Id_aux (Id "vector",_) as id, [Typ_arg_aux (Typ_arg_nexp size,_);ord;typ']) -> + | Typ_app (Id_aux (Id "vector",_) as id, [A_aux (A_nexp size,_);ord;typ']) -> begin let mk_typ nexp = - Some (Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp nexp,Parse_ast.Unknown);ord;typ']),a)) + Some (Typ_aux (Typ_app (id, [A_aux (A_nexp nexp,Parse_ast.Unknown);ord;typ']),a)) in match Type_check.solve env size with | Some n -> mk_typ (nconstant n) @@ -645,10 +645,10 @@ let rec typeclass_nexps (Typ_aux(t,l)) = | Typ_fn (t1,t2,_) -> List.fold_left NexpSet.union (typeclass_nexps t2) (List.map typeclass_nexps t1) | Typ_tup ts -> List.fold_left NexpSet.union NexpSet.empty (List.map typeclass_nexps ts) | Typ_app (Id_aux (Id "vector",_), - [Typ_arg_aux (Typ_arg_nexp size_nexp,_); - _;Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_)]) + [A_aux (A_nexp size_nexp,_); + _;A_aux (A_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_)]) | Typ_app (Id_aux (Id "itself",_), - [Typ_arg_aux (Typ_arg_nexp size_nexp,_)]) -> + [A_aux (A_nexp size_nexp,_)]) -> let size_nexp = nexp_simp size_nexp in if is_nexp_constant size_nexp then NexpSet.empty else NexpSet.singleton (orig_nexp size_nexp) @@ -693,8 +693,7 @@ let rec doc_pat ctxt apat_needed exists_as_pairs (P_aux (p,(l,annot)) as pat, ty let arg_typs = match Env.expand_synonyms env ctor_typ with | Typ_aux (Typ_fn (arg_typs, ret_typ, _), _) -> - (* The FIXME comes from the typechecker code, not sure what it's about... *) - let unifiers, _, _ (* FIXME! *) = unify l env ret_typ typ in + let unifiers = unify l env (tyvars_of_typ ret_typ) ret_typ typ in List.map (subst_unifiers unifiers) arg_typs | _ -> assert false in @@ -742,14 +741,14 @@ let rec doc_pat ctxt apat_needed exists_as_pairs (P_aux (p,(l,annot)) as pat, ty | _ -> parens (separate_map comma_sp (doc_pat ctxt false exists_as_pairs) (List.combine pats typs))) | P_list pats -> let el_typ = match typ with - | Typ_aux (Typ_app (f, [Typ_arg_aux (Typ_arg_typ el_typ,_)]),_) + | Typ_aux (Typ_app (f, [A_aux (A_typ el_typ,_)]),_) when Id.compare f (mk_id "list") = 0 -> el_typ | _ -> raise (Reporting.err_unreachable l __POS__ "list pattern not a list") in brackets (separate_map semi (fun p -> doc_pat ctxt false true (p, el_typ)) pats) | P_cons (p,p') -> let el_typ = match typ with - | Typ_aux (Typ_app (f, [Typ_arg_aux (Typ_arg_typ el_typ,_)]),_) + | Typ_aux (Typ_app (f, [A_aux (A_typ el_typ,_)]),_) when Id.compare f (mk_id "list") = 0 -> el_typ | _ -> raise (Reporting.err_unreachable l __POS__ "list pattern not a list") in @@ -776,7 +775,7 @@ let find_e_ids exp = let typ_id_of (Typ_aux (typ, l)) = match typ with | Typ_id id -> id - | Typ_app (register, [Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id id, _)), _)]) + | Typ_app (register, [A_aux (A_typ (Typ_aux (Typ_id id, _)), _)]) when string_of_id register = "register" -> id | Typ_app (id, _) -> id | _ -> raise (Reporting.err_unreachable l __POS__ "failed to get type id") @@ -861,16 +860,16 @@ let is_no_Z_proof_fn env id = let replace_atom_return_type ret_typ = (* TODO: more complex uses of atom *) match ret_typ with - | Typ_aux (Typ_app (Id_aux (Id "atom",_), [Typ_arg_aux (Typ_arg_nexp nexp,_)]),l) -> + | Typ_aux (Typ_app (Id_aux (Id "atom",_), [A_aux (A_nexp nexp,_)]),l) -> let kid = mk_kid "_retval" in (* TODO: collision avoidance *) true, Typ_aux (Typ_exist ([kid], nc_eq (nvar kid) nexp, atom_typ (nvar kid)),Parse_ast.Generated l) | _ -> false, ret_typ let is_range_from_atom env (Typ_aux (argty,_)) (Typ_aux (fnty,_)) = match argty, fnty with - | Typ_app(Id_aux (Id "atom", _), [Typ_arg_aux (Typ_arg_nexp nexp,_)]), - Typ_app(Id_aux (Id "range", _), [Typ_arg_aux(Typ_arg_nexp low,_); - Typ_arg_aux(Typ_arg_nexp high,_)]) -> + | Typ_app(Id_aux (Id "atom", _), [A_aux (A_nexp nexp,_)]), + Typ_app(Id_aux (Id "range", _), [A_aux(A_nexp low,_); + A_aux(A_nexp high,_)]) -> Type_check.prove env (nc_and (nc_eq nexp low) (nc_eq nexp high)) | _ -> false @@ -932,8 +931,8 @@ let doc_exp, doc_let = (* Avoid using helper functions which simplify the nexps *) is_bitvector_typ in_typ && is_bitvector_typ out_typ && match in_typ, out_typ with - | Typ_aux (Typ_app (_,[Typ_arg_aux (Typ_arg_nexp n1,_);_;_]),_), - Typ_aux (Typ_app (_,[Typ_arg_aux (Typ_arg_nexp n2,_);_;_]),_) -> + | Typ_aux (Typ_app (_,[A_aux (A_nexp n1,_);_;_]),_), + Typ_aux (Typ_app (_,[A_aux (A_nexp n2,_);_;_]),_) -> not (similar_nexps ctxt (env_of exp) n1 n2) | _ -> false in @@ -1185,8 +1184,8 @@ let doc_exp, doc_let = (* Avoid using helper functions which simplify the nexps *) is_bitvector_typ typ_of_arg' && is_bitvector_typ typ_from_fn' && match typ_of_arg', typ_from_fn' with - | Typ_aux (Typ_app (_,[Typ_arg_aux (Typ_arg_nexp n1,_);_;_]),_), - Typ_aux (Typ_app (_,[Typ_arg_aux (Typ_arg_nexp n2,_);_;_]),_) -> + | Typ_aux (Typ_app (_,[A_aux (A_nexp n1,_);_;_]),_), + Typ_aux (Typ_app (_,[A_aux (A_nexp n2,_);_;_]),_) -> not (similar_nexps ctxt env n1 n2) | _ -> false in @@ -1235,8 +1234,8 @@ let doc_exp, doc_let = (* Avoid using helper functions which simplify the nexps *) is_bitvector_typ in_typ && is_bitvector_typ out_typ && match in_typ, out_typ with - | Typ_aux (Typ_app (_,[Typ_arg_aux (Typ_arg_nexp n1,_);_;_]),_), - Typ_aux (Typ_app (_,[Typ_arg_aux (Typ_arg_nexp n2,_);_;_]),_) -> + | Typ_aux (Typ_app (_,[A_aux (A_nexp n1,_);_;_]),_), + Typ_aux (Typ_app (_,[A_aux (A_nexp n2,_);_;_]),_) -> not (similar_nexps ctxt env n1 n2) | _ -> false in pack,unpack,autocast @@ -1333,8 +1332,8 @@ let doc_exp, doc_let = (* Avoid using helper functions which simplify the nexps *) is_bitvector_typ outer_typ' && is_bitvector_typ cast_typ' && match outer_typ', cast_typ' with - | Typ_aux (Typ_app (_,[Typ_arg_aux (Typ_arg_nexp n1,_);_;_]),_), - Typ_aux (Typ_app (_,[Typ_arg_aux (Typ_arg_nexp n2,_);_;_]),_) -> + | Typ_aux (Typ_app (_,[A_aux (A_nexp n1,_);_;_]),_), + Typ_aux (Typ_app (_,[A_aux (A_nexp n2,_);_;_]),_) -> not (similar_nexps ctxt env n1 n2) | _ -> false in @@ -1656,9 +1655,9 @@ let types_used_with_generic_eq defs = List.fold_left add_typ_arg (IdSet.add id idset) args | Typ_tup ts -> List.fold_left add_typ idset ts | _ -> idset - and add_typ_arg idset (Typ_arg_aux (ta,_)) = + and add_typ_arg idset (A_aux (ta,_)) = match ta with - | Typ_arg_typ typ -> add_typ idset typ + | A_typ typ -> add_typ idset typ | _ -> idset in let alg = @@ -1711,7 +1710,7 @@ let rec doc_range (BF_aux(r,_)) = match r with | BF_concat(ir1,ir2) -> (doc_range ir1) ^^ comma ^^ (doc_range ir2) let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = match td with - | TD_abbrev(id,typq,Typ_arg_aux (Typ_arg_typ typ, _)) -> + | TD_abbrev(id,typq,A_aux (A_typ typ, _)) -> let typschm = TypSchm_aux (TypSchm_ts (typq, typ), l) in doc_op coloneq (separate space [string "Definition"; doc_id_type id; @@ -1729,7 +1728,7 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = match td with let quant_item = function | QI_aux (QI_id (KOpt_aux (KOpt_none kid, _)), l) | QI_aux (QI_id (KOpt_aux (KOpt_kind (_, kid), _)), l) -> - [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid, l)), l)] + [A_aux (A_nexp (Nexp_aux (Nexp_var kid, l)), l)] | _ -> [] in let targs = List.concat (List.map quant_item qs) in mk_typ (Typ_app (id, targs)) @@ -1879,7 +1878,7 @@ let rec atom_constraint ctxt (pat, typ) = match pat, typ with | P_aux (P_id id, _), Typ_aux (Typ_app (Id_aux (Id "atom",_), - [Typ_arg_aux (Typ_arg_nexp nexp,_)]),_) -> + [A_aux (A_nexp nexp,_)]),_) -> (match nexp with (* When the kid is mapped to the id, we don't need a constraint *) | Nexp_aux (Nexp_var kid,_) @@ -2039,12 +2038,12 @@ let doc_funcl (FCL_aux(FCL_Funcl(id, pexp), annot)) = match destruct_exist env full_typ with | Some ([kid], NC_aux (NC_true,_), Typ_aux (Typ_app (Id_aux (Id "atom",_), - [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid',_)),_)]),_)) + [A_aux (A_nexp (Nexp_aux (Nexp_var kid',_)),_)]),_)) when Kid.compare kid kid' == 0 -> parens (separate space [doc_id id; colon; string "Z"]) | Some ([kid], nc, Typ_aux (Typ_app (Id_aux (Id "atom",_), - [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid',_)),_)]),_)) + [A_aux (A_nexp (Nexp_aux (Nexp_var kid',_)),_)]),_)) when Kid.compare kid kid' == 0 -> (used_a_pattern := true; squote ^^ parens (separate space [string "existT"; underscore; doc_id id; underscore; colon; doc_typ ctxt typ])) @@ -2169,8 +2168,8 @@ let doc_regtype_fields (tname, (n1, n2, fields)) = let ftyp = vector_typ (nconstant fsize) dec_ord bit_typ in let reftyp = mk_typ (Typ_app (Id_aux (Id "field_ref", Parse_ast.Unknown), - [mk_typ_arg (Typ_arg_typ (mk_id_typ (mk_id tname))); - mk_typ_arg (Typ_arg_typ ftyp)])) in + [mk_typ_arg (A_typ (mk_id_typ (mk_id tname))); + mk_typ_arg (A_typ ftyp)])) in let rfannot = doc_tannot empty_ctxt Env.empty false reftyp in doc_op equals (concat [string "let "; parens (concat [string tname; underscore; doc_id fid; rfannot])]) diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index e5613961..1764ab92 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -224,14 +224,14 @@ let rec lem_nexps_of_typ (Typ_aux (t,l)) = List.fold_left (fun s t -> NexpSet.union s (trec t)) NexpSet.empty ts | Typ_app(Id_aux (Id "vector", _), [ - Typ_arg_aux (Typ_arg_nexp m, _); - Typ_arg_aux (Typ_arg_order ord, _); - Typ_arg_aux (Typ_arg_typ elem_typ, _)]) -> + A_aux (A_nexp m, _); + A_aux (A_order ord, _); + A_aux (A_typ elem_typ, _)]) -> let m = nexp_simp m in if !opt_mwords && is_bit_typ elem_typ && not (is_nexp_constant m) then NexpSet.singleton (orig_nexp m) else trec elem_typ - | Typ_app(Id_aux (Id "register", _), [Typ_arg_aux (Typ_arg_typ etyp, _)]) -> + | Typ_app(Id_aux (Id "register", _), [A_aux (A_typ etyp, _)]) -> trec etyp | Typ_app(Id_aux (Id "range", _),_) | Typ_app(Id_aux (Id "implicit", _),_) @@ -242,11 +242,11 @@ let rec lem_nexps_of_typ (Typ_aux (t,l)) = | Typ_exist (kids,_,t) -> trec t | Typ_bidir _ -> raise (Reporting.err_unreachable l __POS__ "Lem doesn't support bidir types") | Typ_internal_unknown -> raise (Reporting.err_unreachable l __POS__ "escaped Typ_internal_unknown") -and lem_nexps_of_typ_arg (Typ_arg_aux (ta,_)) = +and lem_nexps_of_typ_arg (A_aux (ta,_)) = match ta with - | Typ_arg_nexp nexp -> NexpSet.singleton (nexp_simp (orig_nexp nexp)) - | Typ_arg_typ typ -> lem_nexps_of_typ typ - | Typ_arg_order _ -> NexpSet.empty + | A_nexp nexp -> NexpSet.singleton (nexp_simp (orig_nexp nexp)) + | A_typ typ -> lem_nexps_of_typ typ + | A_order _ -> NexpSet.empty let lem_tyvars_of_typ typ = NexpSet.fold (fun nexp ks -> KidSet.union ks (tyvars_of_nexp nexp)) @@ -274,9 +274,9 @@ let doc_typ_lem, doc_atomic_typ_lem = | _ -> app_typ atyp_needed ty and app_typ atyp_needed ((Typ_aux (t, l)) as ty) = match t with | Typ_app(Id_aux (Id "vector", _), [ - Typ_arg_aux (Typ_arg_nexp m, _); - Typ_arg_aux (Typ_arg_order ord, _); - Typ_arg_aux (Typ_arg_typ elem_typ, _)]) -> + A_aux (A_nexp m, _); + A_aux (A_order ord, _); + A_aux (A_typ elem_typ, _)]) -> let tpp = match elem_typ with | Typ_aux (Typ_id (Id_aux (Id "bit",_)),_) when !opt_mwords -> string "mword " ^^ doc_nexp_lem (nexp_simp m) @@ -287,14 +287,14 @@ let doc_typ_lem, doc_atomic_typ_lem = "cannot pretty-print bitvector type with non-constant length")) *) | _ -> string "list" ^^ space ^^ typ elem_typ in if atyp_needed then parens tpp else tpp - | Typ_app(Id_aux (Id "register", _), [Typ_arg_aux (Typ_arg_typ etyp, _)]) -> + | Typ_app(Id_aux (Id "register", _), [A_aux (A_typ etyp, _)]) -> let tpp = string "register_ref regstate register_value " ^^ typ etyp in if atyp_needed then parens tpp else tpp | Typ_app(Id_aux (Id "range", _),_) -> (string "integer") | Typ_app(Id_aux (Id "implicit", _),_) -> (string "integer") - | Typ_app(Id_aux (Id "atom", _), [Typ_arg_aux(Typ_arg_nexp n,_)]) -> + | Typ_app(Id_aux (Id "atom", _), [A_aux(A_nexp n,_)]) -> (string "integer") | Typ_app(id,args) -> let tpp = (doc_id_lem_type id) ^^ space ^^ (separate_map space doc_typ_arg_lem args) in @@ -325,10 +325,10 @@ let doc_typ_lem, doc_atomic_typ_lem = end | Typ_bidir _ -> unreachable l __POS__ "Lem doesn't support bidir types" | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" - and doc_typ_arg_lem (Typ_arg_aux(t,_)) = match t with - | Typ_arg_typ t -> app_typ true t - | Typ_arg_nexp n -> doc_nexp_lem (nexp_simp n) - | Typ_arg_order o -> empty + and doc_typ_arg_lem (A_aux(t,_)) = match t with + | A_typ t -> app_typ true t + | A_nexp n -> doc_nexp_lem (nexp_simp n) + | A_order o -> empty in typ', atomic_typ (* Check for variables in types that would be pretty-printed. *) @@ -338,10 +338,10 @@ let contains_t_pp_var ctxt (Typ_aux (t,a) as typ) = let replace_typ_size ctxt env (Typ_aux (t,a)) = match t with - | Typ_app (Id_aux (Id "vector",_) as id, [Typ_arg_aux (Typ_arg_nexp size,_);ord;typ']) -> + | Typ_app (Id_aux (Id "vector",_) as id, [A_aux (A_nexp size,_);ord;typ']) -> begin let mk_typ nexp = - Some (Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp nexp,Parse_ast.Unknown);ord;typ']),a)) + Some (Typ_aux (Typ_app (id, [A_aux (A_nexp nexp,Parse_ast.Unknown);ord;typ']),a)) in match Type_check.solve env size with | Some n -> mk_typ (nconstant n) @@ -443,16 +443,16 @@ let rec typeclass_nexps (Typ_aux(t,l)) = | Typ_fn (ts,t,_) -> List.fold_left NexpSet.union (typeclass_nexps t) (List.map typeclass_nexps ts) | Typ_tup ts -> List.fold_left NexpSet.union NexpSet.empty (List.map typeclass_nexps ts) | Typ_app (Id_aux (Id "vector",_), - [Typ_arg_aux (Typ_arg_nexp size_nexp,_); - _;Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_)]) + [A_aux (A_nexp size_nexp,_); + _;A_aux (A_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_)]) | Typ_app (Id_aux (Id "itself",_), - [Typ_arg_aux (Typ_arg_nexp size_nexp,_)]) -> + [A_aux (A_nexp size_nexp,_)]) -> let size_nexp = nexp_simp size_nexp in if is_nexp_constant size_nexp then NexpSet.empty else NexpSet.singleton (orig_nexp size_nexp) | Typ_app (id, args) -> let add_arg_nexps nexps = function - | Typ_arg_aux (Typ_arg_typ typ, _) -> + | A_aux (A_typ typ, _) -> NexpSet.union nexps (typeclass_nexps typ) | _ -> nexps in @@ -533,8 +533,8 @@ let rec typ_needs_printed (Typ_aux (t,_) as typ) = match t with let visible_kids = KidSet.inter (KidSet.of_list kids) (lem_tyvars_of_typ t) in typ_needs_printed t && KidSet.is_empty visible_kids | _ -> false -and typ_needs_printed_arg (Typ_arg_aux (targ, _)) = match targ with - | Typ_arg_typ t -> typ_needs_printed t +and typ_needs_printed_arg (A_aux (targ, _)) = match targ with + | A_typ t -> typ_needs_printed t | _ -> false let contains_early_return exp = @@ -553,7 +553,7 @@ let find_e_ids exp = let typ_id_of (Typ_aux (typ, l)) = match typ with | Typ_id id -> id - | Typ_app (register, [Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id id, _)), _)]) + | Typ_app (register, [A_aux (A_typ (Typ_aux (Typ_id id, _)), _)]) when string_of_id register = "register" -> id | Typ_app (id, _) -> id | _ -> raise (Reporting.err_unreachable l __POS__ "failed to get type id") @@ -1006,7 +1006,7 @@ let rec doc_range_lem (BF_aux(r,_)) = match r with | BF_concat(ir1,ir2) -> (doc_range ir1) ^^ comma ^^ (doc_range ir2) let doc_typdef_lem (TD_aux(td, (l, annot))) = match td with - | TD_abbrev(id,typq,Typ_arg_aux (Typ_arg_typ typ, _)) -> + | TD_abbrev(id,typq,A_aux (A_typ typ, _)) -> let typschm = TypSchm_aux (TypSchm_ts (typq, typ), l) in doc_op equals (separate space [string "type"; doc_id_lem_type id; doc_typquant_items_lem None typq]) @@ -1022,7 +1022,7 @@ let doc_typdef_lem (TD_aux(td, (l, annot))) = match td with let quant_item = function | QI_aux (QI_id (KOpt_aux (KOpt_none kid, _)), l) | QI_aux (QI_id (KOpt_aux (KOpt_kind (_, kid), _)), l) -> - [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid, l)), l)] + [A_aux (A_nexp (Nexp_aux (Nexp_var kid, l)), l)] | _ -> [] in let targs = List.concat (List.map quant_item qs) in mk_typ (Typ_app (id, targs)) @@ -1031,8 +1031,8 @@ let doc_typdef_lem (TD_aux(td, (l, annot))) = match td with (* let doc_field (ftyp, fid) = let reftyp = mk_typ (Typ_app (Id_aux (Id "field_ref", Parse_ast.Unknown), - [mk_typ_arg (Typ_arg_typ rectyp); - mk_typ_arg (Typ_arg_typ ftyp)])) in + [mk_typ_arg (A_typ rectyp); + mk_typ_arg (A_typ ftyp)])) in let rfannot = doc_tannot_lem empty_ctxt env false reftyp in let get, set = string "rec_val" ^^ dot ^^ fname fid, @@ -1389,8 +1389,8 @@ let doc_regtype_fields (tname, (n1, n2, fields)) = let ftyp = vector_typ (nconstant fsize) dec_ord bit_typ in let reftyp = mk_typ (Typ_app (Id_aux (Id "field_ref", Parse_ast.Unknown), - [mk_typ_arg (Typ_arg_typ (mk_id_typ (mk_id tname))); - mk_typ_arg (Typ_arg_typ ftyp)])) in + [mk_typ_arg (A_typ (mk_id_typ (mk_id tname))); + mk_typ_arg (A_typ ftyp)])) in let rfannot = doc_tannot_lem empty_ctxt Env.empty false reftyp in doc_op equals (concat [string "let "; parens (concat [string tname; underscore; doc_id_lem fid; rfannot])]) diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index 7fb67a06..bae1b893 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -165,7 +165,7 @@ let rec doc_typ ?(simple=false) (Typ_aux (typ_aux, l)) = (* Resugar set types like {|1, 2, 3|} *) | Typ_exist ([kid1], NC_aux (NC_set (kid2, ints), _), - Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid3, _)), _)]), _)) + Typ_aux (Typ_app (id, [A_aux (A_nexp (Nexp_aux (Nexp_var kid3, _)), _)]), _)) when Kid.compare kid1 kid2 == 0 && Kid.compare kid2 kid3 == 0 && Id.compare (mk_id "atom") id == 0 -> enclose (string "{|") (string "|}") (separate_map (string ", ") doc_int ints) | Typ_exist (kids, nc, typ) -> @@ -181,11 +181,11 @@ let rec doc_typ ?(simple=false) (Typ_aux (typ_aux, l)) = | Typ_bidir (typ1, typ2) -> separate space [doc_typ typ1; string "<->"; doc_typ typ2] | Typ_internal_unknown -> raise (Reporting.err_unreachable l __POS__ "escaped Typ_internal_unknown") -and doc_typ_arg (Typ_arg_aux (ta_aux, _)) = +and doc_typ_arg (A_aux (ta_aux, _)) = match ta_aux with - | Typ_arg_typ typ -> doc_typ typ - | Typ_arg_nexp nexp -> doc_nexp nexp - | Typ_arg_order o -> doc_ord o + | A_typ typ -> doc_typ typ + | A_nexp nexp -> doc_nexp nexp + | A_order o -> doc_ord o and doc_arg_typs = function | [typ] -> doc_typ typ | typs -> parens (separate_map (comma ^^ space) doc_typ typs) diff --git a/src/return_analysis.ml b/src/return_analysis.ml index 06565b01..256f97cf 100644 --- a/src/return_analysis.ml +++ b/src/return_analysis.ml @@ -110,7 +110,7 @@ let existentialize_annot funcl_annot annot = let funcl_env = env_of_annot funcl_annot in let env = env_of_annot annot in match Env.expand_synonyms env (typ_of_annot annot) with - | (Typ_aux (Typ_app (ty_id, [Typ_arg_aux (Typ_arg_nexp nexp, _)]), _) as typ) + | (Typ_aux (Typ_app (ty_id, [A_aux (A_nexp nexp, _)]), _) as typ) when Id.compare ty_id (mk_id "atom") = 0 -> let tyvars = Env.get_typ_vars funcl_env |> KBindings.bindings in let toplevel_kids = diff --git a/src/rewrites.ml b/src/rewrites.ml index 82228206..d5601d08 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -264,13 +264,13 @@ let rewrite_defs_nexp_ids, rewrite_typ_nexp_ids = | Typ_app (id, targs) -> Typ_aux (Typ_app (id, List.map (rewrite_typ_arg env) targs), l) | _ -> typ_aux - and rewrite_typ_arg env (Typ_arg_aux (targ, l) as targ_aux) = match targ with - | Typ_arg_nexp nexp -> - Typ_arg_aux (Typ_arg_nexp (rewrite_nexp_ids env nexp), l) - | Typ_arg_typ typ -> - Typ_arg_aux (Typ_arg_typ (rewrite_typ env typ), l) - | Typ_arg_order ord -> - Typ_arg_aux (Typ_arg_order ord, l) + and rewrite_typ_arg env (A_aux (targ, l) as targ_aux) = match targ with + | A_nexp nexp -> + A_aux (A_nexp (rewrite_nexp_ids env nexp), l) + | A_typ typ -> + A_aux (A_typ (rewrite_typ env typ), l) + | A_order ord -> + A_aux (A_order ord, l) in let rewrite_annot (l, tannot) = @@ -409,7 +409,7 @@ let rewrite_sizeof (Defs defs) = | P_id id | P_as (_, id) -> let (Typ_aux (typ,_) as typ_aux) = typ_of_annot annot in (match typ with - | Typ_app (atom, [Typ_arg_aux (Typ_arg_nexp nexp, _)]) + | Typ_app (atom, [A_aux (A_nexp nexp, _)]) when string_of_id atom = "atom" -> [nexp, E_id id] | Typ_app (vector, _) when string_of_id vector = "vector" -> @@ -470,7 +470,7 @@ let rewrite_sizeof (Defs defs) = assert (not (Str.string_match ex_regex (string_of_kid kid) 0)); let uvar = try Some (KBindings.find (orig_kid kid) inst) with Not_found -> None in match uvar with - | Some (U_nexp nexp) -> + | Some (A_aux (A_nexp nexp, _)) -> let sizeof = E_aux (E_sizeof nexp, (l, mk_tannot env (atom_typ nexp) no_effect)) in (try rewrite_trivial_sizeof_exp sizeof with | Type_error (l, err) -> @@ -2302,8 +2302,8 @@ let rewrite_type_union_typs rw_typ (Tu_aux (Tu_ty_id (typ, id), annot)) = let rewrite_type_def_typs rw_typ rw_typquant (TD_aux (td, annot)) = match td with - | TD_abbrev (id, typq, Typ_arg_aux (Typ_arg_typ typ, l)) -> - TD_aux (TD_abbrev (id, rw_typquant typq, Typ_arg_aux (Typ_arg_typ (rw_typ typ), l)), annot) + | TD_abbrev (id, typq, A_aux (A_typ typ, l)) -> + TD_aux (TD_abbrev (id, rw_typquant typq, A_aux (A_typ (rw_typ typ), l)), annot) | TD_record (id, nso, typq, typ_ids, flag) -> TD_aux (TD_record (id, nso, rw_typquant typq, List.map (fun (typ, id) -> (rw_typ typ, id)) typ_ids, flag), annot) | TD_variant (id, nso, typq, tus, flag) -> @@ -2355,8 +2355,8 @@ let rewrite_undefined_if_gen always_bitvector defs = let rec simple_typ (Typ_aux (typ_aux, l) as typ) = Typ_aux (simple_typ_aux typ_aux, l) and simple_typ_aux = function | Typ_id id -> Typ_id id - | Typ_app (id, [_; _; Typ_arg_aux (Typ_arg_typ typ, l)]) when Id.compare id (mk_id "vector") = 0 -> - Typ_app (mk_id "list", [Typ_arg_aux (Typ_arg_typ (simple_typ typ), l)]) + | Typ_app (id, [_; _; A_aux (A_typ typ, l)]) when Id.compare id (mk_id "vector") = 0 -> + Typ_app (mk_id "list", [A_aux (A_typ (simple_typ typ), l)]) | Typ_app (id, [_]) when Id.compare id (mk_id "atom") = 0 -> Typ_id (mk_id "int") | Typ_app (id, [_; _]) when Id.compare id (mk_id "range") = 0 -> @@ -2366,9 +2366,9 @@ and simple_typ_aux = function | Typ_tup typs -> Typ_tup (List.map simple_typ typs) | Typ_exist (_, _, Typ_aux (typ, l)) -> simple_typ_aux typ | typ_aux -> typ_aux -and simple_typ_arg (Typ_arg_aux (typ_arg_aux, l)) = +and simple_typ_arg (A_aux (typ_arg_aux, l)) = match typ_arg_aux with - | Typ_arg_typ typ -> [Typ_arg_aux (Typ_arg_typ (simple_typ typ), l)] + | A_typ typ -> [A_aux (A_typ (simple_typ typ), l)] | _ -> [] (* This pass aims to remove all the Num quantifiers from the specification. *) @@ -3010,7 +3010,7 @@ let rec binding_typs_of_pat (P_aux (p_aux, p_annot) as pat) = let construct_toplevel_string_append_call env f_id bindings binding_typs guard expr = (* s# if match f#(s#) { Some (bindings) => guard, _ => false) } => let Some(bindings) = f#(s#) in expr *) let s_id = fresh_stringappend_id () in - let option_typ = app_typ (mk_id "option") [Typ_arg_aux (Typ_arg_typ (match binding_typs with + let option_typ = app_typ (mk_id "option") [A_aux (A_typ (match binding_typs with | [] -> unit_typ | [typ] -> typ | typs -> tuple_typ typs @@ -3042,7 +3042,7 @@ let construct_toplevel_string_append_func env f_id pat = else bindings in - let option_typ = app_typ (mk_id "option") [Typ_arg_aux (Typ_arg_typ (match binding_typs with + let option_typ = app_typ (mk_id "option") [A_aux (A_typ (match binding_typs with | [] -> unit_typ | [typ] -> typ | typs -> tuple_typ typs @@ -3102,7 +3102,7 @@ let construct_toplevel_string_append_func env f_id pat = in let mapping_inner_typ = match Env.get_val_spec (mk_id mapping_prefix_func) env with - | (_, Typ_aux (Typ_fn (_, Typ_aux (Typ_app (_, [Typ_arg_aux (Typ_arg_typ typ, _)]), _), _), _)) -> typ + | (_, Typ_aux (Typ_fn (_, Typ_aux (Typ_app (_, [A_aux (A_typ typ, _)]), _), _), _)) -> typ | _ -> typ_error Parse_ast.Unknown "mapping prefix func without correct function type?" in @@ -3119,7 +3119,7 @@ let construct_toplevel_string_append_func env f_id pat = [annot_exp (E_id s_id) unk env string_typ])) unk env mapping_inner_typ in (* construct some pattern -- Some (n#, len#) *) - let opt_typ = app_typ (mk_id "option") [Typ_arg_aux (Typ_arg_typ mapping_inner_typ, unk)] in + let opt_typ = app_typ (mk_id "option") [A_aux (A_typ mapping_inner_typ, unk)] in let tup_arg_pat = match arg_pats with | [] -> assert false | [arg_pat] -> arg_pat @@ -3278,7 +3278,7 @@ let rec rewrite_defs_pat_string_append = in let mapping_inner_typ = match Env.get_val_spec (mk_id mapping_prefix_func) env with - | (_, Typ_aux (Typ_fn (_, Typ_aux (Typ_app (_, [Typ_arg_aux (Typ_arg_typ typ, _)]), _), _), _)) -> typ + | (_, Typ_aux (Typ_fn (_, Typ_aux (Typ_app (_, [A_aux (A_typ typ, _)]), _), _), _)) -> typ | _ -> typ_error Parse_ast.Unknown "mapping prefix func without correct function type?" in @@ -3295,7 +3295,7 @@ let rec rewrite_defs_pat_string_append = [annot_exp (E_id s_id) unk env string_typ])) unk env mapping_inner_typ in (* construct some pattern -- Some (n#, len#) *) - let opt_typ = app_typ (mk_id "option") [Typ_arg_aux (Typ_arg_typ mapping_inner_typ, unk)] in + let opt_typ = app_typ (mk_id "option") [A_aux (A_typ mapping_inner_typ, unk)] in let tup_arg_pat = match arg_pats with | [] -> assert false | [arg_pat] -> arg_pat @@ -3926,14 +3926,14 @@ let remove_reference_types exp = let rec rewrite_t (Typ_aux (t_aux,a)) = (Typ_aux (rewrite_t_aux t_aux,a)) and rewrite_t_aux t_aux = match t_aux with - | Typ_app (Id_aux (Id "reg",_), [Typ_arg_aux (Typ_arg_typ (Typ_aux (t_aux2, _)), _)]) -> + | Typ_app (Id_aux (Id "reg",_), [A_aux (A_typ (Typ_aux (t_aux2, _)), _)]) -> rewrite_t_aux t_aux2 | Typ_app (name,t_args) -> Typ_app (name,List.map rewrite_t_arg t_args) | Typ_fn (arg_typs, ret_typ, eff) -> Typ_fn (List.map rewrite_t arg_typs, rewrite_t ret_typ, eff) | Typ_tup ts -> Typ_tup (List.map rewrite_t ts) | _ -> t_aux and rewrite_t_arg t_arg = match t_arg with - | Typ_arg_aux (Typ_arg_typ t, a) -> Typ_arg_aux (Typ_arg_typ (rewrite_t t), a) + | A_aux (A_typ t, a) -> A_aux (A_typ (rewrite_t t), a) | _ -> t_arg in let rec rewrite_annot (l, tannot) = @@ -4329,7 +4329,7 @@ let rewrite_defs_realise_mappings (Defs defs) = let prefix_wildcard = mk_pexp (Pat_exp (mk_pat P_wild, mk_exp (E_app (mk_id "None", [mk_exp (E_lit (mk_lit L_unit))])))) in let string_defs = begin if subtype_check env typ1 string_typ && subtype_check env string_typ typ1 then - let forwards_prefix_typ = Typ_aux (Typ_fn ([typ1], app_typ (mk_id "option") [Typ_arg_aux (Typ_arg_typ (tuple_typ [typ2; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in + let forwards_prefix_typ = Typ_aux (Typ_fn ([typ1], app_typ (mk_id "option") [A_aux (A_typ (tuple_typ [typ2; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in let forwards_prefix_spec = VS_aux (VS_val_spec (mk_typschm typq forwards_prefix_typ, prefix_id, (fun _ -> None), false), (Parse_ast.Unknown,())) in let forwards_prefix_spec, env = Type_check.check_val_spec env forwards_prefix_spec in let forwards_prefix_match = mk_exp (E_case (arg_exp, ((List.map (fun mapcl -> strip_mapcl mapcl |> realise_prefix_mapcl true prefix_id) mapcls) |> List.flatten) @ [prefix_wildcard])) in @@ -4339,7 +4339,7 @@ let rewrite_defs_realise_mappings (Defs defs) = forwards_prefix_spec @ forwards_prefix_fun else if subtype_check env typ2 string_typ && subtype_check env string_typ typ2 then - let backwards_prefix_typ = Typ_aux (Typ_fn ([typ2], app_typ (mk_id "option") [Typ_arg_aux (Typ_arg_typ (tuple_typ [typ1; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in + let backwards_prefix_typ = Typ_aux (Typ_fn ([typ2], app_typ (mk_id "option") [A_aux (A_typ (tuple_typ [typ1; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in let backwards_prefix_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_prefix_typ, prefix_id, (fun _ -> None), false), (Parse_ast.Unknown,())) in let backwards_prefix_spec, env = Type_check.check_val_spec env backwards_prefix_spec in let backwards_prefix_match = mk_exp (E_case (arg_exp, ((List.map (fun mapcl -> strip_mapcl mapcl |> realise_prefix_mapcl false prefix_id) mapcls) |> List.flatten) @ [prefix_wildcard])) in diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index 84fa8235..2ab64f1c 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -101,7 +101,7 @@ and free_type_names_maybe_t consider_var = function | Some t -> free_type_names_t consider_var t | None -> mt and free_type_names_t_arg consider_var = function - | Typ_arg_aux (Typ_arg_typ t, _) -> free_type_names_t consider_var t + | A_aux (A_typ t, _) -> free_type_names_t consider_var t | _ -> mt and free_type_names_t_args consider_var targs = nameset_bigunion (List.map (free_type_names_t_arg consider_var) targs) @@ -129,9 +129,9 @@ let rec fv_of_typ consider_var bound used (Typ_aux (t,l)) : Nameset.t = | Typ_exist (kids,_,t') -> fv_of_typ consider_var (List.fold_left (fun b (Kid_aux (Var v,_)) -> Nameset.add v b) bound kids) used t' | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" -and fv_of_targ consider_var bound used (Ast.Typ_arg_aux(targ,_)) : Nameset.t = match targ with - | Typ_arg_typ t -> fv_of_typ consider_var bound used t - | Typ_arg_nexp n -> fv_of_nexp consider_var bound used n +and fv_of_targ consider_var bound used (Ast.A_aux(targ,_)) : Nameset.t = match targ with + | A_typ t -> fv_of_typ consider_var bound used t + | A_nexp n -> fv_of_nexp consider_var bound used n | _ -> used and fv_of_nexp consider_var bound used (Ast.Nexp_aux(n,_)) = match n with @@ -309,7 +309,7 @@ let fv_of_kind_def consider_var (KD_aux(k,_)) = match k with | KD_nabbrev(_,id,_,nexp) -> init_env (string_of_id id), fv_of_nexp consider_var mt mt nexp let fv_of_type_def consider_var (TD_aux(t,_)) = match t with - | TD_abbrev(id,typq,Typ_arg_aux(Typ_arg_typ typ, l)) -> + | TD_abbrev(id,typq,A_aux(A_typ typ, l)) -> let typschm = TypSchm_aux (TypSchm_ts (typq,typ), l) in init_env (string_of_id id), snd (fv_of_typschm consider_var mt mt typschm) | TD_record(id,_,typq,tids,_) -> diff --git a/src/specialize.ml b/src/specialize.ml index 6e625176..0f5b939c 100644 --- a/src/specialize.ml +++ b/src/specialize.ml @@ -54,8 +54,8 @@ open Rewriter open Extra_pervasives let is_typ_ord_uvar = function - | Type_check.U_typ _ -> true - | Type_check.U_order _ -> true + | A_aux (A_nexp _, _) -> true + | A_aux (A_order _, _) -> true | _ -> false let rec nexp_simp_typ (Typ_aux (typ_aux, l)) = @@ -71,24 +71,20 @@ let rec nexp_simp_typ (Typ_aux (typ_aux, l)) = | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" in Typ_aux (typ_aux, l) -and nexp_simp_typ_arg (Typ_arg_aux (typ_arg_aux, l)) = +and nexp_simp_typ_arg (A_aux (typ_arg_aux, l)) = let typ_arg_aux = match typ_arg_aux with - | Typ_arg_nexp n -> Typ_arg_nexp (nexp_simp n) - | Typ_arg_typ typ -> Typ_arg_typ (nexp_simp_typ typ) - | Typ_arg_order ord -> Typ_arg_order ord + | A_nexp n -> A_nexp (nexp_simp n) + | A_typ typ -> A_typ (nexp_simp_typ typ) + | A_order ord -> A_order ord + | A_bool nc -> A_bool (constraint_simp nc) in - Typ_arg_aux (typ_arg_aux, l) - -let nexp_simp_uvar = function - | Type_check.U_nexp nexp -> (prerr_endline ("Simp nexp " ^ string_of_nexp nexp); Type_check.U_nexp (nexp_simp nexp)) - | Type_check.U_typ typ -> Type_check.U_typ (nexp_simp_typ typ) - | uvar -> uvar + A_aux (typ_arg_aux, l) (* We have to be careful about whether the typechecker has renamed anything returned by instantiation_of. This part of the typechecker API is a bit ugly. *) let fix_instantiation instantiation = - let instantiation = KBindings.bindings (KBindings.filter (fun _ uvar -> is_typ_ord_uvar uvar) instantiation) in - let instantiation = List.map (fun (kid, uvar) -> Type_check.orig_kid kid, nexp_simp_uvar uvar) instantiation in + let instantiation = KBindings.bindings (KBindings.filter (fun _ arg -> is_typ_ord_uvar arg) instantiation) in + let instantiation = List.map (fun (kid, arg) -> Type_check.orig_kid kid, nexp_simp_typ_arg arg) instantiation in List.fold_left (fun m (k, v) -> KBindings.add k v m) KBindings.empty instantiation let rec polymorphic_functions is_kopt (Defs defs) = @@ -146,11 +142,12 @@ let string_of_instantiation instantiation = "exist " ^ Util.string_of_list " " kid_name kids ^ ", " ^ string_of_n_constraint nc ^ ". " ^ string_of_typ typ | Typ_internal_unknown -> "UNKNOWN" and string_of_typ_arg = function - | Typ_arg_aux (typ_arg, l) -> string_of_typ_arg_aux typ_arg + | A_aux (typ_arg, l) -> string_of_typ_arg_aux typ_arg and string_of_typ_arg_aux = function - | Typ_arg_nexp n -> string_of_nexp n - | Typ_arg_typ typ -> string_of_typ typ - | Typ_arg_order o -> string_of_order o + | A_nexp n -> string_of_nexp n + | A_typ typ -> string_of_typ typ + | A_order o -> string_of_order o + | A_bool nc -> string_of_n_constraint nc and string_of_n_constraint = function | NC_aux (NC_equal (n1, n2), _) -> string_of_nexp n1 ^ " = " ^ string_of_nexp n2 | NC_aux (NC_not_equal (n1, n2), _) -> string_of_nexp n1 ^ " != " ^ string_of_nexp n2 @@ -166,13 +163,7 @@ let string_of_instantiation instantiation = | NC_aux (NC_false, _) -> "false" in - let string_of_uvar = function - | U_nexp n -> string_of_nexp n - | U_order o -> string_of_order o - | U_typ typ -> string_of_typ typ - in - - let string_of_binding (kid, uvar) = string_of_kid kid ^ " => " ^ string_of_uvar uvar in + let string_of_binding (kid, arg) = string_of_kid kid ^ " => " ^ string_of_typ_arg arg in Util.zencode_string (Util.string_of_list ", " string_of_binding (KBindings.bindings instantiation)) let id_of_instantiation id instantiation = @@ -182,7 +173,7 @@ let id_of_instantiation id instantiation = let rec variant_generic_typ id (Defs defs) = match defs with | DEF_type (TD_aux (TD_variant (id', _, typq, _, _), _)) :: _ when Id.compare id id' = 0 -> - mk_typ (Typ_app (id', List.map (fun kopt -> mk_typ_arg (Typ_arg_typ (mk_typ (Typ_var (kopt_kid kopt))))) (quant_kopts typq))) + mk_typ (Typ_app (id', List.map (fun kopt -> mk_typ_arg (A_typ (mk_typ (Typ_var (kopt_kid kopt))))) (quant_kopts typq))) | _ :: defs -> variant_generic_typ id (Defs defs) | [] -> failwith ("No variant with id " ^ string_of_id id) @@ -207,9 +198,10 @@ let rec instantiations_of id ast = begin match Type_check.typ_of_annot annot with | Typ_aux (Typ_app (variant_id, _), _) as typ -> let open Type_check in - let instantiation, _, _ = unify (fst annot) (env_of_annot annot) - (variant_generic_typ variant_id ast) - typ + let instantiation = unify (fst annot) (env_of_annot annot) + (tyvars_of_typ (variant_generic_typ variant_id ast)) + (variant_generic_typ variant_id ast) + typ in instantiations := fix_instantiation instantiation :: !instantiations; pat @@ -262,11 +254,11 @@ let rec typ_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) = List.fold_left KidSet.union (typ_frees ~exs:exs ret_typ) (List.map (typ_frees ~exs:exs) arg_typs) | Typ_bidir (t1, t2) -> KidSet.union (typ_frees ~exs:exs t1) (typ_frees ~exs:exs t2) | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" -and typ_arg_frees ?exs:(exs=KidSet.empty) (Typ_arg_aux (typ_arg_aux, l)) = +and typ_arg_frees ?exs:(exs=KidSet.empty) (A_aux (typ_arg_aux, l)) = match typ_arg_aux with - | Typ_arg_nexp n -> KidSet.empty - | Typ_arg_typ typ -> typ_frees ~exs:exs typ - | Typ_arg_order ord -> KidSet.empty + | A_nexp n -> KidSet.empty + | A_typ typ -> typ_frees ~exs:exs typ + | A_order ord -> KidSet.empty let rec typ_int_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) = match typ_aux with @@ -279,20 +271,11 @@ let rec typ_int_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) = List.fold_left KidSet.union (typ_int_frees ~exs:exs ret_typ) (List.map (typ_int_frees ~exs:exs) arg_typs) | Typ_bidir (t1, t2) -> KidSet.union (typ_int_frees ~exs:exs t1) (typ_int_frees ~exs:exs t2) | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" -and typ_arg_int_frees ?exs:(exs=KidSet.empty) (Typ_arg_aux (typ_arg_aux, l)) = +and typ_arg_int_frees ?exs:(exs=KidSet.empty) (A_aux (typ_arg_aux, l)) = match typ_arg_aux with - | Typ_arg_nexp n -> KidSet.diff (tyvars_of_nexp n) exs - | Typ_arg_typ typ -> KidSet.empty - | Typ_arg_order ord -> KidSet.empty - -let uvar_int_frees = function - | Type_check.U_nexp n -> tyvars_of_nexp n - | Type_check.U_typ typ -> typ_int_frees typ - | _ -> KidSet.empty - -let uvar_typ_frees = function - | Type_check.U_typ typ -> typ_frees typ - | _ -> KidSet.empty + | A_nexp n -> KidSet.diff (tyvars_of_nexp n) exs + | A_typ typ -> typ_int_frees ~exs:exs typ + | A_order ord -> KidSet.empty let specialize_id_valspec instantiations id ast = match split_defs (is_valspec id) ast with @@ -313,8 +296,8 @@ let specialize_id_valspec instantiations id ast = (* Collect any new type variables introduced by the instantiation *) let collect_kids kidsets = KidSet.elements (List.fold_left KidSet.union KidSet.empty kidsets) in - let typ_frees = KBindings.bindings instantiation |> List.map snd |> List.map uvar_typ_frees |> collect_kids in - let int_frees = KBindings.bindings instantiation |> List.map snd |> List.map uvar_int_frees |> collect_kids in + let typ_frees = KBindings.bindings instantiation |> List.map snd |> List.map typ_arg_frees |> collect_kids in + let int_frees = KBindings.bindings instantiation |> List.map snd |> List.map typ_arg_int_frees |> collect_kids in (* Remove type variables from the type quantifier. *) let kopts, constraints = quant_split typq in diff --git a/src/specialize.mli b/src/specialize.mli index 87533e9b..f2c94a48 100644 --- a/src/specialize.mli +++ b/src/specialize.mli @@ -68,6 +68,6 @@ val polymorphic_functions : (kinded_id -> bool) -> 'a defs -> IdSet.t which case specialize returns the AST unmodified. *) val specialize : tannot defs -> Env.t -> tannot defs * Env.t -val instantiations_of : id -> tannot defs -> uvar KBindings.t list +val instantiations_of : id -> tannot defs -> typ_arg KBindings.t list -val string_of_instantiation : uvar KBindings.t -> string +val string_of_instantiation : typ_arg KBindings.t -> string diff --git a/src/state.ml b/src/state.ml index 00f81bf4..4fc2e1e8 100644 --- a/src/state.ml +++ b/src/state.ml @@ -102,12 +102,12 @@ let generate_initial_regstate defs = if string_of_id id = "unit" then "()" else Bindings.find id vals [] | Typ_app (id, _) when string_of_id id = "list" -> "[||]" - | Typ_app (id, [Typ_arg_aux (Typ_arg_nexp nexp, _)]) when string_of_id id = "atom" -> + | Typ_app (id, [A_aux (A_nexp nexp, _)]) when string_of_id id = "atom" -> string_of_nexp nexp - | Typ_app (id, [Typ_arg_aux (Typ_arg_nexp nexp, _); _]) when string_of_id id = "range" -> + | Typ_app (id, [A_aux (A_nexp nexp, _); _]) when string_of_id id = "range" -> string_of_nexp nexp - | Typ_app (id, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant len, _)), _); _ ; - Typ_arg_aux (Typ_arg_typ etyp, _)]) + | Typ_app (id, [A_aux (A_nexp (Nexp_aux (Nexp_constant len, _)), _); _ ; + A_aux (A_typ etyp, _)]) when string_of_id id = "vector" -> (* Output a list of initial values of the vector elements, or a literal binary zero value if this is a bitvector and the @@ -146,7 +146,7 @@ let generate_initial_regstate defs = string_of_id id1 ^ " (" ^ lookup_init_val vals typ1 ^ ")" in Bindings.add id init_val vals - | TD_abbrev (id, tq, Typ_arg_aux (Typ_arg_typ typ, _)) -> + | TD_abbrev (id, tq, A_aux (A_typ typ, _)) -> let init_val args = lookup_init_val vals (typ_subst_typquant tq args typ) in Bindings.add id init_val vals | TD_record (id, _, tq, fields, _) -> @@ -174,12 +174,12 @@ let generate_initial_regstate defs = let rec regval_constr_id mwords (Typ_aux (t, l) as typ) = match t with | Typ_id id -> id | Typ_app (id, args) -> - let name_arg (Typ_arg_aux (targ, _)) = match targ with - | Typ_arg_typ targ -> string_of_id (regval_constr_id mwords targ) - | Typ_arg_nexp nexp when is_nexp_constant (nexp_simp nexp) -> + let name_arg (A_aux (targ, _)) = match targ with + | A_typ targ -> string_of_id (regval_constr_id mwords targ) + | A_nexp nexp when is_nexp_constant (nexp_simp nexp) -> string_of_nexp (nexp_simp nexp) - | Typ_arg_order (Ord_aux (Ord_inc, _)) -> "inc" - | Typ_arg_order (Ord_aux (Ord_dec, _)) -> "dec" + | A_order (Ord_aux (Ord_inc, _)) -> "inc" + | A_order (Ord_aux (Ord_dec, _)) -> "dec" | _ -> raise (Reporting.err_typ l "Unsupported register type") in @@ -194,9 +194,9 @@ let register_base_types mwords typs = match t with | Typ_app (id, args) when IdSet.mem id builtins && not (mwords && is_bitvector_typ typ) -> - let add_typ_arg base_typs (Typ_arg_aux (targ, _)) = + let add_typ_arg base_typs (A_aux (targ, _)) = match targ with - | Typ_arg_typ typ -> add_base_typs typs typ + | A_typ typ -> add_base_typs typs typ | _ -> typs in List.fold_left add_typ_arg typs args @@ -243,12 +243,12 @@ let rec regval_convs_lem mwords (Typ_aux (t, _) as typ) = match t with let etyp_of, of_etyp = regval_convs_lem mwords etyp in "(fun v -> vector_of_regval " ^ etyp_of ^ " v)", "(fun v -> regval_of_vector " ^ of_etyp ^ " " ^ size ^ " " ^ is_inc ^ " v)" - | Typ_app (id, [Typ_arg_aux (Typ_arg_typ etyp, _)]) + | Typ_app (id, [A_aux (A_typ etyp, _)]) when string_of_id id = "list" -> let etyp_of, of_etyp = regval_convs_lem mwords etyp in "(fun v -> list_of_regval " ^ etyp_of ^ " v)", "(fun v -> regval_of_list " ^ of_etyp ^ " v)" - | Typ_app (id, [Typ_arg_aux (Typ_arg_typ etyp, _)]) + | Typ_app (id, [A_aux (A_typ etyp, _)]) when string_of_id id = "option" -> let etyp_of, of_etyp = regval_convs_lem mwords etyp in "(fun v -> option_of_regval " ^ etyp_of ^ " v)", @@ -407,12 +407,12 @@ let rec regval_convs_coq (Typ_aux (t, _) as typ) = match t with let etyp_of, of_etyp = regval_convs_coq etyp in "(fun v => vector_of_regval " ^ size ^ " " ^ etyp_of ^ " v)", "(fun v => regval_of_vector " ^ of_etyp ^ " " ^ size ^ " " ^ is_inc ^ " v)" - | Typ_app (id, [Typ_arg_aux (Typ_arg_typ etyp, _)]) + | Typ_app (id, [A_aux (A_typ etyp, _)]) when string_of_id id = "list" -> let etyp_of, of_etyp = regval_convs_coq etyp in "(fun v => list_of_regval " ^ etyp_of ^ " v)", "(fun v => regval_of_list " ^ of_etyp ^ " v)" - | Typ_app (id, [Typ_arg_aux (Typ_arg_typ etyp, _)]) + | Typ_app (id, [A_aux (A_typ etyp, _)]) when string_of_id id = "option" -> let etyp_of, of_etyp = regval_convs_coq etyp in "(fun v => option_of_regval " ^ etyp_of ^ " v)", diff --git a/src/type_check.ml b/src/type_check.ml index 2c10b8ae..42616361 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -96,6 +96,7 @@ type type_error = | Err_subtype of typ * typ * n_constraint list * Ast.l KBindings.t | Err_no_num_ident of id | Err_other of string + | Err_because of type_error * type_error exception Type_error of l * type_error;; @@ -125,7 +126,7 @@ let orig_kid (Kid_aux (Var v, l) as kid) = let is_list (Typ_aux (typ_aux, _)) = match typ_aux with - | Typ_app (f, [Typ_arg_aux (Typ_arg_typ typ, _)]) + | Typ_app (f, [A_aux (A_typ typ, _)]) when string_of_id f = "list" -> Some typ | _ -> None @@ -174,12 +175,12 @@ and strip_n_constraint_aux = function and strip_n_constraint = function | NC_aux (nc_aux, _) -> NC_aux (strip_n_constraint_aux nc_aux, Parse_ast.Unknown) and strip_typ_arg = function - | Typ_arg_aux (typ_arg_aux, _) -> Typ_arg_aux (strip_typ_arg_aux typ_arg_aux, Parse_ast.Unknown) + | A_aux (typ_arg_aux, _) -> A_aux (strip_typ_arg_aux typ_arg_aux, Parse_ast.Unknown) and strip_typ_arg_aux = function - | Typ_arg_nexp nexp -> Typ_arg_nexp (strip_nexp nexp) - | Typ_arg_typ typ -> Typ_arg_typ (strip_typ typ) - | Typ_arg_order ord -> Typ_arg_order (strip_order ord) - | Typ_arg_bool nc -> Typ_arg_bool (strip_n_constraint nc) + | A_nexp nexp -> A_nexp (strip_nexp nexp) + | A_typ typ -> A_typ (strip_typ typ) + | A_order ord -> A_order (strip_order ord) + | A_bool nc -> A_bool (strip_n_constraint nc) and strip_order = function | Ord_aux (ord_aux, _) -> Ord_aux (strip_order_aux ord_aux, Parse_ast.Unknown) and strip_order_aux = function @@ -466,14 +467,14 @@ end = struct let kopts, ncs = quant_split typq in let rec subst_args kopts args = match kopts, args with - | kopt :: kopts, (Typ_arg_aux (Typ_arg_nexp _, _) as arg) :: args when is_nat_kopt kopt -> + | kopt :: kopts, (A_aux (A_nexp _, _) as arg) :: args when is_nat_kopt kopt -> List.map (constraint_subst (kopt_kid kopt) arg) (subst_args kopts args) - | kopt :: kopts, Typ_arg_aux (Typ_arg_typ arg, _) :: args when is_typ_kopt kopt -> + | kopt :: kopts, A_aux (A_typ arg, _) :: args when is_typ_kopt kopt -> subst_args kopts args - | kopt :: kopts, Typ_arg_aux (Typ_arg_order arg, _) :: args when is_order_kopt kopt -> + | kopt :: kopts, A_aux (A_order arg, _) :: args when is_order_kopt kopt -> subst_args kopts args | [], [] -> ncs - | _, Typ_arg_aux (_, l) :: _ -> typ_error l ("Error when processing type quantifer arguments " ^ string_of_typquant typq) + | _, A_aux (_, l) :: _ -> typ_error l ("Error when processing type quantifer arguments " ^ string_of_typquant typq) | _, _ -> typ_error Parse_ast.Unknown ("Error when processing type quantifer arguments " ^ string_of_typquant typq) in let ncs = subst_args kopts args in @@ -488,7 +489,7 @@ end = struct | NC_app (id, args) -> (try begin match Bindings.find id env.typ_synonyms env args with - | Typ_arg_aux (Typ_arg_bool nc, _) -> expand_constraint_synonyms env nc + | A_aux (A_bool nc, _) -> expand_constraint_synonyms env nc | _ -> typ_error l ("Expected Type when expanding synonym " ^ string_of_id id) end with Not_found -> NC_aux (NC_app (id, List.map (expand_synonyms_arg env) args), l)) @@ -503,7 +504,7 @@ end = struct | Typ_app (id, args) -> (try begin match Bindings.find id env.typ_synonyms env args with - | Typ_arg_aux (Typ_arg_typ typ, _) -> expand_synonyms env typ + | A_aux (A_typ typ, _) -> expand_synonyms env typ | _ -> typ_error l ("Expected Type when expanding synonym " ^ string_of_id id) end with @@ -511,7 +512,7 @@ end = struct | Typ_id id -> (try begin match Bindings.find id env.typ_synonyms env [] with - | Typ_arg_aux (Typ_arg_typ typ, _) -> expand_synonyms env typ + | A_aux (A_typ typ, _) -> expand_synonyms env typ | _ -> typ_error l ("Expected Type when expanding synonym " ^ string_of_id id) end with @@ -544,11 +545,11 @@ end = struct let env = { env with constraints = nc :: env.constraints } in Typ_aux (Typ_exist (kids, nc, expand_synonyms env typ), l) | Typ_var v -> Typ_aux (Typ_var v, l) - and expand_synonyms_arg env (Typ_arg_aux (typ_arg, l)) = + and expand_synonyms_arg env (A_aux (typ_arg, l)) = match typ_arg with - | Typ_arg_typ typ -> Typ_arg_aux (Typ_arg_typ (expand_synonyms env typ), l) - | Typ_arg_bool nc -> Typ_arg_aux (Typ_arg_bool (expand_constraint_synonyms env nc), l) - | arg -> Typ_arg_aux (arg, l) + | A_typ typ -> A_aux (A_typ (expand_synonyms env typ), l) + | A_bool nc -> A_aux (A_bool (expand_constraint_synonyms env nc), l) + | arg -> A_aux (arg, l) (** Map over all nexps in a type - excluding those in existential constraints **) let rec map_nexps f (Typ_aux (typ_aux, l) as typ) = @@ -560,10 +561,10 @@ end = struct | Typ_tup typs -> Typ_aux (Typ_tup (List.map (map_nexps f) typs), l) | Typ_exist (kids, nc, typ) -> Typ_aux (Typ_exist (kids, nc, map_nexps f typ), l) | Typ_app (id, args) -> Typ_aux (Typ_app (id, List.map (map_nexps_arg f) args), l) - and map_nexps_arg f (Typ_arg_aux (arg_aux, l) as arg) = + and map_nexps_arg f (A_aux (arg_aux, l) as arg) = match arg_aux with - | Typ_arg_order _ | Typ_arg_typ _ | Typ_arg_bool _ -> arg - | Typ_arg_nexp n -> Typ_arg_aux (Typ_arg_nexp (f n), l) + | A_order _ | A_typ _ | A_bool _ -> arg + | A_nexp n -> A_aux (A_nexp (f n), l) let canonical env typ = let typ = expand_synonyms env typ in @@ -646,12 +647,12 @@ end = struct wf_typ ~exs:(KidSet.of_list kids) { env with constraints = nc :: env.constraints } typ | Typ_exist (_, _, _) -> typ_error l ("Nested existentials are not allowed") | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" - and wf_typ_arg ?exs:(exs=KidSet.empty) env (Typ_arg_aux (typ_arg_aux, _)) = + and wf_typ_arg ?exs:(exs=KidSet.empty) env (A_aux (typ_arg_aux, _)) = match typ_arg_aux with - | Typ_arg_nexp nexp -> wf_nexp ~exs:exs env nexp - | Typ_arg_typ typ -> wf_typ ~exs:exs env typ - | Typ_arg_order ord -> wf_order env ord - | Typ_arg_bool nc -> wf_constraint ~exs:exs env nc + | A_nexp nexp -> wf_nexp ~exs:exs env nexp + | A_typ typ -> wf_typ ~exs:exs env typ + | A_order ord -> wf_order env ord + | A_bool nc -> wf_constraint ~exs:exs env nc and wf_nexp ?exs:(exs=KidSet.empty) env (Nexp_aux (nexp_aux, l) as nexp) = match nexp_aux with | Nexp_id _ -> () @@ -820,10 +821,10 @@ end = struct in let prefix_id = mk_id (string_of_id id ^ "_matches_prefix") in begin if strip_typ typ1 = string_typ then - let forwards_prefix_typ = Typ_aux (Typ_fn ([typ1], app_typ (mk_id "option") [Typ_arg_aux (Typ_arg_typ (tuple_typ [typ2; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in + let forwards_prefix_typ = Typ_aux (Typ_fn ([typ1], app_typ (mk_id "option") [A_aux (A_typ (tuple_typ [typ2; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in add_val_spec prefix_id (typq, forwards_prefix_typ) env else if strip_typ typ2 = string_typ then - let backwards_prefix_typ = Typ_aux (Typ_fn ([typ2], app_typ (mk_id "option") [Typ_arg_aux (Typ_arg_typ (tuple_typ [typ1; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in + let backwards_prefix_typ = Typ_aux (Typ_fn ([typ2], app_typ (mk_id "option") [A_aux (A_typ (tuple_typ [typ1; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in add_val_spec prefix_id (typq, backwards_prefix_typ) env else env @@ -882,11 +883,11 @@ end = struct let rec record_typ_args = function | [] -> [] | ((QI_aux (QI_id kopt, _)) :: qis) when is_nat_kopt kopt -> - mk_typ_arg (Typ_arg_nexp (nvar (kopt_kid kopt))) :: record_typ_args qis + mk_typ_arg (A_nexp (nvar (kopt_kid kopt))) :: record_typ_args qis | ((QI_aux (QI_id kopt, _)) :: qis) when is_typ_kopt kopt -> - mk_typ_arg (Typ_arg_typ (mk_typ (Typ_var (kopt_kid kopt)))) :: record_typ_args qis + mk_typ_arg (A_typ (mk_typ (Typ_var (kopt_kid kopt)))) :: record_typ_args qis | ((QI_aux (QI_id kopt, _)) :: qis) when is_order_kopt kopt -> - mk_typ_arg (Typ_arg_order (mk_ord (Ord_var (kopt_kid kopt)))) :: record_typ_args qis + mk_typ_arg (A_order (mk_ord (Ord_var (kopt_kid kopt)))) :: record_typ_args qis | (_ :: qis) -> record_typ_args qis in let rectyp = match record_typ_args (quant_items typq) with @@ -1109,15 +1110,15 @@ end = struct rewrap (Typ_fn (List.map aux arg_typs, aux ret_typ, eff)) | Typ_tup ts -> rewrap (Typ_tup (List.map aux ts)) - | Typ_app (r, [Typ_arg_aux (Typ_arg_typ rtyp,_)]) when string_of_id r = "register" -> + | Typ_app (r, [A_aux (A_typ rtyp,_)]) when string_of_id r = "register" -> aux rtyp | Typ_app (id, targs) -> rewrap (Typ_app (id, List.map aux_arg targs)) | t -> rewrap t - and aux_arg (Typ_arg_aux (targ,a)) = - let rewrap targ = Typ_arg_aux (targ,a) in + and aux_arg (A_aux (targ,a)) = + let rewrap targ = A_aux (targ,a) in match targ with - | Typ_arg_typ typ -> rewrap (Typ_arg_typ (aux typ)) + | A_typ typ -> rewrap (A_typ (aux typ)) | targ -> rewrap targ in aux (expand_synonyms env typ) @@ -1195,11 +1196,11 @@ let exist_typ constr typ = let destruct_numeric env typ = let typ = Env.expand_synonyms env typ in match destruct_exist env typ, typ with - | Some (kids, nc, Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp nexp, _)]), _)), _ when string_of_id id = "atom" -> + | Some (kids, nc, Typ_aux (Typ_app (id, [A_aux (A_nexp nexp, _)]), _)), _ when string_of_id id = "atom" -> Some (kids, nc, nexp) - | None, Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp nexp, _)]), _) when string_of_id id = "atom" -> + | None, Typ_aux (Typ_app (id, [A_aux (A_nexp nexp, _)]), _) when string_of_id id = "atom" -> Some ([], nc_true, nexp) - | None, Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp lo, _); Typ_arg_aux (Typ_arg_nexp hi, _)]), _) when string_of_id id = "range" -> + | None, Typ_aux (Typ_app (id, [A_aux (A_nexp lo, _); A_aux (A_nexp hi, _)]), _) when string_of_id id = "range" -> let kid = fresh_existential () in Some ([kid], nc_and (nc_lteq lo (nvar kid)) (nc_lteq (nvar kid) hi), nvar kid) | None, Typ_aux (Typ_id id, _) when string_of_id id = "nat" -> @@ -1230,17 +1231,17 @@ let destruct_range env typ = Util.option_default ([], nc_true, typ) (destruct_exist env typ) in match typ_aux with - | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp n, _)]) + | Typ_app (f, [A_aux (A_nexp n, _)]) when string_of_id f = "atom" -> Some (kids, constr, n, n) - | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp n1, _); Typ_arg_aux (Typ_arg_nexp n2, _)]) + | Typ_app (f, [A_aux (A_nexp n1, _); A_aux (A_nexp n2, _)]) when string_of_id f = "range" -> Some (kids, constr, n1, n2) | _ -> None let destruct_vector env typ = let destruct_vector' = function - | Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp n1, _); - Typ_arg_aux (Typ_arg_order o, _); - Typ_arg_aux (Typ_arg_typ vtyp, _)] + | Typ_aux (Typ_app (id, [A_aux (A_nexp n1, _); + A_aux (A_order o, _); + A_aux (A_typ vtyp, _)] ), _) when string_of_id id = "vector" -> Some (nexp_simp n1, o, vtyp) | typ -> None in @@ -1255,12 +1256,12 @@ let rec is_typ_monomorphic (Typ_aux (typ, l)) = | Typ_bidir (typ1, typ2) -> is_typ_monomorphic typ1 && is_typ_monomorphic typ2 | Typ_exist _ | Typ_var _ -> false | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" -and is_typ_arg_monomorphic (Typ_arg_aux (arg, _)) = +and is_typ_arg_monomorphic (A_aux (arg, _)) = match arg with - | Typ_arg_nexp _ -> true - | Typ_arg_typ typ -> is_typ_monomorphic typ - | Typ_arg_order (Ord_aux (Ord_dec, _)) | Typ_arg_order (Ord_aux (Ord_inc, _)) -> true - | Typ_arg_order (Ord_aux (Ord_var _, _)) -> false + | A_nexp _ -> true + | A_typ typ -> is_typ_monomorphic typ + | A_order (Ord_aux (Ord_dec, _)) | A_order (Ord_aux (Ord_inc, _)) -> true + | A_order (Ord_aux (Ord_var _, _)) -> false (**************************************************************************) (* 2. Subtyping and constraint solving *) @@ -1373,11 +1374,11 @@ let rec typ_nexps (Typ_aux (typ_aux, l)) = List.concat (List.map typ_nexps arg_typs) @ typ_nexps ret_typ | Typ_bidir (typ1, typ2) -> typ_nexps typ1 @ typ_nexps typ2 -and typ_arg_nexps (Typ_arg_aux (typ_arg_aux, l)) = +and typ_arg_nexps (A_aux (typ_arg_aux, l)) = match typ_arg_aux with - | Typ_arg_nexp n -> [n] - | Typ_arg_typ typ -> typ_nexps typ - | Typ_arg_order ord -> [] + | A_nexp n -> [n] + | A_typ typ -> typ_nexps typ + | A_order ord -> [] let rec typ_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) = match typ_aux with @@ -1390,11 +1391,11 @@ let rec typ_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) = | Typ_exist (kids, nc, typ) -> typ_frees ~exs:(KidSet.of_list kids) typ | Typ_fn (arg_typs, ret_typ, _) -> List.fold_left KidSet.union (typ_frees ~exs:exs ret_typ) (List.map (typ_frees ~exs:exs) arg_typs) | Typ_bidir (typ1, typ2) -> KidSet.union (typ_frees ~exs:exs typ1) (typ_frees ~exs:exs typ2) -and typ_arg_frees ?exs:(exs=KidSet.empty) (Typ_arg_aux (typ_arg_aux, l)) = +and typ_arg_frees ?exs:(exs=KidSet.empty) (A_aux (typ_arg_aux, l)) = match typ_arg_aux with - | Typ_arg_nexp n -> nexp_frees ~exs:exs n - | Typ_arg_typ typ -> typ_frees ~exs:exs typ - | Typ_arg_order ord -> order_frees ord + | A_nexp n -> nexp_frees ~exs:exs n + | A_typ typ -> typ_frees ~exs:exs typ + | A_order ord -> order_frees ord let rec nexp_identical (Nexp_aux (nexp1, _)) (Nexp_aux (nexp2, _)) = match nexp1, nexp2 with @@ -1457,11 +1458,11 @@ let typ_identical env typ1 typ2 = | Typ_exist (kids1, nc1, typ1), Typ_exist (kids2, nc2, typ2) when List.length kids1 = List.length kids2 -> List.for_all2 (fun k1 k2 -> Kid.compare k1 k2 = 0) kids1 kids2 && nc_identical nc1 nc2 && typ_identical' typ1 typ2 | _, _ -> false - and typ_arg_identical (Typ_arg_aux (arg1, _)) (Typ_arg_aux (arg2, _)) = + and typ_arg_identical (A_aux (arg1, _)) (A_aux (arg2, _)) = match arg1, arg2 with - | Typ_arg_nexp n1, Typ_arg_nexp n2 -> nexp_identical n1 n2 - | Typ_arg_typ typ1, Typ_arg_typ typ2 -> typ_identical' typ1 typ2 - | Typ_arg_order ord1, Typ_arg_order ord2 -> ord_identical ord1 ord2 + | A_nexp n1, A_nexp n2 -> nexp_identical n1 n2 + | A_typ typ1, A_typ typ2 -> typ_identical' typ1 typ2 + | A_order ord1, A_order ord2 -> ord_identical ord1 ord2 | _, _ -> false in typ_identical' (Env.expand_synonyms env typ1) (Env.expand_synonyms env typ2) @@ -1472,7 +1473,7 @@ let unify_error l str = raise (Unification_error (l, str)) let merge_unifiers l kid uvar1 uvar2 = match uvar1, uvar2 with - | Some (Typ_arg_aux (Typ_arg_nexp n1, _)), Some (Typ_arg_aux (Typ_arg_nexp n2, _)) -> + | Some (A_aux (A_nexp n1, _)), Some (A_aux (A_nexp n2, _)) -> if nexp_identical n1 n2 then Some (arg_nexp n1) else @@ -1488,16 +1489,22 @@ let merge_uvars l unifiers1 unifiers2 = let rec unify_typ l env goals (Typ_aux (aux1, _) as typ1) (Typ_aux (aux2, _) as typ2) = match aux1, aux2 with + | Typ_internal_unknown, _ | _, Typ_internal_unknown + when Env.allow_unknowns env -> + KBindings.empty + | Typ_var v, _ when KidSet.mem v goals -> KBindings.singleton v (arg_typ typ2) - | Typ_app (range, [Typ_arg_aux (Typ_arg_nexp n1, _); Typ_arg_aux (Typ_arg_nexp n2, _)]), - Typ_app (atom, [Typ_arg_aux (Typ_arg_nexp m, _)]) + | Typ_app (range, [A_aux (A_nexp n1, _); A_aux (A_nexp n2, _)]), + Typ_app (atom, [A_aux (A_nexp m, _)]) when string_of_id range = "range" && string_of_id atom = "atom" -> merge_uvars l (unify_nexp l env goals n1 m) (unify_nexp l env goals n2 m) | Typ_app (id1, args1), Typ_app (id2, args2) when List.length args1 = List.length args2 && Id.compare id1 id2 = 0 -> List.fold_left (merge_uvars l) KBindings.empty (List.map2 (unify_typ_arg l env goals) args1 args2) + | Typ_app (id1, []), Typ_id id2 when Id.compare id1 id2 = 0 -> KBindings.empty + | Typ_id id1, Typ_app (id2, []) when Id.compare id1 id2 = 0 -> KBindings.empty | Typ_id id1, Typ_id id2 when Id.compare id1 id2 = 0 -> KBindings.empty | Typ_tup typs1, Typ_tup typs2 when List.length typs1 = List.length typs2 -> @@ -1505,11 +1512,11 @@ let rec unify_typ l env goals (Typ_aux (aux1, _) as typ1) (Typ_aux (aux2, _) as | _, _ -> unify_error l ("Cound not unify " ^ string_of_typ typ1 ^ " and " ^ string_of_typ typ2) -and unify_typ_arg l env goals (Typ_arg_aux (aux1, _) as typ_arg1) (Typ_arg_aux (aux2, _) as typ_arg2) = +and unify_typ_arg l env goals (A_aux (aux1, _) as typ_arg1) (A_aux (aux2, _) as typ_arg2) = match aux1, aux2 with - | Typ_arg_typ typ1, Typ_arg_typ typ2 -> unify_typ l env goals typ1 typ2 - | Typ_arg_nexp nexp1, Typ_arg_nexp nexp2 -> unify_nexp l env goals nexp1 nexp2 - | Typ_arg_order ord1, Typ_arg_order ord2 -> unify_order l goals ord1 ord2 + | A_typ typ1, A_typ typ2 -> unify_typ l env goals typ1 typ2 + | A_nexp nexp1, A_nexp nexp2 -> unify_nexp l env goals nexp1 nexp2 + | A_order ord1, A_order ord2 -> unify_order l goals ord1 ord2 | _, _ -> unify_error l ("Could not unify type arguments " ^ string_of_typ_arg typ_arg1 ^ " and " ^ string_of_typ_arg typ_arg2) and unify_order l goals (Ord_aux (aux1, _) as ord1) (Ord_aux (aux2, _) as ord2) = @@ -1589,14 +1596,22 @@ and unify_nexp l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (nexp_au else unify_error l ("Cannot unify Int expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) | _ -> unify_error l ("Cannot unify Int expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) -let unify l env typ1 typ2 goals = - typ_print (lazy (Util.("Unify " |> magenta |> clear) ^ string_of_typ typ1 ^ " and " ^ string_of_typ typ2)); +let unify l env goals typ1 typ2 = + typ_print (lazy (Util.("Unify " |> magenta |> clear) ^ string_of_typ typ1 ^ " and " ^ string_of_typ typ2 + ^ " for " ^ Util.string_of_list ", " string_of_kid (KidSet.elements goals))); let typ1, typ2 = Env.expand_synonyms env typ1, Env.expand_synonyms env typ2 in - unify_typ l env goals typ1 typ2 + if not (KidSet.is_empty (KidSet.inter goals (tyvars_of_typ typ2))) then + typ_error l ("Occurs check failed: " ^ string_of_typ typ2 ^ " contains " + ^ Util.string_of_list ", " string_of_kid (KidSet.elements goals)) + else + unify_typ l env goals typ1 typ2 let subst_unifiers unifiers typ = List.fold_left (fun typ (v, arg) -> typ_subst v arg typ) typ (KBindings.bindings unifiers) +let subst_unifiers_typ_arg unifiers typ_arg = + List.fold_left (fun typ_arg (v, arg) -> typ_arg_subst v arg typ_arg) typ_arg (KBindings.bindings unifiers) + let instantiate_quant (v, arg) (QI_aux (aux, l) as qi) = match aux with | QI_id kopt when Kid.compare (kopt_kid kopt) v = 0 -> @@ -1614,18 +1629,18 @@ let instantiate_quants quants unifier = let destruct_atom_nexp env typ = match Env.expand_synonyms env typ with - | Typ_aux (Typ_app (f, [Typ_arg_aux (Typ_arg_nexp n, _)]), _) + | Typ_aux (Typ_app (f, [A_aux (A_nexp n, _)]), _) when string_of_id f = "atom" -> Some n - | Typ_aux (Typ_app (f, [Typ_arg_aux (Typ_arg_nexp n, _); Typ_arg_aux (Typ_arg_nexp m, _)]), _) + | Typ_aux (Typ_app (f, [A_aux (A_nexp n, _); A_aux (A_nexp m, _)]), _) when string_of_id f = "range" && nexp_identical n m -> Some n | _ -> None let destruct_atom_kid env typ = match Env.expand_synonyms env typ with - | Typ_aux (Typ_app (f, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid, _)), _)]), _) + | Typ_aux (Typ_app (f, [A_aux (A_nexp (Nexp_aux (Nexp_var kid, _)), _)]), _) when string_of_id f = "atom" -> Some kid - | Typ_aux (Typ_app (f, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid1, _)), _); - Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid2, _)), _)]), _) + | Typ_aux (Typ_app (f, [A_aux (A_nexp (Nexp_aux (Nexp_var kid1, _)), _); + A_aux (A_nexp (Nexp_aux (Nexp_var kid2, _)), _)]), _) when string_of_id f = "range" && Kid.compare kid1 kid2 = 0 -> Some kid1 | _ -> None @@ -1657,11 +1672,11 @@ let rec kid_order kids (Typ_aux (aux, l) as typ) = List.fold_left (fun (ord, kids) arg -> let (ord', kids) = kid_order_arg kids arg in (ord @ ord', kids)) ([], kids) args | Typ_fn _ | Typ_bidir _ | Typ_exist _ -> typ_error l ("Existential or function type cannot appear within existential type: " ^ string_of_typ typ) | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" -and kid_order_arg kids (Typ_arg_aux (aux, l) as arg) = +and kid_order_arg kids (A_aux (aux, l) as arg) = match aux with - | Typ_arg_typ typ -> kid_order kids typ - | Typ_arg_nexp nexp -> kid_order_nexp kids nexp - | Typ_arg_order _ -> ([], kids) + | A_typ typ -> kid_order kids typ + | A_nexp nexp -> kid_order_nexp kids nexp + | A_order _ -> ([], kids) let rec alpha_equivalent env typ1 typ2 = let counter = ref 0 in @@ -1686,10 +1701,10 @@ let rec alpha_equivalent env typ1 typ2 = Typ_app (id, List.map relabel_arg args) in Typ_aux (relabelled_aux, l) - and relabel_arg (Typ_arg_aux (aux, l) as arg) = + and relabel_arg (A_aux (aux, l) as arg) = match aux with - | Typ_arg_nexp _ | Typ_arg_order _ -> arg - | Typ_arg_typ typ -> Typ_arg_aux (Typ_arg_typ (relabel typ), l) + | A_nexp _ | A_order _ -> arg + | A_typ typ -> A_aux (A_typ (relabel typ), l) in let typ1 = relabel (Env.expand_synonyms env typ1) in @@ -1707,7 +1722,7 @@ let unwrap_exist env typ = let unifier_constraint env (v, arg) = match arg with - | Typ_arg_aux (Typ_arg_nexp nexp, _) -> Env.add_constraint (nc_eq (nvar v) nexp) env + | A_aux (A_nexp nexp, _) -> Env.add_constraint (nc_eq (nvar v) nexp) env | _ -> env let rec subtyp l env (Typ_aux (typ_aux1, _) as typ1) (Typ_aux (typ_aux2, _) as typ2) = @@ -1742,7 +1757,7 @@ let rec subtyp l env (Typ_aux (typ_aux1, _) as typ1) (Typ_aux (typ_aux2, _) as t let kids' = KidSet.elements (KidSet.diff (KidSet.of_list kids) (typ_frees typ2)) in if not (kids' = []) then typ_error l "Universally quantified constraint generated" else (); let unifiers = - try unify l env typ2 typ1 (KidSet.of_list kids) with + try unify l env (tyvars_of_typ typ2) typ2 typ1 with | Unification_error (_, m) -> typ_error l m in let nc = List.fold_left (fun nc (kid, uvar) -> constraint_subst kid uvar nc) nc (KBindings.bindings unifiers) in @@ -1860,9 +1875,9 @@ in inst_from_eq let destruct_vec_typ l env typ = let destruct_vec_typ' l = function - | Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp n1, _); - Typ_arg_aux (Typ_arg_order o, _); - Typ_arg_aux (Typ_arg_typ vtyp, _)] + | Typ_aux (Typ_app (id, [A_aux (A_nexp n1, _); + A_aux (A_order o, _); + A_aux (A_typ vtyp, _)] ), _) when string_of_id id = "vector" -> (n1, o, vtyp) | typ -> typ_error l ("Expected vector type, got " ^ string_of_typ typ) in @@ -1927,10 +1942,10 @@ let rec big_int_of_nexp (Nexp_aux (nexp, _)) = match nexp with let destruct_atom (Typ_aux (typ_aux, _)) = match typ_aux with - | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp nexp, _)]) + | Typ_app (f, [A_aux (A_nexp nexp, _)]) when string_of_id f = "atom" -> Util.option_map (fun c -> (c, nexp)) (big_int_of_nexp nexp) - | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp nexp1, _); Typ_arg_aux (Typ_arg_nexp nexp2, _)]) + | Typ_app (f, [A_aux (A_nexp nexp1, _); A_aux (A_nexp nexp2, _)]) when string_of_id f = "range" -> begin match big_int_of_nexp nexp1, big_int_of_nexp nexp2 with @@ -2152,7 +2167,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ in let check_fexp (FE_aux (FE_Fexp (field, exp), (l, ()))) = let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field env in - let unifiers = try unify l env rectyp_q typ (tyvars_of_typ rectyp_q) with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in + let unifiers = try unify l env (tyvars_of_typ rectyp_q) rectyp_q typ with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in let field_typ' = subst_unifiers unifiers field_typ in let checked_exp = crule check_exp env exp field_typ' in FE_aux (FE_Fexp (field, checked_exp), (l, None)) @@ -2167,7 +2182,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ in let check_fexp (FE_aux (FE_Fexp (field, exp), (l, ()))) = let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field env in - let unifiers = try unify l env rectyp_q typ (tyvars_of_typ rectyp_q) with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in + let unifiers = try unify l env (tyvars_of_typ rectyp_q) rectyp_q typ with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in let field_typ' = subst_unifiers unifiers field_typ in let checked_exp = crule check_exp env exp field_typ' in FE_aux (FE_Fexp (field, checked_exp), (l, None)) @@ -2411,7 +2426,7 @@ and type_coercion_unify env goals (E_aux (_, (l, _)) as annotated_exp) typ = try let inferred_cast = irule infer_exp (Env.no_casts env) (strip (E_app (cast, [annotated_exp]))) in let ityp, env = bind_existential l (typ_of inferred_cast) env in - inferred_cast, unify l env typ ityp goals, env + inferred_cast, unify l env goals typ ityp, env with | Type_error (_, err) -> try_casts casts | Unification_error (_, err) -> try_casts casts @@ -2421,7 +2436,7 @@ and type_coercion_unify env goals (E_aux (_, (l, _)) as annotated_exp) typ = try typ_debug (lazy "PERFORMING COERCING UNIFICATION"); let atyp, env = bind_existential l (typ_of annotated_exp) env in - annotated_exp, unify l env typ atyp goals, env + annotated_exp, unify l env goals typ atyp, env with | Unification_error (_, m) when Env.allow_casts env -> let casts = filter_casts env (typ_of annotated_exp) typ (Env.get_casts env) in @@ -2475,7 +2490,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) | P_cons (hd_pat, tl_pat) -> begin match Env.expand_synonyms env typ with - | Typ_aux (Typ_app (f, [Typ_arg_aux (Typ_arg_typ ltyp, _)]), _) when Id.compare f (mk_id "list") = 0 -> + | Typ_aux (Typ_app (f, [A_aux (A_typ ltyp, _)]), _) when Id.compare f (mk_id "list") = 0 -> let hd_pat, env, hd_guards = bind_pat env hd_pat ltyp in let tl_pat, env, tl_guards = bind_pat env tl_pat typ in annot_pat (P_cons (hd_pat, tl_pat)) typ, env, hd_guards @ tl_guards @@ -2499,7 +2514,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) | P_list pats -> begin match Env.expand_synonyms env typ with - | Typ_aux (Typ_app (f, [Typ_arg_aux (Typ_arg_typ ltyp, _)]), _) when Id.compare f (mk_id "list") = 0 -> + | Typ_aux (Typ_app (f, [A_aux (A_typ ltyp, _)]), _) when Id.compare f (mk_id "list") = 0 -> let rec process_pats env = function | [] -> [], env, [] | (pat :: pats) -> @@ -2543,9 +2558,9 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) | Typ_aux (Typ_fn ([arg_typ], ret_typ, _), _) -> begin try - let goals = List.fold_left KidSet.union KidSet.empty (List.map tyvars_of_quant_item quants) in + let goals = quant_kopts typq |> List.map kopt_kid |> KidSet.of_list in typ_debug (lazy ("Unifying " ^ string_of_bind (typq, ctor_typ) ^ " for pattern " ^ string_of_typ typ)); - let unifiers = unify l env ret_typ typ goals in + let unifiers = unify l env goals ret_typ typ in let arg_typ' = subst_unifiers unifiers arg_typ in let quants' = List.fold_left instantiate_quants quants (KBindings.bindings unifiers) in if (match quants' with [] -> false | _ -> true) @@ -2578,7 +2593,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) typ_debug (lazy ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for pattern " ^ string_of_typ typ)); (* FIXME: There's no obvious goals here *) - let unifiers = unify l env typ2 typ (tyvars_of_typ typ2) in + let unifiers = unify l env (tyvars_of_typ typ2) typ2 typ in let arg_typ' = subst_unifiers unifiers typ1 in let quants' = List.fold_left instantiate_quants quants (KBindings.bindings unifiers) in if (match quants' with [] -> false | _ -> true) @@ -2596,7 +2611,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) try typ_debug (lazy "Unifying mapping forwards failed, trying backwards."); typ_debug (lazy ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for pattern " ^ string_of_typ typ)); - let unifiers = unify l env typ1 typ (tyvars_of_typ typ1) in + let unifiers = unify l env (tyvars_of_typ typ1) typ1 typ in let arg_typ' = subst_unifiers unifiers typ2 in let quants' = List.fold_left instantiate_quants quants (KBindings.bindings unifiers) in if (match quants' with [] -> false | _ -> true) @@ -2734,13 +2749,13 @@ and bind_typ_pat env (TP_aux (typ_pat_aux, l) as typ_pat) (Typ_aux (typ_aux, _) | TP_app (f1, tpats), Typ_app (f2, typs) when Id.compare f1 f2 = 0 -> List.fold_left2 bind_typ_pat_arg env tpats typs | _, _ -> typ_error l ("Couldn't bind type " ^ string_of_typ typ ^ " with " ^ string_of_typ_pat typ_pat) -and bind_typ_pat_arg env (TP_aux (typ_pat_aux, l) as typ_pat) (Typ_arg_aux (typ_arg_aux, _) as typ_arg) = +and bind_typ_pat_arg env (TP_aux (typ_pat_aux, l) as typ_pat) (A_aux (typ_arg_aux, _) as typ_arg) = match typ_pat_aux, typ_arg_aux with | TP_wild, _ -> env - | TP_var kid, Typ_arg_nexp nexp -> + | TP_var kid, A_nexp nexp -> Env.add_constraint (nc_eq (nvar kid) nexp) (Env.add_typ_var l kid K_int env) - | _, Typ_arg_typ typ -> bind_typ_pat env typ_pat typ - | _, Typ_arg_order _ -> typ_error l "Cannot bind type pattern against order" + | _, A_typ typ -> bind_typ_pat env typ_pat typ + | _, A_order _ -> typ_error l "Cannot bind type pattern against order" | _, _ -> typ_error l ("Couldn't bind type argument " ^ string_of_typ_arg typ_arg ^ " with " ^ string_of_typ_pat typ_pat) and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as exp) = @@ -2787,7 +2802,7 @@ and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as | Typ_aux (Typ_id rectyp_id, _) | Typ_aux (Typ_app (rectyp_id, _), _) when Env.is_record rectyp_id env -> let eff = if is_register then mk_effect [BE_wreg] else no_effect in let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field env in - let unifiers = try unify l env rectyp_q regtyp (tyvars_of_typ rectyp_q) with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in + let unifiers = try unify l env (tyvars_of_typ rectyp_q) rectyp_q regtyp with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in let field_typ' = subst_unifiers unifiers field_typ in let checked_exp = crule check_exp env exp field_typ' in annot_assign (annot_lexp (LEXP_field (annot_lexp_effect inferred_flexp regtyp eff, field)) field_typ') checked_exp, env @@ -2817,11 +2832,13 @@ and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as let tlexp, env' = bind_lexp env lexp (typ_of inferred_exp) in annot_assign tlexp inferred_exp, env' with - | Type_error (_, _) -> - let inferred_lexp = infer_lexp env lexp in - let checked_exp = crule check_exp env exp (lexp_typ_of inferred_lexp) in - annot_assign inferred_lexp checked_exp, env - + | Type_error (l, err) -> + try + let inferred_lexp = infer_lexp env lexp in + let checked_exp = crule check_exp env exp (lexp_typ_of inferred_lexp) in + annot_assign inferred_lexp checked_exp, env + with Type_error (l, err') -> typ_raise l (Err_because (err', err)) + and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = typ_print (lazy ("Binding mutable " ^ string_of_lexp lexp ^ " to " ^ string_of_typ typ)); let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, Some ((env, typ, eff),None))) in @@ -2846,7 +2863,7 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = | LEXP_deref exp -> let inferred_exp = infer_exp env exp in begin match typ_of inferred_exp with - | Typ_aux (Typ_app (r, [Typ_arg_aux (Typ_arg_typ vtyp, _)]), _) when string_of_id r = "register" -> + | Typ_aux (Typ_app (r, [A_aux (A_typ vtyp, _)]), _) when string_of_id r = "register" -> subtyp l env typ vtyp; annot_lexp_effect (LEXP_deref inferred_exp) typ (mk_effect [BE_wreg]), env | _ -> typ_error l (string_of_typ typ ^ " must be a register type in " ^ string_of_exp exp ^ ")") @@ -2899,7 +2916,7 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) = let inferred_v_lexp = infer_lexp env v_lexp in let (Typ_aux (v_typ_aux, _) as v_typ) = Env.expand_synonyms env (lexp_typ_of inferred_v_lexp) in match v_typ_aux with - | Typ_app (id, [Typ_arg_aux (Typ_arg_nexp len, _); Typ_arg_aux (Typ_arg_order ord, _); Typ_arg_aux (Typ_arg_typ elem_typ, _)]) + | Typ_app (id, [A_aux (A_nexp len, _); A_aux (A_order ord, _); A_aux (A_typ elem_typ, _)]) when Id.compare id (mk_id "vector") = 0 -> let inferred_exp1 = infer_exp env exp1 in let inferred_exp2 = infer_exp env exp2 in @@ -2921,7 +2938,7 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) = let inferred_v_lexp = infer_lexp env v_lexp in let (Typ_aux (v_typ_aux, _) as v_typ) = Env.expand_synonyms env (lexp_typ_of inferred_v_lexp) in match v_typ_aux with - | Typ_app (id, [Typ_arg_aux (Typ_arg_nexp len, _); Typ_arg_aux (Typ_arg_order ord, _); Typ_arg_aux (Typ_arg_typ elem_typ, _)]) + | Typ_app (id, [A_aux (A_nexp len, _); A_aux (A_order ord, _); A_aux (A_typ elem_typ, _)]) when Id.compare id (mk_id "vector") = 0 -> let inferred_exp = infer_exp env exp in let nexp, env = bind_numeric l (typ_of inferred_exp) env in @@ -2936,7 +2953,7 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) = begin let sum_lengths first_ord first_elem_typ acc (Typ_aux (v_typ_aux, _) as v_typ) = match v_typ_aux with - | Typ_app (id, [Typ_arg_aux (Typ_arg_nexp len, _); Typ_arg_aux (Typ_arg_order ord, _); Typ_arg_aux (Typ_arg_typ elem_typ, _)]) + | Typ_app (id, [A_aux (A_nexp len, _); A_aux (A_order ord, _); A_aux (A_typ elem_typ, _)]) when Id.compare id (mk_id "vector") = 0 && ord_identical ord first_ord -> typ_equality l env elem_typ first_elem_typ; nsum acc len @@ -2947,7 +2964,7 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) = let (Typ_aux (v_typ_aux, _) as v_typ) = Env.expand_synonyms env (lexp_typ_of inferred_v_lexp) in let v_typs = List.map (fun lexp -> Env.expand_synonyms env (lexp_typ_of lexp)) inferred_v_lexps in match v_typ_aux with - | Typ_app (id, [Typ_arg_aux (Typ_arg_nexp len, _); Typ_arg_aux (Typ_arg_order ord, _); Typ_arg_aux (Typ_arg_typ elem_typ, _)]) + | Typ_app (id, [A_aux (A_nexp len, _); A_aux (A_order ord, _); A_aux (A_typ elem_typ, _)]) when Id.compare id (mk_id "vector") = 0 -> let len = List.fold_left (sum_lengths ord elem_typ) len v_typs in annot_lexp (LEXP_vector_concat (inferred_v_lexp :: inferred_v_lexps)) (vector_typ (nexp_simp len) ord elem_typ) @@ -2981,7 +2998,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = | Unbound -> typ_error l ("Identifier " ^ string_of_id v ^ " is unbound") end | E_lit lit -> annot_exp (E_lit lit) (infer_lit env lit) - | E_sizeof nexp -> annot_exp (E_sizeof nexp) (mk_typ (Typ_app (mk_id "atom", [mk_typ_arg (Typ_arg_nexp nexp)]))) + | E_sizeof nexp -> annot_exp (E_sizeof nexp) (mk_typ (Typ_app (mk_id "atom", [mk_typ_arg (A_nexp nexp)]))) | E_constraint nc -> Env.wf_constraint env nc; annot_exp (E_constraint nc) bool_typ @@ -3022,7 +3039,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = in let check_fexp (FE_aux (FE_Fexp (field, exp), (l, ()))) = let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field env in - let unifiers = try unify l env rectyp_q typ (tyvars_of_typ rectyp_q) with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in + let unifiers = try unify l env (tyvars_of_typ rectyp_q) rectyp_q typ with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in let field_typ' = subst_unifiers unifiers field_typ in let inferred_exp = crule check_exp env exp field_typ' in FE_aux (FE_Fexp (field, inferred_exp), (l, None)) @@ -3179,6 +3196,13 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ = let universals = Env.get_typ_vars env in let universal_constraints = Env.get_constraints env in + let all_unifiers = ref KBindings.empty in + let record_unifiers unifiers = + let previous_unifiers = !all_unifiers in + let updated_unifiers = KBindings.map (subst_unifiers_typ_arg unifiers) previous_unifiers in + all_unifiers := merge_uvars l updated_unifiers unifiers; + in + let quants, typ_args, typ_ret, eff = match Env.expand_synonyms env f_typ with | Typ_aux (Typ_fn (typ_args, typ_ret, eff), _) -> ref (quant_items typq), typ_args, ref typ_ret, eff @@ -3202,9 +3226,11 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ = | None -> typ_args | Some expect when is_exist (Env.expand_synonyms env expect) || is_exist !typ_ret -> typ_args | Some expect -> - let goals = List.fold_left KidSet.union KidSet.empty (List.map tyvars_of_quant_item !quants) in + let goals = quant_kopts (mk_typquant !quants) |> List.map kopt_kid |> KidSet.of_list in try - let unifiers = unify l env !typ_ret expect goals |> KBindings.bindings in + let unifiers = unify l env goals !typ_ret expect in + record_unifiers unifiers; + let unifiers = KBindings.bindings unifiers in typ_debug (lazy (Util.("Unifiers " |> magenta |> clear) ^ Util.string_of_list ", " (fun (v, arg) -> string_of_kid v ^ " => " ^ string_of_typ_arg arg) unifiers)); List.iter (fun unifier -> quants := instantiate_quants !quants unifier) unifiers; @@ -3219,12 +3245,14 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ = if KidSet.for_all (is_bound env) (tyvars_of_typ typ) then crule check_exp env arg typ, remaining_typs, env else - let goals = List.fold_left KidSet.union KidSet.empty (List.map tyvars_of_quant_item !quants) in + let goals = quant_kopts (mk_typquant !quants) |> List.map kopt_kid |> KidSet.of_list in + typ_debug (lazy ("Quantifiers " ^ Util.string_of_list ", " string_of_quant_item !quants)); let inferred_arg = irule infer_exp env arg in let inferred_arg, unifiers, env = try type_coercion_unify env goals inferred_arg typ with | Unification_error (l, m) -> typ_error l m in + record_unifiers unifiers; let unifiers = KBindings.bindings unifiers in typ_debug (lazy (Util.("Unifiers " |> magenta |> clear) ^ Util.string_of_list ", " (fun (v, arg) -> string_of_kid v ^ " => " ^ string_of_typ_arg arg) unifiers)); @@ -3266,7 +3294,7 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ = let exp = annot_exp (E_app (f, xs)) typ_ret eff in typ_debug (lazy ("RETURNING: " ^ string_of_exp exp)); - exp, KBindings.empty (* FIXME *) + exp, !all_unifiers and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) (Typ_aux (typ_aux, _) as typ) = let (Typ_aux (typ_aux, _) as typ), env = bind_existential l typ env in @@ -3298,7 +3326,7 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) ( | MP_cons (hd_mpat, tl_mpat) -> begin match Env.expand_synonyms env typ with - | Typ_aux (Typ_app (f, [Typ_arg_aux (Typ_arg_typ ltyp, _)]), _) when Id.compare f (mk_id "list") = 0 -> + | Typ_aux (Typ_app (f, [A_aux (A_typ ltyp, _)]), _) when Id.compare f (mk_id "list") = 0 -> let hd_mpat, env, hd_guards = bind_mpat allow_unknown other_env env hd_mpat ltyp in let tl_mpat, env, tl_guards = bind_mpat allow_unknown other_env env tl_mpat typ in annot_mpat (MP_cons (hd_mpat, tl_mpat)) typ, env, hd_guards @ tl_guards @@ -3322,7 +3350,7 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) ( | MP_list mpats -> begin match Env.expand_synonyms env typ with - | Typ_aux (Typ_app (f, [Typ_arg_aux (Typ_arg_typ ltyp, _)]), _) when Id.compare f (mk_id "list") = 0 -> + | Typ_aux (Typ_app (f, [A_aux (A_typ ltyp, _)]), _) when Id.compare f (mk_id "list") = 0 -> let rec process_mpats env = function | [] -> [], env, [] | (pat :: mpats) -> @@ -3365,7 +3393,7 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) ( begin try typ_debug (lazy ("Unifying " ^ string_of_bind (typq, ctor_typ) ^ " for mapping-pattern " ^ string_of_typ typ)); - let unifiers = unify l env ret_typ typ (tyvars_of_typ ret_typ) in + let unifiers = unify l env (tyvars_of_typ ret_typ) ret_typ typ in let arg_typ' = subst_unifiers unifiers arg_typ in let quants' = List.fold_left instantiate_quants quants (KBindings.bindings unifiers) in if (match quants' with [] -> false | _ -> true) @@ -3395,7 +3423,7 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) ( begin try typ_debug (lazy ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for mapping-pattern " ^ string_of_typ typ)); - let unifiers = unify l env typ2 typ (tyvars_of_typ typ2) in + let unifiers = unify l env (tyvars_of_typ typ2) typ2 typ in let arg_typ' = subst_unifiers unifiers typ1 in let quants' = List.fold_left instantiate_quants quants (KBindings.bindings unifiers) in if (match quants' with [] -> false | _ -> true) @@ -3412,7 +3440,7 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) ( try typ_debug (lazy "Unifying mapping forwards failed, trying backwards."); typ_debug (lazy ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for mapping-pattern " ^ string_of_typ typ)); - let unifiers = unify l env typ1 typ (tyvars_of_typ typ1) in + let unifiers = unify l env (tyvars_of_typ typ1) typ1 typ in let arg_typ' = subst_unifiers unifiers typ2 in let quants' = List.fold_left instantiate_quants quants (KBindings.bindings unifiers) in if (match quants' with [] -> false | _ -> true) @@ -4164,14 +4192,14 @@ let check_default env (DT_aux (ds, l)) = | DT_order (Ord_aux (Ord_var _, _)) -> typ_error l "Cannot have variable default order" let kinded_id_arg kind_id = - let typ_arg arg = Typ_arg_aux (arg, Parse_ast.Unknown) in + let typ_arg arg = A_aux (arg, Parse_ast.Unknown) in match kind_id with - | KOpt_aux (KOpt_none kid, _) -> typ_arg (Typ_arg_nexp (nvar kid)) - | KOpt_aux (KOpt_kind (K_aux (K_int, _), kid), _) -> typ_arg (Typ_arg_nexp (nvar kid)) + | KOpt_aux (KOpt_none kid, _) -> typ_arg (A_nexp (nvar kid)) + | KOpt_aux (KOpt_kind (K_aux (K_int, _), kid), _) -> typ_arg (A_nexp (nvar kid)) | KOpt_aux (KOpt_kind (K_aux (K_order, _), kid), _) -> - typ_arg (Typ_arg_order (Ord_aux (Ord_var kid, Parse_ast.Unknown))) + typ_arg (A_order (Ord_aux (Ord_var kid, Parse_ast.Unknown))) | KOpt_aux (KOpt_kind (K_aux (K_type, _), kid), _) -> - typ_arg (Typ_arg_typ (mk_typ (Typ_var kid))) + typ_arg (A_typ (mk_typ (Typ_var kid))) let fold_union_quant quants (QI_aux (qi, l)) = match qi with @@ -4197,21 +4225,21 @@ let mk_synonym typq typ_arg = let kopts, ncs = quant_split typq in let rec subst_args kopts args = match kopts, args with - | kopt :: kopts, Typ_arg_aux (Typ_arg_nexp arg, _) :: args when is_nat_kopt kopt -> + | kopt :: kopts, A_aux (A_nexp arg, _) :: args when is_nat_kopt kopt -> let typ_arg, ncs = subst_args kopts args in typ_arg_subst (kopt_kid kopt) (arg_nexp arg) typ_arg, List.map (constraint_subst (kopt_kid kopt) (arg_nexp arg)) ncs - | kopt :: kopts, Typ_arg_aux (Typ_arg_typ arg, _) :: args when is_typ_kopt kopt -> + | kopt :: kopts, A_aux (A_typ arg, _) :: args when is_typ_kopt kopt -> let typ_arg, ncs = subst_args kopts args in typ_arg_subst (kopt_kid kopt) (arg_typ arg) typ_arg, ncs - | kopt :: kopts, Typ_arg_aux (Typ_arg_order arg, _) :: args when is_order_kopt kopt -> + | kopt :: kopts, A_aux (A_order arg, _) :: args when is_order_kopt kopt -> let typ_arg, ncs = subst_args kopts args in typ_arg_subst (kopt_kid kopt) (arg_order arg) typ_arg, ncs - | kopt :: kopts, Typ_arg_aux (Typ_arg_bool arg, _) :: args when is_order_kopt kopt -> + | kopt :: kopts, A_aux (A_bool arg, _) :: args when is_order_kopt kopt -> let typ_arg, ncs = subst_args kopts args in typ_arg_subst (kopt_kid kopt) (arg_bool arg) typ_arg, ncs | [], [] -> typ_arg, ncs - | _, Typ_arg_aux (_, l) :: _ -> typ_error l "Synonym applied to bad arguments" + | _, A_aux (_, l) :: _ -> typ_error l "Synonym applied to bad arguments" | _, _ -> typ_error Parse_ast.Unknown "Synonym applied to bad arguments" in fun env args -> @@ -4234,7 +4262,7 @@ let rec check_typedef : 'a. Env.t -> 'a type_def -> (tannot def) list * Env.t = fun env (TD_aux (tdef, (l, _))) -> let td_err () = raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented Typedef") in match tdef with - | TD_abbrev (id, typq, (Typ_arg_aux (Typ_arg_typ _, _) as typ_arg)) -> + | TD_abbrev (id, typq, (A_aux (A_typ _, _) as typ_arg)) -> [DEF_type (TD_aux (tdef, (l, None)))], Env.add_typ_synonym id (mk_synonym typq typ_arg) env (* For type synonyms for non-Type kinds we omit them from the AST *) | TD_abbrev (id, typq, typ_arg) -> @@ -4255,9 +4283,9 @@ let rec check_typedef : 'a. Env.t -> 'a type_def -> (tannot def) list * Env.t = begin match typ with (* The type of a bitfield must be a constant-width bitvector *) - | Typ_aux (Typ_app (v, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant size, _)), _); - Typ_arg_aux (Typ_arg_order order, _); - Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id b, _)), _)]), _) + | Typ_aux (Typ_app (v, [A_aux (A_nexp (Nexp_aux (Nexp_constant size, _)), _); + A_aux (A_order order, _); + A_aux (A_typ (Typ_aux (Typ_id b, _)), _)]), _) when string_of_id v = "vector" && string_of_id b = "bit" -> let size = Big_int.to_int size in let (Defs defs), env = check env (Bitfield.macro id size order ranges) in @@ -4343,11 +4371,11 @@ let initial_env = |> Env.add_val_spec (mk_id "size_itself_int") (TypQ_aux (TypQ_tq [QI_aux (QI_id (KOpt_aux (KOpt_none (mk_kid "n"),Parse_ast.Unknown)), Parse_ast.Unknown)],Parse_ast.Unknown), - function_typ [app_typ (mk_id "itself") [mk_typ_arg (Typ_arg_nexp (nvar (mk_kid "n")))]] + function_typ [app_typ (mk_id "itself") [mk_typ_arg (A_nexp (nvar (mk_kid "n")))]] (atom_typ (nvar (mk_kid "n"))) no_effect) |> Env.add_extern (mk_id "make_the_value") (fun _ -> Some "make_the_value") |> Env.add_val_spec (mk_id "make_the_value") (TypQ_aux (TypQ_tq [QI_aux (QI_id (KOpt_aux (KOpt_none (mk_kid "n"),Parse_ast.Unknown)), Parse_ast.Unknown)],Parse_ast.Unknown), function_typ [atom_typ (nvar (mk_kid "n"))] - (app_typ (mk_id "itself") [mk_typ_arg (Typ_arg_nexp (nvar (mk_kid "n")))]) no_effect) + (app_typ (mk_id "itself") [mk_typ_arg (A_nexp (nvar (mk_kid "n")))]) no_effect) diff --git a/src/type_check.mli b/src/type_check.mli index 7dc2da30..52ade6fa 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -80,6 +80,7 @@ type type_error = | Err_subtype of typ * typ * n_constraint list * Ast.l KBindings.t | Err_no_num_ident of id | Err_other of string + | Err_because of type_error * type_error exception Type_error of l * type_error;; @@ -359,7 +360,13 @@ val destruct_vector : Env.t -> typ -> (nexp * order * typ) option val subst_unifiers : typ_arg KBindings.t -> typ -> typ -val unify : l -> Env.t -> typ -> typ -> typ_arg KBindings.t * kid list * n_constraint option +(** [unify l env goals typ1 typ2] returns set of typ_arg bindings such + that substituting those bindings using every type variable in goals + will make typ1 and typ2 equal. Will throw a Unification_error if + typ1 and typ2 cannot unification (although unification in Sail is + not complete). Will throw a type error if any goals appear in in + typ2 (occurs check). *) +val unify : l -> Env.t -> KidSet.t -> typ -> typ -> typ_arg KBindings.t val alpha_equivalent : Env.t -> typ -> typ -> bool diff --git a/src/type_error.ml b/src/type_error.ml index 0fa238ed..9144e993 100644 --- a/src/type_error.ml +++ b/src/type_error.ml @@ -133,7 +133,7 @@ let rec analyze_unresolved_quant2 locals ncs = function (* If we have a really anonymous type-variable, try to find a regular variable that corresponds to it. *) let is_linked v = function - | (id, (Immutable, (Typ_aux (Typ_app (ty_id, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var v', _)), _)]), _) as typ))) + | (id, (Immutable, (Typ_aux (Typ_app (ty_id, [A_aux (A_nexp (Nexp_aux (Nexp_var v', _)), _)]), _) as typ))) when Id.compare ty_id (mk_id "atom") = 0 && Kid.compare v v' = 0 -> [(v, nid id, typ)] | (id, (mut, typ)) -> @@ -178,7 +178,7 @@ let rec analyze_unresolved_quant locals ncs = function (* If we have a really anonymous type-variable, try to find a regular variable that corresponds to it. *) let is_linked v = function - | (id, (Immutable, (Typ_aux (Typ_app (ty_id, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var v', _)), _)]), _) as typ))) + | (id, (Immutable, (Typ_aux (Typ_app (ty_id, [A_aux (A_nexp (Nexp_aux (Nexp_var v', _)), _)]), _) as typ))) when Id.compare ty_id (mk_id "atom") = 0 && Kid.compare v v' = 0 -> [(v, nid id, typ)] | (id, (mut, typ)) -> @@ -206,18 +206,20 @@ let rec pp_type_error = function in coercion ^^ hardline ^^ (string "Coercion failed because:" ^//^ pp_type_error trigger) - ^^ hardline - ^^ (string "Possible reasons:" ^//^ separate_map hardline pp_type_error reasons) + ^^ if not (reasons = []) then + hardline + ^^ (string "Possible reasons:" ^//^ separate_map hardline pp_type_error reasons) + else + empty | Err_no_overloading (id, errs) -> string ("No overloadings for " ^ string_of_id id ^ ", tried:") ^//^ group (separate_map hardline (fun (id, err) -> string (string_of_id id) ^^ colon ^//^ pp_type_error err) errs) | Err_subtype (typ1, typ2, constrs, locs) -> - enclose (string (Util.termcode 1)) (string (Util.termcode 21)) - (separate space [ string (string_of_typ typ1); - string "is not a subtype of"; - string (string_of_typ typ2) ]) + (separate space [ string (string_of_typ typ1); + string "is not a subtype of"; + string (string_of_typ typ2) ]) ^/^ string "in context" ^/^ bullet pp_n_constraint constrs ^/^ string "where" @@ -232,6 +234,12 @@ let rec pp_type_error = function ^^ twice hardline ^^ group (separate_map hardline (analyze_unresolved_quant locals ncs) quants) + (* We only got err, because of previous error, err' *) + | Err_because (err, err') -> + pp_type_error err + ^^ hardline ^^ string "This error occured because of a previous error:" + ^//^ pp_type_error err' + | Err_other str -> string str let rec string_of_type_error err = -- cgit v1.2.3 From 5bc5f5dee8921f8d24260dae54177e00c291fcb1 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 10 Dec 2018 20:39:16 +0000 Subject: Various changes: * Improve type inference for numeric if statements (if_infer test) * Correctly handle constraints for existentially quantified constructors (constraint_ctor test) * Canonicalise all numeric types in function arguments, which triggers some weird edge cases between parametric polymorphism and subtyping of numeric arguments * Because of this eq_int, eq_range, and eq_atom etc become identical * Avoid duplicating destruct_exist in Env * Handle some odd subtyping cases better --- src/ast_util.ml | 9 +- src/c_backend.ml | 2 +- src/initial_check.ml | 5 + src/initial_check.mli | 1 + src/isail.ml | 3 + src/monomorphise.ml | 8 +- src/parser.mly | 6 + src/pretty_print_coq.ml | 16 +- src/rewrites.ml | 2 +- src/type_check.ml | 386 ++++++++++++++++++++++++++---------------------- src/type_check.mli | 6 +- 11 files changed, 247 insertions(+), 197 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index f6b8317d..46afe599 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -368,12 +368,17 @@ let nc_lteq n1 n2 = NC_aux (NC_bounded_le (n1, n2), Parse_ast.Unknown) let nc_gteq n1 n2 = NC_aux (NC_bounded_ge (n1, n2), Parse_ast.Unknown) let nc_lt n1 n2 = nc_lteq (nsum n1 (nint 1)) n2 let nc_gt n1 n2 = nc_gteq n1 (nsum n2 (nint 1)) -let nc_and nc1 nc2 = mk_nc (NC_and (nc1, nc2)) let nc_or nc1 nc2 = mk_nc (NC_or (nc1, nc2)) let nc_var kid = mk_nc (NC_var kid) let nc_true = mk_nc NC_true let nc_false = mk_nc NC_false +let nc_and nc1 nc2 = + match nc1, nc2 with + | _, NC_aux (NC_true, _) -> nc1 + | NC_aux (NC_true, _), _ -> nc2 + | _, _ -> mk_nc (NC_and (nc1, nc2)) + let arg_nexp ?loc:(l=Parse_ast.Unknown) n = A_aux (A_nexp n, l) let arg_order ?loc:(l=Parse_ast.Unknown) ord = A_aux (A_order ord, l) let arg_typ ?loc:(l=Parse_ast.Unknown) typ = A_aux (A_typ typ, l) @@ -685,7 +690,7 @@ and string_of_typ_arg_aux = function | A_order o -> string_of_order o | A_bool nc -> string_of_n_constraint nc and string_of_n_constraint = function - | NC_aux (NC_equal (n1, n2), _) -> string_of_nexp n1 ^ " = " ^ string_of_nexp n2 + | NC_aux (NC_equal (n1, n2), _) -> string_of_nexp n1 ^ " == " ^ string_of_nexp n2 | NC_aux (NC_not_equal (n1, n2), _) -> string_of_nexp n1 ^ " != " ^ string_of_nexp n2 | NC_aux (NC_bounded_ge (n1, n2), _) -> string_of_nexp n1 ^ " >= " ^ string_of_nexp n2 | NC_aux (NC_bounded_le (n1, n2), _) -> string_of_nexp n1 ^ " <= " ^ string_of_nexp n2 diff --git a/src/c_backend.ml b/src/c_backend.ml index 535a0b67..95ab51df 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -194,7 +194,7 @@ let rec ctyp_of_typ ctx typ = ensure that we don't cause any type variable clashes in local_env, and that we can optimize the existential based upon it's constraints. *) - begin match destruct_exist ctx.local_env typ with + begin match destruct_exist (Env.expand_synonyms ctx.local_env typ) with | Some (kids, nc, typ) -> let env = add_existential l kids nc ctx.local_env in ctyp_of_typ { ctx with local_env = env } typ diff --git a/src/initial_check.ml b/src/initial_check.ml index 0f1af63d..44f36892 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -777,6 +777,11 @@ let typschm_of_string str = let typschm, _ = to_ast_typschm initial_ctx typschm in typschm +let typ_of_string str = + let typ = Parser.typ_eof Lexer.token (Lexing.from_string str) in + let typ = to_ast_typ initial_ctx typ in + typ + let extern_of_string id str = mk_val_spec (VS_val_spec (typschm_of_string str, id, (fun _ -> Some (string_of_id id)), false)) let val_spec_of_string id str = mk_val_spec (VS_val_spec (typschm_of_string str, id, (fun _ -> None), false)) diff --git a/src/initial_check.mli b/src/initial_check.mli index 32def316..25187e4c 100644 --- a/src/initial_check.mli +++ b/src/initial_check.mli @@ -91,3 +91,4 @@ val extern_of_string : id -> string -> unit def val val_spec_of_string : id -> string -> unit def val exp_of_string : string -> unit exp +val typ_of_string : string -> typ diff --git a/src/isail.ml b/src/isail.ml index 195e5940..18c59e0b 100644 --- a/src/isail.ml +++ b/src/isail.ml @@ -270,6 +270,9 @@ let handle_input' input = let exp = Type_check.infer_exp !interactive_env exp in pretty_sail stdout (doc_typ (Type_check.typ_of exp)); print_newline () + | ":canon" -> + let typ = Initial_check.typ_of_string arg in + print_endline (string_of_typ (Type_check.canonicalize !interactive_env typ)) | ":v" | ":verbose" -> Type_check.opt_tc_debug := (!Type_check.opt_tc_debug + 1) mod 3; print_endline ("Verbosity: " ^ string_of_int !Type_check.opt_tc_debug) diff --git a/src/monomorphise.ml b/src/monomorphise.ml index 74ef8376..113db3a2 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -522,7 +522,7 @@ let refine_constructor refinements l env id args = (* A constructor should always have a single argument. *) | Typ_aux (Typ_fn ([constr_ty],_,_),_) -> begin let arg_ty = typ_of_args args in - match Type_check.destruct_exist env constr_ty with + match Type_check.destruct_exist (Type_check.Env.expand_synonyms env constr_ty) with | None -> None | Some (kids,nc,constr_ty) -> let bindings = Type_check.unify l env (tyvars_of_typ constr_ty) constr_ty arg_ty in @@ -728,7 +728,7 @@ let fabricate_nexp l tannot = match destruct_tannot tannot with | None -> nint 32 | Some (env,typ,_) -> - match Type_check.destruct_exist env typ with + match Type_check.destruct_exist (Type_check.Env.expand_synonyms env typ) with | None -> nint 32 | Some (kids,nc,typ') -> fabricate_nexp_exist env l typ kids nc typ' @@ -745,7 +745,7 @@ let atom_typ_kid kid = function let reduce_cast typ exp l annot = let env = env_of_annot (l,annot) in let typ' = Env.base_typ_of env typ in - match exp, destruct_exist env typ' with + match exp, destruct_exist (Env.expand_synonyms env typ') with | E_aux (E_lit (L_aux (L_num n,_)),_), Some ([kid],nc,typ'') when atom_typ_kid kid typ'' -> let nc_env = Env.add_typ_var l kid K_int env in let nc_env = Env.add_constraint (nc_eq (nvar kid) (nconstant n)) nc_env in @@ -3182,7 +3182,7 @@ let rec analyse_exp fn_id env assigns (E_aux (e,(l,annot)) as exp) = | Some (tenv,typ,_) -> let typ = Env.base_typ_of tenv typ in let env, tenv, typ = - match destruct_exist tenv typ with + match destruct_exist (Env.expand_synonyms tenv typ) with | None -> env, tenv, typ | Some (kids, nc, typ) -> { env with kid_deps = diff --git a/src/parser.mly b/src/parser.mly index fa36591c..83e6936d 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -212,9 +212,11 @@ let rec desugar_rchain chain s e = %start file %start typschm_eof +%start typ_eof %start exp_eof %start def_eof %type typschm_eof +%type typ_eof %type exp_eof %type def_eof %type file @@ -349,6 +351,10 @@ tyarg: | Lparen typ_list Rparen { [], $2 } +typ_eof: + | typ Eof + { $1 } + typ: | typ0 { $1 } diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 025156cc..f00a93b7 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -667,7 +667,7 @@ let is_ctor env id = match Env.lookup_id id env with let is_auto_decomposed_exist env typ = let typ = expand_range_type typ in - match destruct_exist env typ with + match destruct_exist (Env.expand_synonyms env typ) with | Some (_, _, typ') -> Some typ' | _ -> None @@ -905,7 +905,7 @@ let doc_exp, doc_let = debug ctxt (lazy (" at type " ^ string_of_typ typ)) in let typ = expand_range_type typ in - match destruct_exist env typ with + match destruct_exist typ with | None -> epp | Some _ -> let epp = string "build_ex" ^/^ epp in @@ -921,12 +921,12 @@ let doc_exp, doc_let = | _ -> let typ' = expand_range_type (Env.expand_synonyms (env_of exp) typ) in let build_ex, out_typ = - match destruct_exist env typ' with + match destruct_exist typ' with | Some (_,_,t) -> true, t | None -> false, typ' in let in_typ = expand_range_type (Env.expand_synonyms (env_of exp) (typ_of exp)) in - let in_typ = match destruct_exist env in_typ with Some (_,_,t) -> t | None -> in_typ in + let in_typ = match destruct_exist in_typ with Some (_,_,t) -> t | None -> in_typ in let autocast = (* Avoid using helper functions which simplify the nexps *) is_bitvector_typ in_typ && is_bitvector_typ out_typ && @@ -1528,7 +1528,7 @@ let doc_exp, doc_let = | P_aux (P_var (P_aux (P_typ (typ, P_aux (P_id id,_)),_),_),_) when not (is_enum (env_of e1) id) -> let full_typ = (expand_range_type typ) in - let binder = match destruct_exist (env_of e1) full_typ with + let binder = match destruct_exist (Env.expand_synonyms (env_of e1) full_typ) with | Some _ -> squote ^^ parens (separate space [string "existT"; underscore; doc_id id; underscore; colon; doc_typ ctxt typ]) | _ -> @@ -1975,7 +1975,7 @@ let doc_funcl (FCL_aux(FCL_Funcl(id, pexp), annot)) = | _ -> failwith ("Function " ^ string_of_id id ^ " does not have function type") in let build_ex, ret_typ = replace_atom_return_type ret_typ in - let build_ex = match destruct_exist env (expand_range_type ret_typ) with + let build_ex = match destruct_exist (Env.expand_synonyms env (expand_range_type ret_typ)) with | Some _ -> true | _ -> build_ex in @@ -2035,7 +2035,7 @@ let doc_funcl (FCL_aux(FCL_Funcl(id, pexp), annot)) = | P_typ (_,P_aux (P_id id,_)) when not (is_enum env id) -> begin let full_typ = (expand_range_type exp_typ) in - match destruct_exist env full_typ with + match destruct_exist (Env.expand_synonyms env full_typ) with | Some ([kid], NC_aux (NC_true,_), Typ_aux (Typ_app (Id_aux (Id "atom",_), [A_aux (A_nexp (Nexp_aux (Nexp_var kid',_)),_)]),_)) @@ -2255,7 +2255,7 @@ let doc_val pat exp = | None -> typpp, exp | Some typ -> let typ = expand_range_type (Env.expand_synonyms env typ) in - match destruct_exist env typ with + match destruct_exist typ with | None -> typpp, exp | Some _ -> empty, match exp with diff --git a/src/rewrites.ml b/src/rewrites.ml index d5601d08..d8f1af75 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -3729,7 +3729,7 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = in let exp4 = rewrite_var_updates (add_vars overwrite exp4 vars) in let ord_exp, kids, constr, lower, upper, lower_exp, upper_exp = - match destruct_numeric env (typ_of exp1), destruct_numeric env (typ_of exp2) with + match destruct_numeric (Env.expand_synonyms env (typ_of exp1)), destruct_numeric (Env.expand_synonyms env (typ_of exp2)) with | None, _ | _, None -> raise (Reporting.err_unreachable el __POS__ "Could not determine loop bounds") | Some (kids1, constr1, n1), Some (kids2, constr2, n2) -> diff --git a/src/type_check.ml b/src/type_check.ml index 42616361..459fe8d7 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -215,6 +215,52 @@ and strip_kinded_id_aux = function and strip_kind = function | K_aux (k_aux, _) -> K_aux (k_aux, Parse_ast.Unknown) +let ex_counter = ref 0 + +let fresh_existential ?name:(n="") () = + let fresh = Kid_aux (Var ("'ex" ^ string_of_int !ex_counter ^ "#" ^ n), Parse_ast.Unknown) in + incr ex_counter; fresh + +let destruct_exist' typ = + match typ with + | Typ_aux (Typ_exist (kids, nc, typ), _) -> + let fresh_kids = List.map (fun kid -> (kid, fresh_existential ~name:(string_of_id (id_of_kid kid)) ())) kids in + let nc = List.fold_left (fun nc (kid, fresh) -> constraint_subst kid (arg_nexp (nvar fresh)) nc) nc fresh_kids in + let typ = List.fold_left (fun typ (kid, fresh) -> typ_subst kid (arg_nexp (nvar fresh)) typ) typ fresh_kids in + Some (List.map snd fresh_kids, nc, typ) + | _ -> None + +(** Destructure and canonicalise a numeric type into a list of type + variables, a constraint on those type variables, and an + N-expression that represents that numeric type in the + environment. For example: + - {'n, 'n <= 10. atom('n)} => ['n], 'n <= 10, 'n + - int => ['n], true, 'n (where x is fresh) + - atom('n) => [], true, 'n +**) +let destruct_numeric typ = + match destruct_exist' typ, typ with + | Some (kids, nc, Typ_aux (Typ_app (id, [A_aux (A_nexp nexp, _)]), _)), _ when string_of_id id = "atom" -> + Some (kids, nc, nexp) + | None, Typ_aux (Typ_app (id, [A_aux (A_nexp nexp, _)]), _) when string_of_id id = "atom" -> + Some ([], nc_true, nexp) + | None, Typ_aux (Typ_app (id, [A_aux (A_nexp lo, _); A_aux (A_nexp hi, _)]), _) when string_of_id id = "range" -> + let kid = fresh_existential () in + Some ([kid], nc_and (nc_lteq lo (nvar kid)) (nc_lteq (nvar kid) hi), nvar kid) + | None, Typ_aux (Typ_id id, _) when string_of_id id = "nat" -> + let kid = fresh_existential () in + Some ([kid], nc_lteq (nint 0) (nvar kid), nvar kid) + | None, Typ_aux (Typ_id id, _) when string_of_id id = "int" -> + let kid = fresh_existential () in + Some ([kid], nc_true, nvar kid) + | _, _ -> None + +let destruct_exist typ = + match destruct_numeric typ with + | Some (kids, nc, nexp) -> Some (kids, nc, atom_typ nexp) + | None -> destruct_exist' typ + + let adding = Util.("Adding " |> darkgray |> clear) (**************************************************************************) @@ -244,6 +290,7 @@ module Env : sig val get_variant : id -> t -> typquant * type_union list val add_mapping : id -> typquant * typ * typ -> t -> t val add_union_id : id -> typquant * typ -> t -> t + val get_union_id : id -> t -> typquant * typ val add_flow : id -> (typ -> typ) -> t -> t val get_flow : id -> t -> typ -> typ val remove_flow : id -> t -> t @@ -286,11 +333,7 @@ module Env : sig val fresh_kid : ?kid:kid -> t -> kid val expand_synonyms : t -> typ -> typ val expand_constraint_synonyms : t -> n_constraint -> n_constraint - val canonicalize : t -> typ -> typ val base_typ_of : t -> typ -> typ - val add_smt_op : id -> string -> t -> t - val get_smt_op : id -> t -> string - val have_smt_op : id -> t -> bool val allow_unknowns : t -> bool val set_allow_unknowns : bool -> t -> t @@ -332,7 +375,6 @@ end = struct records : (typquant * (typ * id) list) Bindings.t; accessors : (typquant * typ) Bindings.t; externs : (string -> string option) Bindings.t; - smt_ops : string Bindings.t; casts : id list; allow_casts : bool; allow_bindings : bool; @@ -361,7 +403,6 @@ end = struct records = Bindings.empty; accessors = Bindings.empty; externs = Bindings.empty; - smt_ops = Bindings.empty; casts = []; allow_bindings = true; allow_casts = true; @@ -434,21 +475,6 @@ end = struct let existing = try Bindings.find id env.overloads with Not_found -> [] in { env with overloads = Bindings.add id (existing @ ids) env.overloads } - let add_smt_op id str env = - typ_print (lazy (adding ^ "smt binding " ^ string_of_id id ^ " to " ^ str)); - { env with smt_ops = Bindings.add id str env.smt_ops } - - let get_smt_op (Id_aux (_, l) as id) env = - let rec first_smt_op = function - | id :: ids -> (try Bindings.find id env.smt_ops with Not_found -> first_smt_op ids) - | [] -> typ_error l ("No SMT op for " ^ string_of_id id) - in - try Bindings.find id env.smt_ops with - | Not_found -> first_smt_op (get_overloads id env) - - let have_smt_op id env = - try ignore(get_smt_op id env); true with Type_error _ -> false - let rec infer_kind env id = if Bindings.mem id builtin_typs then Bindings.find id builtin_typs @@ -566,53 +592,6 @@ end = struct | A_order _ | A_typ _ | A_bool _ -> arg | A_nexp n -> A_aux (A_nexp (f n), l) - let canonical env typ = - let typ = expand_synonyms env typ in - let counter = ref 0 in - let complex_nexps = ref KBindings.empty in - let simplify_nexp (Nexp_aux (nexp_aux, l) as nexp) = - match nexp_aux with - | Nexp_constant _ -> nexp (* Check this ? *) - | _ -> - let kid = Kid_aux (Var ("'c#" ^ string_of_int !counter), l) in - complex_nexps := KBindings.add kid nexp !complex_nexps; - incr counter; - Nexp_aux (Nexp_var kid, l) - in - let typ = map_nexps (fun nexp -> simplify_nexp (nexp_simp nexp)) typ in - let existentials = KBindings.bindings !complex_nexps |> List.map fst in - let constrs = List.fold_left (fun ncs (kid, nexp) -> nc_eq (nvar kid) nexp :: ncs) [] (KBindings.bindings !complex_nexps) in - existentials, constrs, typ - - let is_canonical env typ = - let typ = expand_synonyms env typ in - let counter = ref 0 in - let simplify_nexp (Nexp_aux (nexp_aux, l) as nexp) = - match nexp_aux with - | Nexp_constant _ -> nexp - | _ -> (incr counter; nexp) - in - let typ = map_nexps simplify_nexp typ in - not (!counter > 0) - - let rec canonicalize env typ = - match typ with - | Typ_aux (Typ_fn (arg_typs, ret_typ, effects), l) when List.for_all (is_canonical env) arg_typs -> - Typ_aux (Typ_fn (arg_typs, canonicalize env ret_typ, effects), l) - | Typ_aux (Typ_fn _, l) -> typ_error l ("Function type " ^ string_of_typ typ ^ " is not canonical") - | _ -> - let existentials, constrs, (Typ_aux (typ_aux, l) as typ) = canonical env typ in - if existentials = [] then - typ - else - let typ_aux = match typ_aux with - | Typ_tup _ | Typ_app _ -> Typ_exist (existentials, List.fold_left nc_and (List.hd constrs) (List.tl constrs), typ) - | Typ_exist (kids, nc, typ) -> Typ_exist (kids @ existentials, List.fold_left nc_and nc constrs, typ) - | Typ_fn _ | Typ_bidir _ | Typ_id _ | Typ_var _ -> assert false (* These must be simple *) - | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" - in - Typ_aux (typ_aux, l) - (* Check if a type, order, n-expression or constraint is well-formed. Throws a type error if the type is badly formed. *) let rec wf_typ ?exs:(exs=KidSet.empty) env typ = @@ -667,7 +646,6 @@ end = struct end | Nexp_constant _ -> () | Nexp_app (id, nexps) -> - let _ = get_smt_op id env in List.iter (fun n -> wf_nexp ~exs:exs env n) nexps | Nexp_times (nexp1, nexp2) -> wf_nexp ~exs:exs env nexp1; wf_nexp ~exs:exs env nexp2 | Nexp_sum (nexp1, nexp2) -> wf_nexp ~exs:exs env nexp1; wf_nexp ~exs:exs env nexp2 @@ -746,20 +724,6 @@ end = struct let ex_counter = ref 0 - (* TODO: Currently this is duplicated with destruct_exist outside of Env and deals with val spec arguments only. *) - let fresh_existential ?name:(n="") () = - let fresh = Kid_aux (Var ("'all" ^ string_of_int !ex_counter ^ "#" ^ n), Parse_ast.Unknown) in - incr ex_counter; fresh - - let destruct_exist env typ = - match expand_synonyms env typ with - | Typ_aux (Typ_exist (kids, nc, typ), _) -> - let fresh_kids = List.map (fun kid -> (kid, fresh_existential ~name:(string_of_id (id_of_kid kid)) ())) kids in - let nc = List.fold_left (fun nc (kid, fresh) -> constraint_subst kid (arg_nexp (nvar fresh)) nc) nc fresh_kids in - let typ = List.fold_left (fun typ (kid, fresh) -> typ_subst kid (arg_nexp (nvar fresh)) typ) typ fresh_kids in - Some (List.map snd fresh_kids, nc, typ) - | _ -> None - let rec update_val_spec id (typq, typ) env = begin match expand_synonyms env typ with | Typ_aux (Typ_fn (arg_typs, ret_typ, effect), l) -> @@ -769,7 +733,7 @@ end = struct forall 'n, 'n >= 2. (int('n), foo) -> bar this enforces the invariant that all things on the left of functions are 'base types' (i.e. without existentials) *) - let base_args = List.map (destruct_exist env) arg_typs in + let base_args = List.map (fun typ -> destruct_exist (expand_synonyms env typ)) arg_typs in let existential_arg typq = function | None -> typq | Some (exs, nc, _) -> @@ -959,10 +923,15 @@ end = struct | None -> typ_error (id_loc id) ("union " ^ string_of_id id ^ " not found") let add_union_id id bind env = - begin - typ_print (lazy (adding ^ "union identifier " ^ string_of_id id ^ " : " ^ string_of_bind bind)); - { env with union_ids = Bindings.add id bind env.union_ids } - end + typ_print (lazy (adding ^ "union identifier " ^ string_of_id id ^ " : " ^ string_of_bind bind)); + { env with union_ids = Bindings.add id bind env.union_ids } + + let get_union_id id env = + try + let bind = Bindings.find id env.union_ids in + List.fold_left (fun bind (kid, _) -> freshen_kid env kid bind) bind (KBindings.bindings env.typ_vars) + with + | Not_found -> typ_error (id_loc id) ("No union constructor found for " ^ string_of_id id) let get_flow id env = try Bindings.find id env.flow with @@ -1156,21 +1125,6 @@ let default_order_error_string = let dvector_typ env n typ = vector_typ n (Env.get_default_order env) typ -let ex_counter = ref 0 - -let fresh_existential ?name:(n="") () = - let fresh = Kid_aux (Var ("'ex" ^ string_of_int !ex_counter ^ "#" ^ n), Parse_ast.Unknown) in - incr ex_counter; fresh - -let destruct_exist env typ = - match Env.expand_synonyms env typ with - | Typ_aux (Typ_exist (kids, nc, typ), _) -> - let fresh_kids = List.map (fun kid -> (kid, fresh_existential ~name:(string_of_id (id_of_kid kid)) ())) kids in - let nc = List.fold_left (fun nc (kid, fresh) -> constraint_subst kid (arg_nexp (nvar fresh)) nc) nc fresh_kids in - let typ = List.fold_left (fun typ (kid, fresh) -> typ_subst kid (arg_nexp (nvar fresh)) typ) typ fresh_kids in - Some (List.map snd fresh_kids, nc, typ) - | _ -> None - let add_existential l kids nc env = let env = List.fold_left (fun env kid -> Env.add_typ_var l kid K_int env) env kids in Env.add_constraint nc env @@ -1185,34 +1139,8 @@ let exist_typ constr typ = let fresh_kid = fresh_existential () in mk_typ (Typ_exist ([fresh_kid], constr fresh_kid, typ fresh_kid)) -(** Destructure and canonicalise a numeric type into a list of type - variables, a constraint on those type variables, and an - N-expression that represents that numeric type in the - environment. For example: - - {'n, 'n <= 10. atom('n)} => ['n], 'n <= 10, 'n - - int => ['n], true, 'n (where x is fresh) - - atom('n) => [], true, 'n -**) -let destruct_numeric env typ = - let typ = Env.expand_synonyms env typ in - match destruct_exist env typ, typ with - | Some (kids, nc, Typ_aux (Typ_app (id, [A_aux (A_nexp nexp, _)]), _)), _ when string_of_id id = "atom" -> - Some (kids, nc, nexp) - | None, Typ_aux (Typ_app (id, [A_aux (A_nexp nexp, _)]), _) when string_of_id id = "atom" -> - Some ([], nc_true, nexp) - | None, Typ_aux (Typ_app (id, [A_aux (A_nexp lo, _); A_aux (A_nexp hi, _)]), _) when string_of_id id = "range" -> - let kid = fresh_existential () in - Some ([kid], nc_and (nc_lteq lo (nvar kid)) (nc_lteq (nvar kid) hi), nvar kid) - | None, Typ_aux (Typ_id id, _) when string_of_id id = "nat" -> - let kid = fresh_existential () in - Some ([kid], nc_lteq (nint 0) (nvar kid), nvar kid) - | None, Typ_aux (Typ_id id, _) when string_of_id id = "int" -> - let kid = fresh_existential () in - Some ([kid], nc_true, nvar kid) - | _, _ -> None - let bind_numeric l typ env = - match destruct_numeric env typ with + match destruct_numeric (Env.expand_synonyms env typ) with | Some (kids, nc, nexp) -> nexp, add_existential l kids nc env | None -> typ_error l ("Expected " ^ string_of_typ typ ^ " to be numeric") @@ -1220,15 +1148,13 @@ let bind_numeric l typ env = (** Pull an (potentially)-existentially qualified type into the global typing environment **) let bind_existential l typ env = - match destruct_numeric env typ with - | Some (kids, nc, nexp) -> atom_typ nexp, add_existential l kids nc env - | None -> match destruct_exist env typ with - | Some (kids, nc, typ) -> typ, add_existential l kids nc env - | None -> typ, env + match destruct_exist (Env.expand_synonyms env typ) with + | Some (kids, nc, typ) -> typ, add_existential l kids nc env + | None -> typ, env let destruct_range env typ = let kids, constr, (Typ_aux (typ_aux, _)) = - Util.option_default ([], nc_true, typ) (destruct_exist env typ) + Util.option_default ([], nc_true, typ) (destruct_exist (Env.expand_synonyms env typ)) in match typ_aux with | Typ_app (f, [A_aux (A_nexp n, _)]) @@ -1492,7 +1418,7 @@ let rec unify_typ l env goals (Typ_aux (aux1, _) as typ1) (Typ_aux (aux2, _) as | Typ_internal_unknown, _ | _, Typ_internal_unknown when Env.allow_unknowns env -> KBindings.empty - + | Typ_var v, _ when KidSet.mem v goals -> KBindings.singleton v (arg_typ typ2) | Typ_app (range, [A_aux (A_nexp n1, _); A_aux (A_nexp n2, _)]), @@ -1528,7 +1454,8 @@ and unify_order l goals (Ord_aux (aux1, _) as ord1) (Ord_aux (aux2, _) as ord2) | _, _ -> unify_error l ("Cound not unify " ^ string_of_order ord1 ^ " and " ^ string_of_order ord2) and unify_nexp l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (nexp_aux2, _) as nexp2) = - typ_debug (lazy ("UNIFYING NEXPS " ^ string_of_nexp nexp1 ^ " AND " ^ string_of_nexp nexp2 ^ " FOR GOALS " ^ string_of_list ", " string_of_kid (KidSet.elements goals))); + typ_debug (lazy (Util.("Unify nexp " |> magenta |> clear) ^ string_of_nexp nexp1 ^ " and " ^ string_of_nexp nexp2 + ^ " goals " ^ string_of_list ", " string_of_kid (KidSet.elements goals))); if KidSet.is_empty (KidSet.inter (nexp_frees nexp1) goals) then begin @@ -1559,19 +1486,17 @@ and unify_nexp l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (nexp_au then unify_nexp l env goals n1a (nsum nexp2 n1b) else unify_error l ("Cannot unify minus Int expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) | Nexp_times (n1a, n1b) -> - (* If we have SMT operations div and mod, then we can use the + (* f we have SMT operations div and mod, then we can use the property that mod(m, C) = 0 && C != 0 --> (C * n = m <--> n = m / C) - to help us unify multiplications. *) - if Env.have_smt_op (mk_id "div") env && Env.have_smt_op (mk_id "mod") env then - let valid n c = prove env (nc_eq (napp (mk_id "mod") [n; c]) (nint 0)) && prove env (nc_neq c (nint 0)) in - if KidSet.is_empty (nexp_frees n1b) && valid nexp2 n1b then - unify_nexp l env goals n1a (napp (mk_id "div") [nexp2; n1b]) - else if KidSet.is_empty (nexp_frees n1a) && valid nexp2 n1a then - unify_nexp l env goals n1b (napp (mk_id "div") [nexp2; n1a]) - else unify_error l ("Cannot unify Int expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) + to help us unify multiplications and divisions. *) + let valid n c = prove env (nc_eq (napp (mk_id "mod") [n; c]) (nint 0)) && prove env (nc_neq c (nint 0)) in + if KidSet.is_empty (nexp_frees n1b) && valid nexp2 n1b then + unify_nexp l env goals n1a (napp (mk_id "div") [nexp2; n1b]) + else if KidSet.is_empty (nexp_frees n1a) && valid nexp2 n1a then + unify_nexp l env goals n1b (napp (mk_id "div") [nexp2; n1a]) else if KidSet.is_empty (nexp_frees n1a) then begin match nexp_aux2 with @@ -1611,7 +1536,7 @@ let subst_unifiers unifiers typ = let subst_unifiers_typ_arg unifiers typ_arg = List.fold_left (fun typ_arg (v, arg) -> typ_arg_subst v arg typ_arg) typ_arg (KBindings.bindings unifiers) - + let instantiate_quant (v, arg) (QI_aux (aux, l) as qi) = match aux with | QI_id kopt when Kid.compare (kopt_kid kopt) v = 0 -> @@ -1716,7 +1641,7 @@ let rec alpha_equivalent env typ1 typ2 = else (typ_debug (lazy "Not alpha-equivalent"); false) let unwrap_exist env typ = - match destruct_exist env typ with + match destruct_exist (Env.expand_synonyms env typ) with | Some (kids, nc, typ) -> (kids, nc, typ) | None -> ([], nc_true, typ) @@ -1725,13 +1650,51 @@ let unifier_constraint env (v, arg) = | A_aux (A_nexp nexp, _) -> Env.add_constraint (nc_eq (nvar v) nexp) env | _ -> env -let rec subtyp l env (Typ_aux (typ_aux1, _) as typ1) (Typ_aux (typ_aux2, _) as typ2) = +let canonicalize env typ = + let typ = Env.expand_synonyms env typ in + let rec canon (Typ_aux (aux, l)) = + match aux with + | Typ_var v -> Typ_aux (Typ_var v, l) + | Typ_internal_unknown -> Typ_aux (Typ_internal_unknown, l) + | Typ_id id when string_of_id id = "int" -> + exist_typ (fun _ -> nc_true) (fun v -> atom_typ (nvar v)) + | Typ_id id -> Typ_aux (Typ_id id, l) + | Typ_app (id, [A_aux (A_nexp lo, _); A_aux (A_nexp hi, _)]) when string_of_id id = "range" -> + exist_typ (fun v -> nc_and (nc_lteq lo (nvar v)) (nc_lteq (nvar v) hi)) (fun v -> atom_typ (nvar v)) + | Typ_app (id, args) -> + Typ_aux (Typ_app (id, List.map canon_arg args), l) + | Typ_tup typs -> + let typs = List.map canon typs in + let fold_exist (kids, nc, typs) typ = + match destruct_exist typ with + | Some (kids', nc', typ') -> (kids @ kids', nc_and nc nc', typs @ [typ']) + | None -> (kids, nc, typs @ [typ]) + in + let kids, nc, typs = List.fold_left fold_exist ([], nc_true, []) typs in + if kids = [] then + Typ_aux (Typ_tup typs, l) + else + Typ_aux (Typ_exist (kids, nc, Typ_aux (Typ_tup typs, l)), l) + | Typ_exist (kids, nc, typ) -> + begin match destruct_exist (canon typ) with + | Some (kids', nc', typ') -> + Typ_aux (Typ_exist (kids @ kids', nc_and nc nc', typ'), l) + | None -> Typ_aux (Typ_exist (kids, nc, typ), l) + end + | Typ_fn _ | Typ_bidir _ -> raise (Reporting.err_unreachable l __POS__ "Function type passed to Type_check.canonicalize") + and canon_arg (A_aux (aux, l)) = + A_aux ((match aux with + | A_typ typ -> A_typ (canon typ) + | arg -> arg), + l) + in + canon typ + +let rec subtyp l env typ1 typ2 = + let (Typ_aux (typ_aux1, _) as typ1) = Env.expand_synonyms env typ1 in + let (Typ_aux (typ_aux2, _) as typ2) = Env.expand_synonyms env typ2 in typ_print (lazy (("Subtype " |> Util.green |> Util.clear) ^ string_of_typ typ1 ^ " and " ^ string_of_typ typ2)); - match typ_aux1, typ_aux2 with - | Typ_tup typs1, Typ_tup typs2 when List.length typs1 = List.length typs2 -> - List.iter2 (subtyp l env) typs1 typs2 - | _, _ -> - match destruct_numeric env typ1, destruct_numeric env typ2 with + match destruct_numeric typ1, destruct_numeric typ2 with (* Ensure alpha equivalent types are always subtypes of one another - this ensures that we can always re-check inferred types. *) | _, _ when alpha_equivalent env typ1 typ2 -> () @@ -1743,27 +1706,50 @@ let rec subtyp l env (Typ_aux (typ_aux1, _) as typ1) (Typ_aux (typ_aux2, _) as t let env = add_existential l kids1 nc1 env in let env = add_typ_vars l (KidSet.elements (KidSet.inter (nexp_frees nexp2) (KidSet.of_list kids2))) env in let kids2 = KidSet.elements (KidSet.diff (KidSet.of_list kids2) (nexp_frees nexp2)) in - if not (kids2 = []) then typ_error l "Universally quantified constraint generated" else (); + if not (kids2 = []) then typ_error l ("Universally quantified constraint generated: " ^ Util.string_of_list ", " string_of_kid kids2) else (); let env = Env.add_constraint (nc_eq nexp1 nexp2) env in if prove env nc2 then () else typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env)) | _, _ -> - match destruct_exist env typ1, unwrap_exist env (Env.canonicalize env typ2) with + match destruct_exist' typ1, destruct_exist (canonicalize env typ2) with | Some (kids, nc, typ1), _ -> let env = add_existential l kids nc env in subtyp l env typ1 typ2 - | None, (kids, nc, typ2) -> + | None, Some (kids, nc, typ2) -> typ_debug (lazy "Subtype check with unification"); + let typ1 = canonicalize env typ1 in let env = add_typ_vars l kids env in let kids' = KidSet.elements (KidSet.diff (KidSet.of_list kids) (typ_frees typ2)) in if not (kids' = []) then typ_error l "Universally quantified constraint generated" else (); let unifiers = - try unify l env (tyvars_of_typ typ2) typ2 typ1 with + try unify l env (KidSet.diff (tyvars_of_typ typ2) (tyvars_of_typ typ1)) typ2 typ1 with | Unification_error (_, m) -> typ_error l m in let nc = List.fold_left (fun nc (kid, uvar) -> constraint_subst kid uvar nc) nc (KBindings.bindings unifiers) in let env = List.fold_left unifier_constraint env (KBindings.bindings unifiers) in if prove env nc then () else typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env)) + | None, None -> + match typ_aux1, typ_aux2 with + | Typ_tup typs1, Typ_tup typs2 when List.length typs1 = List.length typs2 -> + List.iter2 (subtyp l env) typs1 typs2 + + | Typ_app (id1, args1), Typ_app (id2, args2) when Id.compare id1 id2 = 0 && List.length args1 = List.length args2 -> + List.iter2 (subtyp_arg l env) args1 args2 + + | Typ_id id1, Typ_id id2 when Id.compare id1 id2 = 0 -> () + | Typ_id id1, Typ_app (id2, []) when Id.compare id1 id2 = 0 -> () + | Typ_app (id1, []), Typ_id id2 when Id.compare id1 id2 = 0 -> () + + | _, _ -> typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env)) + +and subtyp_arg l env (A_aux (aux1, _) as arg1) (A_aux (aux2, _) as arg2) = + typ_print (lazy (("Subtype arg " |> Util.green |> Util.clear) ^ string_of_typ_arg arg1 ^ " and " ^ string_of_typ_arg arg2)); + match aux1, aux2 with + | A_nexp n1, A_nexp n2 when prove env (nc_eq n1 n2) -> () + | A_typ typ1, A_typ typ2 -> subtyp l env typ1 typ2 + | A_order ord1, A_order ord2 when ord_identical ord1 ord2 -> () + | A_bool nc1, A_bool nc2 -> assert false + | _, _ -> typ_error l "Mismatched argument types in subtype check" let typ_equality l env typ1 typ2 = subtyp l env typ1 typ2; subtyp l env typ2 typ1 @@ -1928,6 +1914,38 @@ let expected_typ_of (l, tannot) = match tannot with (* Flow typing *) +type simple_numeric = + | Equal of nexp + | Constraint of (kid -> n_constraint) + | Anything + +let to_simple_numeric l kids nc (Nexp_aux (aux, _) as n) = + match aux, kids with + | Nexp_var v, [v'] when Kid.compare v v' = 0 -> + Constraint (fun subst -> constraint_subst v (arg_nexp (nvar subst)) nc) + | _, [] -> + Equal n + | _ -> + typ_error l "Numeric type is non-simple" + +let union_simple_numeric ex1 ex2 = + match ex1, ex2 with + | Equal nexp1, Equal nexp2 -> + Constraint (fun kid -> nc_or (nc_eq (nvar kid) nexp1) (nc_eq (nvar kid) nexp2)) + + | Equal nexp, Constraint c -> + Constraint (fun kid -> nc_or (nc_eq (nvar kid) nexp) (c kid)) + + | Constraint c, Equal nexp -> + Constraint (fun kid -> nc_or (c kid) (nc_eq (nvar kid) nexp)) + + | _, _ -> Anything + +let typ_of_simple_numeric = function + | Anything -> int_typ + | Equal nexp -> atom_typ nexp + | Constraint c -> exist_typ c (fun kid -> atom_typ (nvar kid)) + let rec big_int_of_nexp (Nexp_aux (nexp, _)) = match nexp with | Nexp_constant c -> Some c | Nexp_times (n1, n2) -> @@ -1977,17 +1995,17 @@ let rec assert_constraint env b (E_aux (exp_aux, _) as exp) = combine_constraint (not b) nc_or (assert_constraint env b x) (assert_constraint env b y) | E_app (op, [x; y]) when string_of_id op = "and_bool" -> combine_constraint b nc_and (assert_constraint env b x) (assert_constraint env b y) - | E_app (op, [x; y]) when string_of_id op = "gteq_atom" -> + | E_app (op, [x; y]) when string_of_id op = "gteq_int" -> option_binop nc_gteq (assert_nexp env x) (assert_nexp env y) - | E_app (op, [x; y]) when string_of_id op = "lteq_atom" -> + | E_app (op, [x; y]) when string_of_id op = "lteq_int" -> option_binop nc_lteq (assert_nexp env x) (assert_nexp env y) - | E_app (op, [x; y]) when string_of_id op = "gt_atom" -> + | E_app (op, [x; y]) when string_of_id op = "gt_int" -> option_binop nc_gt (assert_nexp env x) (assert_nexp env y) - | E_app (op, [x; y]) when string_of_id op = "lt_atom" -> + | E_app (op, [x; y]) when string_of_id op = "lt_int" -> option_binop nc_lt (assert_nexp env x) (assert_nexp env y) - | E_app (op, [x; y]) when string_of_id op = "eq_atom" -> + | E_app (op, [x; y]) when string_of_id op = "eq_int" -> option_binop nc_eq (assert_nexp env x) (assert_nexp env y) - | E_app (op, [x; y]) when string_of_id op = "neq_atom" -> + | E_app (op, [x; y]) when string_of_id op = "neq_int" -> option_binop nc_neq (assert_nexp env x) (assert_nexp env y) | _ -> None @@ -2398,13 +2416,13 @@ and type_coercion env (E_aux (_, (l, _)) as annotated_exp) typ = in begin try - typ_debug (lazy ("PERFORMING TYPE COERCION: from " ^ string_of_typ (typ_of annotated_exp) ^ " to " ^ string_of_typ typ)); + typ_debug (lazy ("Performing type coercion: from " ^ string_of_typ (typ_of annotated_exp) ^ " to " ^ string_of_typ typ)); subtyp l env (typ_of annotated_exp) typ; switch_exp_typ annotated_exp with | Type_error (_, trigger) when Env.allow_casts env -> let casts = filter_casts env (typ_of annotated_exp) typ (Env.get_casts env) in try_casts trigger [] casts - | Type_error (l, err) -> typ_error l "Subtype error" + | Type_error (l, err) -> typ_raise l err end (* type_coercion_unify env exp typ attempts to coerce exp to a type @@ -2434,7 +2452,7 @@ and type_coercion_unify env goals (E_aux (_, (l, _)) as annotated_exp) typ = in begin try - typ_debug (lazy "PERFORMING COERCING UNIFICATION"); + typ_debug (lazy ("Coercing unification: from " ^ string_of_typ (typ_of annotated_exp) ^ " to " ^ string_of_typ typ)); let atyp, env = bind_existential l (typ_of annotated_exp) env in annotated_exp, unify l env goals typ atyp, env with @@ -2548,7 +2566,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) end | P_app (f, pats) when Env.is_union_constructor f env -> begin - let (typq, ctor_typ) = Env.get_val_spec f env in + let (typq, ctor_typ) = Env.get_union_id f env in let quants = quant_items typq in let untuple (Typ_aux (typ_aux, _) as typ) = match typ_aux with | Typ_tup typs -> typs @@ -2563,8 +2581,8 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) let unifiers = unify l env goals ret_typ typ in let arg_typ' = subst_unifiers unifiers arg_typ in let quants' = List.fold_left instantiate_quants quants (KBindings.bindings unifiers) in - if (match quants' with [] -> false | _ -> true) - then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in pattern " ^ string_of_pat pat) + if not (List.for_all (solve_quant env) quants') then + typ_raise l (Err_unresolved_quants (f, quants', Env.get_locals env, Env.get_constraints env)) else (); let ret_typ' = subst_unifiers unifiers ret_typ in let tpats, env, guards = @@ -2580,7 +2598,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) | P_app (f, pats) when Env.is_mapping f env -> begin - let (typq, mapping_typ) = Env.get_val_spec f env in + let (typq, mapping_typ) = Env.get_union_id f env in let quants = quant_items typq in let untuple (Typ_aux (typ_aux, _) as typ) = match typ_aux with | Typ_tup typs -> typs @@ -3094,7 +3112,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = let inferred_f = irule infer_exp env f in let inferred_t = irule infer_exp env t in let checked_step = crule check_exp env step int_typ in - match destruct_numeric env (typ_of inferred_f), destruct_numeric env (typ_of inferred_t) with + match destruct_numeric (typ_of inferred_f), destruct_numeric (typ_of inferred_t) with | Some (kids1, nc1, nexp1), Some (kids2, nc2, nexp2) -> let loop_kid = mk_kid ("loop_" ^ string_of_id v) in let env = List.fold_left (fun env kid -> Env.add_typ_var l kid K_int env) env (loop_kid :: kids1 @ kids2) in @@ -3110,8 +3128,22 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = | E_if (cond, then_branch, else_branch) -> let cond' = crule check_exp env cond (mk_typ (Typ_id (mk_id "bool"))) in let then_branch' = irule infer_exp (add_opt_constraint (assert_constraint env true cond') env) then_branch in - let else_branch' = crule check_exp (add_opt_constraint (option_map nc_not (assert_constraint env false cond')) env) else_branch (typ_of then_branch') in - annot_exp (E_if (cond', then_branch', else_branch')) (typ_of then_branch') + (* We don't have generic type union in Sail, but we can union simple numeric types. *) + begin match destruct_numeric (Env.expand_synonyms env (typ_of then_branch')) with + | Some (kids, nc, then_nexp) -> + let then_sn = to_simple_numeric l kids nc then_nexp in + let else_branch' = irule infer_exp (add_opt_constraint (option_map nc_not (assert_constraint env false cond')) env) else_branch in + begin match destruct_numeric (Env.expand_synonyms env (typ_of else_branch')) with + | Some (kids, nc, else_nexp) -> + let else_sn = to_simple_numeric l kids nc else_nexp in + let typ = typ_of_simple_numeric (union_simple_numeric then_sn else_sn) in + annot_exp (E_if (cond', then_branch', else_branch')) typ + | None -> typ_error l ("Could not infer type of " ^ string_of_exp else_branch) + end + | None -> + let else_branch' = crule check_exp (add_opt_constraint (option_map nc_not (assert_constraint env false cond')) env) else_branch (typ_of then_branch') in + annot_exp (E_if (cond', then_branch', else_branch')) (typ_of then_branch') + end | E_vector_access (v, n) -> infer_exp env (E_aux (E_app (mk_id "vector_access", [v; n]), (l, ()))) | E_vector_update (v, n, exp) -> infer_exp env (E_aux (E_app (mk_id "vector_update", [v; n; exp]), (l, ()))) | E_vector_update_subrange (v, n, m, exp) -> infer_exp env (E_aux (E_app (mk_id "vector_update_subrange", [v; n; m; exp]), (l, ()))) @@ -4163,10 +4195,6 @@ let check_val_spec env (VS_aux (vs, (l, _))) = let vs, id, typq, typ, env = match vs with | VS_val_spec (TypSchm_aux (TypSchm_ts (typq, typ), ts_l) as typschm, id, ext_opt, is_cast) -> typ_print (lazy (Util.("Check val spec " |> cyan |> clear) ^ string_of_id id ^ " : " ^ string_of_typschm typschm)); - let env = match (ext_opt "smt", ext_opt "#") with - | Some op, None -> Env.add_smt_op id op env - | _, _ -> env - in let env = Env.add_extern id ext_opt env in let env = if is_cast then Env.add_cast id env else env in let typq, typ = diff --git a/src/type_check.mli b/src/type_check.mli index 52ade6fa..47b9d172 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -300,6 +300,8 @@ val prove : Env.t -> n_constraint -> bool val solve : Env.t -> nexp -> Big_int.num option +val canonicalize : Env.t -> typ -> typ + val subtype_check : Env.t -> typ -> typ -> bool val bind_pat : Env.t -> unit pat -> typ -> tannot pat * Env.t * unit Ast.exp list @@ -350,11 +352,11 @@ val destruct_atom_nexp : Env.t -> typ -> nexp option (** Safely destructure an existential type. Returns None if the type is not existential. This function will pick a fresh name for the existential to ensure that no name-clashes occur. *) -val destruct_exist : Env.t -> typ -> (kid list * n_constraint * typ) option +val destruct_exist : typ -> (kid list * n_constraint * typ) option val destruct_range : Env.t -> typ -> (kid list * n_constraint * nexp * nexp) option -val destruct_numeric : Env.t -> typ -> (kid list * n_constraint * nexp) option +val destruct_numeric : typ -> (kid list * n_constraint * nexp) option val destruct_vector : Env.t -> typ -> (nexp * order * typ) option -- cgit v1.2.3 From c0500a16891e57b2856e47a3c233cd0c1d247a70 Mon Sep 17 00:00:00 2001 From: Alasdair Date: Tue, 11 Dec 2018 01:12:50 +0000 Subject: Fix most remaining tests on branch --- src/specialize.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/specialize.ml b/src/specialize.ml index 0f5b939c..583de600 100644 --- a/src/specialize.ml +++ b/src/specialize.ml @@ -54,7 +54,7 @@ open Rewriter open Extra_pervasives let is_typ_ord_uvar = function - | A_aux (A_nexp _, _) -> true + | A_aux (A_typ _, _) -> true | A_aux (A_order _, _) -> true | _ -> false -- cgit v1.2.3 From 4f20163965e7c336f28740628fa9d64528006861 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Tue, 11 Dec 2018 11:54:36 +0000 Subject: Initial attempt at using termination measures in Coq This only applies to recursive functions and uses the termination measure merely as a limit to the recursive call depth, rather than proving the measure correct. --- src/initial_check.ml | 8 +- src/parse_ast.ml | 1 + src/parser.mly | 8 ++ src/pretty_print_coq.ml | 213 ++++++++++++++++++++++++++++++++++++++---------- src/rewriter.ml | 9 +- src/rewrites.ml | 10 ++- src/type_check.ml | 10 +++ 7 files changed, 208 insertions(+), 51 deletions(-) (limited to 'src') diff --git a/src/initial_check.ml b/src/initial_check.ml index b57e6b17..febcb3ff 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -533,10 +533,12 @@ let to_ast_kdef ctx (td:P.kind_def) : unit kind_def = let kind = to_ast_kind kind in KD_aux (KD_nabbrev (kind, id, to_ast_namescm name_scm_opt, to_ast_nexp ctx atyp), (l, ())) -let to_ast_rec (P.Rec_aux(r,l): P.rec_opt) : rec_opt = +let to_ast_rec ctx (P.Rec_aux(r,l): P.rec_opt) : unit rec_opt = Rec_aux((match r with | P.Rec_nonrec -> Rec_nonrec | P.Rec_rec -> Rec_rec + | P.Rec_measure (p,e) -> + Rec_measure (to_ast_pat ctx p, to_ast_exp ctx e) ),l) let to_ast_tannot_opt ctx (P.Typ_annot_opt_aux(tp,l)) : tannot_opt ctx_out = @@ -569,7 +571,7 @@ let to_ast_fundef ctx (P.FD_aux(fd,l):P.fundef) : unit fundef = match fd with | P.FD_function(rec_opt,tannot_opt,effects_opt,funcls) -> let tannot_opt, ctx = to_ast_tannot_opt ctx tannot_opt in - FD_aux(FD_function(to_ast_rec rec_opt, tannot_opt, to_ast_effects_opt effects_opt, List.map (to_ast_funcl ctx) funcls), (l,())) + FD_aux(FD_function(to_ast_rec ctx rec_opt, tannot_opt, to_ast_effects_opt effects_opt, List.map (to_ast_funcl ctx) funcls), (l,())) let rec to_ast_mpat ctx (P.MP_aux(mpat,l)) = MP_aux( @@ -643,7 +645,7 @@ let to_ast_scattered ctx (P.SD_aux (aux, l)) = | P.SD_function (rec_opt, tannot_opt, effect_opt, id) -> let tannot_opt, _ = to_ast_tannot_opt ctx tannot_opt in let effect_opt = to_ast_effects_opt effect_opt in - SD_function (to_ast_rec rec_opt, tannot_opt, effect_opt, to_ast_id id), ctx + SD_function (to_ast_rec ctx rec_opt, tannot_opt, effect_opt, to_ast_id id), ctx | P.SD_funcl funcl -> SD_funcl (to_ast_funcl ctx funcl), ctx | P.SD_variant (id, namescm_opt, typq) -> diff --git a/src/parse_ast.ml b/src/parse_ast.ml index 204389f9..744bd8b0 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -328,6 +328,7 @@ type rec_opt_aux = (* Optional recursive annotation for functions *) Rec_nonrec (* non-recursive *) | Rec_rec (* recursive *) + | Rec_measure of pat * exp (* recursive with termination measure *) type diff --git a/src/parser.mly b/src/parser.mly index bb5aa5f1..9385c148 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -125,6 +125,8 @@ let doc_vs doc (VS_aux (v, l)) = VS_aux (v, Documented (doc, l)) let qi_id_of_kopt (KOpt_aux (kopt_aux, l) as kopt) = QI_aux (QI_id kopt, l) +let mk_recr r n m = (Rec_aux(r, loc n m)) + let mk_recn = (Rec_aux((Rec_nonrec), Unknown)) let mk_typqn = (TypQ_aux(TypQ_no_forall,Unknown)) let mk_tannotn = Typ_annot_opt_aux(Typ_annot_opt_none,Unknown) @@ -1216,9 +1218,15 @@ type_unions: | type_union Comma type_unions { $1 :: $3 } +rec_measure: + | Lcurly pat EqGt exp Rcurly + { mk_recr (Rec_measure ($2, $4)) $startpos $endpos } + fun_def: | Function_ funcls { let funcls, tannot = $2 in mk_fun (FD_function (mk_recn, tannot, mk_eannotn, funcls)) $startpos $endpos } + | Function_ rec_measure funcls + { let funcls, tannot = $3 in mk_fun (FD_function ($2, tannot, mk_eannotn, funcls)) $startpos $endpos } fun_def_list: | fun_def diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 7cc61507..a851c5fa 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -71,6 +71,7 @@ type context = { kid_id_renames : id KBindings.t; (* tyvar -> argument renames *) bound_nvars : KidSet.t; build_ex_return : bool; + recursive_ids : IdSet.t; debug : bool; } let empty_ctxt = { @@ -79,6 +80,7 @@ let empty_ctxt = { kid_id_renames = KBindings.empty; bound_nvars = KidSet.empty; build_ex_return = false; + recursive_ids = IdSet.empty; debug = false; } @@ -605,7 +607,20 @@ let doc_quant_item_id ctx delimit (QI_aux (qi,_)) = | K_int -> Some (delimit (separate space [doc_var ctx kid; colon; string "Z"])) | K_order -> None end - | QI_id _ -> failwith "Quantifier with multiple kinds" + | QI_const nc -> None + +let quant_item_id_name ctx (QI_aux (qi,_)) = + match qi with + | QI_id (KOpt_aux (KOpt_none kid,_)) -> + if KBindings.mem kid ctx.kid_id_renames then None else + Some (doc_var ctx kid) + | QI_id (KOpt_aux (KOpt_kind (K_aux (kind,_),kid),_)) -> begin + if KBindings.mem kid ctx.kid_id_renames then None else + match kind with + | K_type -> Some (doc_var ctx kid) + | K_int -> Some (doc_var ctx kid) + | K_order -> None + end | QI_const nc -> None let doc_quant_item_constr ctx delimit (QI_aux (qi,_)) = @@ -613,6 +628,13 @@ let doc_quant_item_constr ctx delimit (QI_aux (qi,_)) = | QI_id _ -> None | QI_const nc -> Some (bquote ^^ braces (doc_arithfact ctx nc)) +(* At the moment these are all anonymous - when used we rely on Coq to fill + them in. *) +let quant_item_constr_name ctx (QI_aux (qi,_)) = + match qi with + | QI_id _ -> None + | QI_const nc -> Some underscore + let doc_typquant_items ctx delimit (TypQ_aux (tq,_)) = match tq with | TypQ_tq qis -> @@ -627,6 +649,14 @@ let doc_typquant_items_separate ctx delimit (TypQ_aux (tq,_)) = Util.map_filter (doc_quant_item_constr ctx delimit) qis | TypQ_no_forall -> [], [] +let typquant_names_separate ctx (TypQ_aux (tq,_)) = + match tq with + | TypQ_tq qis -> + Util.map_filter (quant_item_id_name ctx) qis, + Util.map_filter (quant_item_constr_name ctx) qis + | TypQ_no_forall -> [], [] + + let doc_typquant ctx (TypQ_aux(tq,_)) typ = match tq with | TypQ_tq ((_ :: _) as qs) -> string "forall " ^^ separate_opt space (doc_quant_item_id ctx braces) qs ^/^ @@ -1146,11 +1176,13 @@ let doc_exp, doc_let = | _ -> let env = env_of_annot (l,annot) in let () = debug ctxt (lazy ("Function application " ^ string_of_id f)) in - let call, is_extern, is_ctor = - if Env.is_union_constructor f env then doc_id_ctor f, false, true else + let call, is_extern, is_ctor, is_rec = + if Env.is_union_constructor f env then doc_id_ctor f, false, true, false else if Env.is_extern f env "coq" - then string (Env.get_extern f env "coq"), true, false - else doc_id f, false, false in + then string (Env.get_extern f env "coq"), true, false, false + else if IdSet.mem f ctxt.recursive_ids + then string "_rec_" ^^ doc_id f, false, false, true + else doc_id f, false, false, false in let (tqs,fn_ty) = Env.get_val_spec_orig f env in let arg_typs, ret_typ, eff = match fn_ty with | Typ_aux (Typ_fn (arg_typs,ret_typ,eff),_) -> arg_typs, ret_typ, eff @@ -1202,7 +1234,13 @@ let doc_exp, doc_let = let epp = if is_ctor then hang 2 (call ^^ break 1 ^^ parens (flow (comma ^^ break 1) (List.map2 (doc_arg false) args arg_typs))) - else hang 2 (flow (break 1) (call :: List.map2 (doc_arg true) args arg_typs)) in + else + let main_call = call :: List.map2 (doc_arg true) args arg_typs in + let all = if is_rec then main_call @ + [parens (string "_limit - 1"); + parens (string "Acc_inv _acc (_limit_is_limit _limit_ok)")] + else main_call + in hang 2 (flow (break 1) all) in (* Decide whether to unpack an existential result, pack one, or cast. To do this we compare the expected type stored in the checked expression @@ -1825,6 +1863,12 @@ let args_of_typ l env typs = E_aux (E_id id, (l, mk_tannot env typ no_effect)) in List.split (List.mapi arg typs) +(* Sail currently has a single pattern to match against a list of + argument types. We need to tweak everything to match up, + especially so that the function is presented in curried form. In + particular, if there's a single binder for multiple arguments + (which rewriting can currently introduce) then we need to turn it + into multiple binders and reconstruct it in the function body. *) let rec untuple_args_pat typs (P_aux (paux, ((l, _) as annot)) as pat) = let env = env_of_annot annot in let identity = (fun body -> body) in @@ -1848,10 +1892,6 @@ let rec untuple_args_pat typs (P_aux (paux, ((l, _) as annot)) as pat) = | _, _ -> unreachable l __POS__ "Unexpected pattern/type combination" -let doc_rec (Rec_aux(r,_)) = match r with - | Rec_nonrec -> string "Definition" - | Rec_rec -> string "Fixpoint" - let doc_fun_body ctxt exp = let doc_exp = doc_exp ctxt false exp in if ctxt.early_ret @@ -1870,6 +1910,28 @@ let demote_as_pattern i (P_aux (_,p_annot) as pat,typ) = E_aux (E_let (LB_aux (LB_val (pat, E_aux (E_id id, p_annot)),p_annot),e),e_ann) else (pat,typ), fun e -> e +let pat_is_plain_binder env (P_aux (p,_)) = + match p with + | P_id id + | P_typ (_,P_aux (P_id id,_)) + when not (is_enum env id) -> Some id + | _ -> None + +let demote_all_patterns env i (P_aux (p,p_annot) as pat,typ) = + match pat_is_plain_binder env pat with + | Some id -> + if Util.is_none (is_auto_decomposed_exist env typ) + then (pat,typ), fun e -> e + else + (P_aux (P_id id, p_annot),typ), + fun (E_aux (_,e_ann) as e) -> + E_aux (E_let (LB_aux (LB_val (pat, E_aux (E_id id, p_annot)),p_annot),e),e_ann) + | None -> + let id = mk_id ("arg" ^ string_of_int i) in (* TODO: name conflicts *) + (P_aux (P_id id, p_annot),typ), + fun (E_aux (_,e_ann) as e) -> + E_aux (E_let (LB_aux (LB_val (pat, E_aux (E_id id, p_annot)),p_annot),e),e_ann) + (* Add equality constraints between arguments and nexps, except in the case that they've been merged. *) @@ -1967,7 +2029,7 @@ let merge_var_patterns map pats = | _ -> map, (pat,typ)::pats) (map,[]) pats in map, List.rev pats -let doc_funcl (FCL_aux(FCL_Funcl(id, pexp), annot)) = +let doc_funcl rec_opt (FCL_aux(FCL_Funcl(id, pexp), annot)) = let env = env_of_annot annot in let (tq,typ) = Env.get_val_spec_orig id env in let (arg_typs, ret_typ, eff) = match typ with @@ -1982,17 +2044,31 @@ let doc_funcl (FCL_aux(FCL_Funcl(id, pexp), annot)) = let ids_to_avoid = all_ids pexp in let bound_kids = tyvars_of_typquant tq in let pat,guard,exp,(l,_) = destruct_pexp pexp in - let pats, bind = untuple_args_pat arg_typs pat in (* FIXME is this needed any more? *) - let pats, binds = List.split (Util.list_mapi demote_as_pattern pats) in + let pats, bind = untuple_args_pat arg_typs pat in + (* Fixpoint definitions can only use simple binders, but even Definitions + can't handle as patterns *) + let pattern_elim = + match rec_opt with + | Rec_aux (Rec_nonrec,_) -> demote_as_pattern + | _ -> demote_all_patterns env + in + let pats, binds = List.split (Util.list_mapi pattern_elim pats) in let eliminated_kids, kid_to_arg_rename = merge_kids_atoms pats in let kid_to_arg_rename, pats = merge_var_patterns kid_to_arg_rename pats in let kids_used = KidSet.diff bound_kids eliminated_kids in + let is_measured, recursive_ids = match rec_opt with + (* No mutual recursion in this backend yet; only change recursive + definitions where we have a measure *) + | Rec_aux (Rec_measure _,_) -> true, IdSet.singleton id + | _ -> false, IdSet.empty + in let ctxt = { early_ret = contains_early_return exp; kid_renames = mk_kid_renames ids_to_avoid kids_used; kid_id_renames = kid_to_arg_rename; bound_nvars = bound_kids; build_ex_return = effectful eff && build_ex; + recursive_ids = recursive_ids; debug = List.mem (string_of_id id) (!opt_debug_on) } in let () = @@ -2013,27 +2089,11 @@ let doc_funcl (FCL_aux(FCL_Funcl(id, pexp), annot)) = debug ctxt (lazy (" pattern " ^ string_of_pat pat)); debug ctxt (lazy (" with expanded type " ^ string_of_typ exp_typ)) in - match p with - | P_id id - | P_typ (_,P_aux (P_id id,_)) - when Util.is_none (is_auto_decomposed_exist env exp_typ) && - not (is_enum env id) -> - parens (separate space [doc_id id; colon; doc_typ ctxt typ]) -(* | P_id id - | P_typ (_,P_aux (P_id id,_)) - when not (is_enum env id) -> begin - match destruct_exist env (expand_range_type exp_typ) with - | Some (kids, NC_aux (NC_true,_), typ) -> - parens (separate space [doc_id id; colon; doc_typ ctxt typ]) - | Some (kids, nc, typ) -> - parens (separate space [doc_id id; colon; doc_typ ctxt typ]) ^^ space ^^ - bquote ^^ braces (doc_arithfact ctxt nc) - | None -> - parens (separate space [doc_id id; colon; doc_typ ctxt typ]) - end*) - | P_id id - | P_typ (_,P_aux (P_id id,_)) - when not (is_enum env id) -> begin + match pat_is_plain_binder env pat with + | Some id -> + if Util.is_none (is_auto_decomposed_exist env exp_typ) then + parens (separate space [doc_id id; colon; doc_typ ctxt typ]) + else begin let full_typ = (expand_range_type exp_typ) in match destruct_exist env full_typ with | Some ([kid], NC_aux (NC_true,_), @@ -2044,17 +2104,17 @@ let doc_funcl (FCL_aux(FCL_Funcl(id, pexp), annot)) = | Some ([kid], nc, Typ_aux (Typ_app (Id_aux (Id "atom",_), [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid',_)),_)]),_)) - when Kid.compare kid kid' == 0 -> + when Kid.compare kid kid' == 0 && not is_measured -> (used_a_pattern := true; squote ^^ parens (separate space [string "existT"; underscore; doc_id id; underscore; colon; doc_typ ctxt typ])) | _ -> parens (separate space [doc_id id; colon; doc_typ ctxt typ]) end - | _ -> + | None -> (used_a_pattern := true; squote ^^ parens (separate space [doc_pat ctxt true true (pat, exp_typ); colon; doc_typ ctxt typ])) in - let patspp = separate_map space doc_binder pats in + let patspp = flow_map (break 1) doc_binder pats in let atom_constrs = Util.map_filter (atom_constraint ctxt) pats in let atom_constr_pp = separate space atom_constrs in let retpp = @@ -2062,7 +2122,67 @@ let doc_funcl (FCL_aux(FCL_Funcl(id, pexp), annot)) = then string "M" ^^ space ^^ parens (doc_typ ctxt ret_typ) else doc_typ ctxt ret_typ in - let idpp = doc_id id in + let intropp, idpp, accpp, measurepp, fixupspp, postpp = match rec_opt with + | Rec_aux (Rec_measure (meas_pat,meas_exp),_) -> + let check_ids (arg_pat,_) m_pat = + match arg_pat, m_pat with + | P_aux ((P_id arg_id | P_typ (_,P_aux (P_id arg_id,_))),_), + P_aux ((P_id m_id | P_typ (_,P_aux (P_id m_id,_))),_) -> + if Id.compare arg_id m_id == 0 then () else + failwith "TODO" + | _, P_aux (P_wild,_) -> () (* TODO generalise *) + | _ -> failwith "TODO" + in + let idpp = doc_id id in + let recidpp = string "_rec_" ^^ idpp in + let patnames = List.map (function + | P_aux (P_id id,_), _ -> doc_id id + | P_aux (P_typ (_,P_aux (P_id id,_)),_), _ -> doc_id id + | p,_ -> raise (Reporting.err_unreachable (pat_loc p) __POS__ + "Pattern has not been reduced to a simple binder")) + pats in + let quantnames, constrnames = typquant_names_separate ctxt tq in + let atomconstrsnames = List.map (fun _ -> underscore) atom_constrs in + let fixupspp = Util.map_filter (fun (pat,typ) -> + match pat_is_plain_binder env pat with + | Some id -> begin + match destruct_exist env (expand_range_type typ) with + | Some (_, NC_aux (NC_true,_), _) -> None + | Some ([kid], nc, + Typ_aux (Typ_app (Id_aux (Id "atom",_), + [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid',_)),_)]),_)) + when Kid.compare kid kid' == 0 -> + Some (string "let " ^^ doc_id id ^^ string " := projT1 " ^^ doc_id id ^^ string " in") + | _ -> None + end + | None -> None) pats + in + let no_fixups = match fixupspp with [] -> true | _ -> false in + let measure_pp = + match pats, meas_pat with + | _, P_aux (P_tup ps,_) when List.length pats = List.length ps -> + let () = List.iter2 check_ids pats ps in + doc_exp ctxt no_fixups meas_exp + | [pat], _ -> + let () = check_ids pat meas_pat in + doc_exp ctxt no_fixups meas_exp + | _, _ -> failwith "TODO" + in + let measure_pp = match fixupspp with + [] -> measure_pp + | _ -> parens (flow (break 1) fixupspp ^/^ measure_pp) + in + string "Fixpoint", + recidpp, + [parens (string "_limit : Z"); + parens (string "_acc : Acc (Zwf 0) _limit")], + [string "{struct _acc}"], + fixupspp, + hardline ^^ string "Definition " ^^ idpp ^/^ flow (break 1) (quantspp @ patspp :: constrspp @ atom_constrs) ^/^ coloneq ^/^ recidpp ^/^ flow (break 1) (quantnames @ patnames @ constrnames @ atomconstrsnames) ^/^ measure_pp ^/^ string "(Zwf_well_founded _ _)." + | Rec_aux (r,_) -> + let d = match r with Rec_nonrec -> "Definition" | _ -> "Fixpoint" in + string d, doc_id id, [], [], [], empty + in (* Work around Coq bug 7975 about pattern binders followed by implicit arguments *) let implicitargs = if !used_a_pattern && List.length constrspp + List.length atom_constrs > 0 then @@ -2082,10 +2202,17 @@ let doc_funcl (FCL_aux(FCL_Funcl(id, pexp), annot)) = "guarded pattern expression should have been rewritten before pretty-printing") in let bodypp = doc_fun_body ctxt exp in let bodypp = if effectful eff || not build_ex then bodypp else string "build_ex" ^^ parens bodypp in + let bodypp = match rec_opt with + | Rec_aux (Rec_measure _,_) -> + string "assert_exp' (_limit >? 0) \"termination limit reached\" >>= fun _limit_ok =>" ^/^ + separate (break 1) fixupspp ^/^ + bodypp + | _ -> bodypp + in group (prefix 3 1 - (separate space ([idpp] @ quantspp @ [patspp] @ constrspp @ [atom_constr_pp]) ^/^ - separate space [colon; retpp; coloneq]) - (bodypp ^^ dot)) ^^ implicitargs + (flow (break 1) ([intropp; idpp] @ quantspp @ [patspp] @ constrspp @ [atom_constr_pp] @ accpp) ^/^ + flow (break 1) (measurepp @ [colon; retpp; coloneq])) + (bodypp ^^ dot)) ^^ postpp ^^ implicitargs let get_id = function | [] -> failwith "FD_function with empty list" @@ -2095,7 +2222,7 @@ let get_id = function joined by "and", although it has worked for Isabelle before. However, all the funcls should have been merged by the merge_funcls rewrite now. *) let doc_fundef_rhs (FD_aux(FD_function(r, typa, efa, funcls),fannot)) = - separate_map (hardline ^^ string "and ") doc_funcl funcls + separate_map (hardline ^^ string "and ") (doc_funcl r) funcls let doc_mutrec = function | [] -> failwith "DEF_internal_mutrec with empty function list" @@ -2108,7 +2235,7 @@ let rec doc_fundef (FD_aux(FD_function(r, typa, efa, fcls),fannot)) = | [] -> failwith "FD_function with empty function list" | [FCL_aux (FCL_Funcl(id,_),annot) as funcl] when not (Env.is_extern id (env_of_annot annot) "coq") -> - (doc_rec r) ^^ space ^^ (doc_funcl funcl) + doc_funcl r funcl | [_] -> empty (* extern *) | _ -> failwith "FD_function with more than one clause" diff --git a/src/rewriter.ml b/src/rewriter.ml index 77070025..5907c603 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -346,7 +346,14 @@ let rewrite_lexp rewriters (LEXP_aux(lexp,(l,annot))) = let rewrite_fun rewriters (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),(l,fdannot))) = let rewrite_funcl (FCL_aux (FCL_Funcl(id,pexp),(l,annot))) = (FCL_aux (FCL_Funcl (id, rewrite_pexp rewriters pexp),(l,annot))) - in FD_aux (FD_function(recopt,tannotopt,effectopt,List.map rewrite_funcl funcls),(l,fdannot)) + in + let recopt = match recopt with + | Rec_aux (Rec_nonrec, l) -> Rec_aux (Rec_nonrec, l) + | Rec_aux (Rec_rec, l) -> Rec_aux (Rec_rec, l) + | Rec_aux (Rec_measure (pat,exp),l) -> + Rec_aux (Rec_measure (rewrite_pat rewriters pat, rewrite_exp rewriters exp),l) + in + FD_aux (FD_function(recopt,tannotopt,effectopt,List.map rewrite_funcl funcls),(l,fdannot)) let rewrite_def rewriters d = match d with | DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp), annot)) -> diff --git a/src/rewrites.ml b/src/rewrites.ml index 0ead9670..c6e2743e 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2202,9 +2202,11 @@ let rewrite_fix_val_specs (Defs defs) = (* Repeat once to cross-propagate effects between clauses *) let (val_specs, funcls) = List.fold_left rewrite_funcl (val_specs, []) funcls in let recopt = - if List.exists is_funcl_rec funcls then - Rec_aux (Rec_rec, Parse_ast.Unknown) - else recopt + match recopt with + | Rec_aux ((Rec_rec | Rec_measure _), _) -> recopt + | _ when List.exists is_funcl_rec funcls -> + Rec_aux (Rec_rec, Parse_ast.Unknown) + | _ -> recopt in let tannotopt = match tannotopt, funcls with | Typ_annot_opt_aux (Typ_annot_opt_some (typq, typ), l), @@ -4748,7 +4750,7 @@ let minimise_recursive_functions (Defs defs) = let rewrite_function (FD_aux (FD_function (recopt,topt,effopt,funcls),ann) as fd) = match recopt with | Rec_aux (Rec_nonrec, _) -> fd - | Rec_aux (Rec_rec, l) -> + | Rec_aux ((Rec_rec | Rec_measure _), l) -> if List.exists funcl_is_rec funcls then fd else FD_aux (FD_function (Rec_aux (Rec_nonrec, Generated l),topt,effopt,funcls),ann) diff --git a/src/type_check.ml b/src/type_check.ml index f204a558..9b8bc4e4 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -4300,6 +4300,16 @@ let check_fundef env (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls) in check_tannotopt env quant vtyp_ret tannotopt; typ_debug (lazy ("Checking fundef " ^ string_of_id id ^ " has type " ^ string_of_bind (quant, typ))); + let recopt = + match recopt with + | Rec_aux (Rec_nonrec, l) -> Rec_aux (Rec_nonrec, l) + | Rec_aux (Rec_rec, l) -> Rec_aux (Rec_rec, l) + | Rec_aux (Rec_measure (measure_p, measure_e), l) -> + let typ = match vtyp_args with [x] -> x | _ -> Typ_aux (Typ_tup vtyp_args,Unknown) in + let tpat, env = bind_pat_no_guard env (strip_pat measure_p) typ in + let texp = check_exp env (strip_exp measure_e) int_typ in + Rec_aux (Rec_measure (tpat, texp), l) + in let funcl_env = add_typquant l quant env in let funcls = List.map (fun funcl -> check_funcl funcl_env funcl typ) funcls in let eff = List.fold_left union_effects no_effect (List.map funcl_effect funcls) in -- cgit v1.2.3 From ab4b9ca4f7cab45b6a2a13d0ef125dcf9c276a06 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Tue, 11 Dec 2018 19:54:14 +0000 Subject: Fix all tests with type checking changes --- src/ast_util.ml | 3 +- src/bytecode_util.ml | 3 ++ src/c_backend.ml | 21 ++------- src/constraint.ml | 112 +++++++++++++++++++++++++++-------------------- src/pretty_print_sail.ml | 8 +++- src/type_check.ml | 88 ++++++++++++++++++------------------- 6 files changed, 123 insertions(+), 112 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index 46afe599..8544700b 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -818,8 +818,9 @@ and string_of_pat (P_aux (pat, l)) = | P_vector_concat pats -> string_of_list " @ " string_of_pat pats | P_vector pats -> "[" ^ string_of_list ", " string_of_pat pats ^ "]" | P_as (pat, id) -> "(" ^ string_of_pat pat ^ " as " ^ string_of_id id ^ ")" + | P_string_append [] -> "\"\"" | P_string_append pats -> string_of_list " ^ " string_of_pat pats - | _ -> "PAT" + | P_record _ -> "PAT" and string_of_mpat (MP_aux (pat, l)) = match pat with diff --git a/src/bytecode_util.ml b/src/bytecode_util.ml index c7fdc62d..3ced48b6 100644 --- a/src/bytecode_util.ml +++ b/src/bytecode_util.ml @@ -67,6 +67,9 @@ let instr_number () = let idecl ?loc:(l=Parse_ast.Unknown) ctyp id = I_aux (I_decl (ctyp, id), (instr_number (), l)) +let ireset ?loc:(l=Parse_ast.Unknown) ctyp id = + I_aux (I_reset (ctyp, id), (instr_number (), l)) + let iinit ?loc:(l=Parse_ast.Unknown) ctyp id cval = I_aux (I_init (ctyp, id, cval), (instr_number (), l)) diff --git a/src/c_backend.ml b/src/c_backend.ml index 95ab51df..43fa3719 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -2576,26 +2576,13 @@ let rec codegen_instr fid ctx (I_aux (instr, (_, l))) = | I_clear (ctyp, id) -> string (Printf.sprintf " KILL(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id)) - | I_init (ctyp, id, cval) when is_stack_ctyp ctyp -> - if ctyp_equal ctyp (cval_ctyp cval) then - ksprintf string " %s %s = %s;" (sgen_ctyp ctyp) (sgen_id id) (sgen_cval cval) - else - ksprintf string " %s %s = CREATE_OF(%s, %s)(%s);" - (sgen_ctyp ctyp) (sgen_id id) (sgen_ctyp_name ctyp) (sgen_ctyp_name (cval_ctyp cval)) (sgen_cval_param cval) | I_init (ctyp, id, cval) -> - ksprintf string " %s %s;" (sgen_ctyp ctyp) (sgen_id id) ^^ hardline - ^^ ksprintf string " CREATE_OF(%s, %s)(&%s, %s);" - (sgen_ctyp_name ctyp) (sgen_ctyp_name (cval_ctyp cval)) (sgen_id id) (sgen_cval_param cval) + codegen_instr fid ctx (idecl ctyp id) ^^ hardline + ^^ codegen_conversion Parse_ast.Unknown (CL_id (id, ctyp)) cval - | I_reinit (ctyp, id, cval) when is_stack_ctyp ctyp -> - if ctyp_equal ctyp (cval_ctyp cval) then - ksprintf string " %s %s = %s;" (sgen_ctyp ctyp) (sgen_id id) (sgen_cval cval) - else - ksprintf string " %s %s = CREATE_OF(%s, %s)(%s);" - (sgen_ctyp ctyp) (sgen_id id) (sgen_ctyp_name ctyp) (sgen_ctyp_name (cval_ctyp cval)) (sgen_cval cval) | I_reinit (ctyp, id, cval) -> - ksprintf string " RECREATE_OF(%s, %s)(&%s, %s);" - (sgen_ctyp_name ctyp) (sgen_ctyp_name (cval_ctyp cval)) (sgen_id id) (sgen_cval_param cval) + codegen_instr fid ctx (ireset ctyp id) ^^ hardline + ^^ codegen_conversion Parse_ast.Unknown (CL_id (id, ctyp)) cval | I_reset (ctyp, id) when is_stack_ctyp ctyp -> string (Printf.sprintf " %s %s;" (sgen_ctyp ctyp) (sgen_id id)) diff --git a/src/constraint.ml b/src/constraint.ml index f512eb8a..a16b8c73 100644 --- a/src/constraint.ml +++ b/src/constraint.ml @@ -63,63 +63,79 @@ let rec pp_sexpr : sexpr -> string = function | List xs -> "(" ^ string_of_list " " pp_sexpr xs ^ ")" | Atom x -> x -let zencode_kid kid = Util.zencode_string (string_of_kid kid) - (** Each non-Type/Order kind in Sail mapes to a type in the SMT solver *) let smt_type l = function | K_int -> Atom "Int" | K_bool -> Atom "Bool" | _ -> raise (Reporting.err_unreachable l __POS__ "Tried to pass Type or Order kinded variable to SMT solver") -let smt_var v = Atom ("v" ^ zencode_kid v) - -(** var_decs outputs the list of variables to be used by the SMT - solver in SMTLIB v2.0 format. It takes a kind_aux KBindings, as - returned by Type_check.get_typ_vars *) -let var_decs l (vars : kind_aux KBindings.t) : string = vars - |> KBindings.bindings - |> List.map (fun (v, k) -> sfun "declare-const" [smt_var v; smt_type l k]) - |> string_of_list "\n" pp_sexpr - -let rec smt_nexp (Nexp_aux (aux, l) : nexp) : sexpr = - match aux with - | Nexp_id id -> Atom (Util.zencode_string (string_of_id id)) - | Nexp_var v -> smt_var v - | Nexp_constant c -> Atom (Big_int.to_string c) - | Nexp_app (id, nexps) -> sfun (string_of_id id) (List.map smt_nexp nexps) - | Nexp_times (nexp1, nexp2) -> sfun "*" [smt_nexp nexp1; smt_nexp nexp2] - | Nexp_sum (nexp1, nexp2) -> sfun "+" [smt_nexp nexp1; smt_nexp nexp2] - | Nexp_minus (nexp1, nexp2) -> sfun "-" [smt_nexp nexp1; smt_nexp nexp2] - | Nexp_exp nexp -> sfun "^" [Atom "2"; smt_nexp nexp] - | Nexp_neg nexp -> sfun "-" [smt_nexp nexp] - -let rec smt_constraint (NC_aux (aux, l) : n_constraint) : sexpr = - match aux with - | NC_equal (nexp1, nexp2) -> sfun "=" [smt_nexp nexp1; smt_nexp nexp2] - | NC_bounded_le (nexp1, nexp2) -> sfun "<=" [smt_nexp nexp1; smt_nexp nexp2] - | NC_bounded_ge (nexp1, nexp2) -> sfun ">=" [smt_nexp nexp1; smt_nexp nexp2] - | NC_not_equal (nexp1, nexp2) -> sfun "not" [sfun "=" [smt_nexp nexp1; smt_nexp nexp2]] - | NC_set (v, ints) -> - sfun "or" (List.map (fun i -> sfun "=" [smt_var v; Atom (Big_int.to_string i)]) ints) - | NC_or (nc1, nc2) -> sfun "or" [smt_constraint nc1; smt_constraint nc2] - | NC_and (nc1, nc2) -> sfun "and" [smt_constraint nc1; smt_constraint nc2] - | NC_app (id, args) -> - sfun (string_of_id id) (List.map smt_typ_arg args) - | NC_true -> Atom "true" - | NC_false -> Atom "false" - | NC_var v -> smt_var v - -and smt_typ_arg (A_aux (aux, l) : typ_arg) : sexpr = - match aux with - | A_nexp nexp -> smt_nexp nexp - | A_bool nc -> smt_constraint nc - | _ -> - raise (Reporting.err_unreachable l __POS__ "Tried to pass Type or Order kind to SMT function") +let to_smt l vars constr = + (* Numbering all SMT variables v0, ... vn, rather than generating + names based on their Sail names (e.g. using zencode) ensures that + alpha-equivalent constraints generate the same SMT problem, which + is important for the SMT memoisation to work properly. *) + let var_map = ref KBindings.empty in + let vnum = ref (-1) in + let smt_var v = + match KBindings.find_opt v !var_map with + | Some n -> Atom ("v" ^ string_of_int n) + | None -> + let n = !vnum + 1 in + var_map := KBindings.add v n !var_map; + vnum := n; + Atom ("v" ^ string_of_int n) + in + + (* var_decs outputs the list of variables to be used by the SMT + solver in SMTLIB v2.0 format. It takes a kind_aux KBindings, as + returned by Type_check.get_typ_vars *) + let var_decs l (vars : kind_aux KBindings.t) : string = + vars + |> KBindings.bindings + |> List.map (fun (v, k) -> sfun "declare-const" [smt_var v; smt_type l k]) + |> string_of_list "\n" pp_sexpr + in + let rec smt_nexp (Nexp_aux (aux, l) : nexp) : sexpr = + match aux with + | Nexp_id id -> Atom (Util.zencode_string (string_of_id id)) + | Nexp_var v -> smt_var v + | Nexp_constant c -> Atom (Big_int.to_string c) + | Nexp_app (id, nexps) -> sfun (string_of_id id) (List.map smt_nexp nexps) + | Nexp_times (nexp1, nexp2) -> sfun "*" [smt_nexp nexp1; smt_nexp nexp2] + | Nexp_sum (nexp1, nexp2) -> sfun "+" [smt_nexp nexp1; smt_nexp nexp2] + | Nexp_minus (nexp1, nexp2) -> sfun "-" [smt_nexp nexp1; smt_nexp nexp2] + | Nexp_exp nexp -> sfun "^" [Atom "2"; smt_nexp nexp] + | Nexp_neg nexp -> sfun "-" [smt_nexp nexp] + in + let rec smt_constraint (NC_aux (aux, l) : n_constraint) : sexpr = + match aux with + | NC_equal (nexp1, nexp2) -> sfun "=" [smt_nexp nexp1; smt_nexp nexp2] + | NC_bounded_le (nexp1, nexp2) -> sfun "<=" [smt_nexp nexp1; smt_nexp nexp2] + | NC_bounded_ge (nexp1, nexp2) -> sfun ">=" [smt_nexp nexp1; smt_nexp nexp2] + | NC_not_equal (nexp1, nexp2) -> sfun "not" [sfun "=" [smt_nexp nexp1; smt_nexp nexp2]] + | NC_set (v, ints) -> + sfun "or" (List.map (fun i -> sfun "=" [smt_var v; Atom (Big_int.to_string i)]) ints) + | NC_or (nc1, nc2) -> sfun "or" [smt_constraint nc1; smt_constraint nc2] + | NC_and (nc1, nc2) -> sfun "and" [smt_constraint nc1; smt_constraint nc2] + | NC_app (id, args) -> + sfun (string_of_id id) (List.map smt_typ_arg args) + | NC_true -> Atom "true" + | NC_false -> Atom "false" + | NC_var v -> smt_var v + and smt_typ_arg (A_aux (aux, l) : typ_arg) : sexpr = + match aux with + | A_nexp nexp -> smt_nexp nexp + | A_bool nc -> smt_constraint nc + | _ -> + raise (Reporting.err_unreachable l __POS__ "Tried to pass Type or Order kind to SMT function") + in + var_decs l vars, smt_constraint constr let smtlib_of_constraints ?get_model:(get_model=false) l vars constr : string = + let variables, problem = to_smt l vars constr in "(push)\n" - ^ var_decs l vars ^ "\n" - ^ pp_sexpr (sfun "define-fun" [Atom "constraint"; List []; Atom "Bool"; smt_constraint constr]) + ^ variables ^ "\n" + ^ pp_sexpr (sfun "define-fun" [Atom "constraint"; List []; Atom "Bool"; problem]) ^ "\n(assert constraint)\n(check-sat)" ^ (if get_model then "\n(get-model)" else "") ^ "\n(pop)" diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index bae1b893..94bcd54b 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -279,7 +279,7 @@ let doc_lit (L_aux(l,_)) = | L_undef -> "undefined" | L_string s -> "\"" ^ String.escaped s ^ "\"") -let rec doc_pat (P_aux (p_aux, _) as pat) = +let rec doc_pat (P_aux (p_aux, (l, _)) as pat) = match p_aux with | P_id id -> doc_id id | P_or (pat1, pat2) -> parens (doc_pat pat1 ^^ string " | " ^^ doc_pat pat2) @@ -297,7 +297,11 @@ let rec doc_pat (P_aux (p_aux, _) as pat) = | P_as (pat, id) -> parens (separate space [doc_pat pat; string "as"; doc_id id]) | P_app (id, pats) -> doc_id id ^^ parens (separate_map (comma ^^ space) doc_pat pats) | P_list pats -> string "[|" ^^ separate_map (comma ^^ space) doc_pat pats ^^ string "|]" - | _ -> string (string_of_pat pat) + | P_cons (hd_pat, tl_pat) -> separate space [doc_pat hd_pat; string "::"; doc_pat tl_pat] + | P_string_append [] -> string "\"\"" + | P_string_append pats -> + parens (separate_map (string " ^ ") doc_pat pats) + | P_record _ -> raise (Reporting.err_unreachable l __POS__ "P_record passed to doc_pat") (* if_block_x is true if x should be printed like a block, i.e. with newlines. Blocks are automatically printed as blocks, so this diff --git a/src/type_check.ml b/src/type_check.ml index 459fe8d7..51625d4a 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -722,7 +722,16 @@ end = struct with | Not_found -> typ_error (id_loc id) ("No val spec found for " ^ string_of_id id) - let ex_counter = ref 0 + let add_union_id id bind env = + typ_print (lazy (adding ^ "union identifier " ^ string_of_id id ^ " : " ^ string_of_bind bind)); + { env with union_ids = Bindings.add id bind env.union_ids } + + let get_union_id id env = + try + let bind = Bindings.find id env.union_ids in + List.fold_left (fun bind (kid, _) -> freshen_kid env kid bind) bind (KBindings.bindings env.typ_vars) + with + | Not_found -> typ_error (id_loc id) ("No union constructor found for " ^ string_of_id id) let rec update_val_spec id (typq, typ) env = begin match expand_synonyms env typ with @@ -757,6 +766,8 @@ end = struct if not (Bindings.mem id env.top_val_specs) then update_val_spec id (bind_typq, bind_typ) env else + env + (* let (existing_typq, existing_typ) = Bindings.find id env.top_val_specs in let existing_cmp = (strip_typq existing_typq, strip_typ existing_typ) in let bind_cmp = (strip_typq bind_typq, strip_typ bind_typ) in @@ -764,36 +775,34 @@ end = struct typ_error (id_loc id) ("Identifier " ^ string_of_id id ^ " is already bound as " ^ string_of_bind (existing_typq, existing_typ) ^ ", cannot rebind as " ^ string_of_bind (bind_typq, bind_typ)) else env + *) and add_mapping id (typq, typ1, typ2) env = - begin - typ_print (lazy (adding ^ "mapping " ^ string_of_id id)); - let forwards_id = mk_id (string_of_id id ^ "_forwards") in - let forwards_matches_id = mk_id (string_of_id id ^ "_forwards_matches") in - let backwards_id = mk_id (string_of_id id ^ "_backwards") in - let backwards_matches_id = mk_id (string_of_id id ^ "_backwards_matches") in - let forwards_typ = Typ_aux (Typ_fn ([typ1], typ2, no_effect), Parse_ast.Unknown) in - let forwards_matches_typ = Typ_aux (Typ_fn ([typ1], bool_typ, no_effect), Parse_ast.Unknown) in - let backwards_typ = Typ_aux (Typ_fn ([typ2], typ1, no_effect), Parse_ast.Unknown) in - let backwards_matches_typ = Typ_aux (Typ_fn ([typ2], bool_typ, no_effect), Parse_ast.Unknown) in - let env = - { env with mappings = Bindings.add id (typq, typ1, typ2) env.mappings } - |> add_val_spec forwards_id (typq, forwards_typ) - |> add_val_spec backwards_id (typq, backwards_typ) - |> add_val_spec forwards_matches_id (typq, forwards_matches_typ) - |> add_val_spec backwards_matches_id (typq, backwards_matches_typ) - in - let prefix_id = mk_id (string_of_id id ^ "_matches_prefix") in - begin if strip_typ typ1 = string_typ then - let forwards_prefix_typ = Typ_aux (Typ_fn ([typ1], app_typ (mk_id "option") [A_aux (A_typ (tuple_typ [typ2; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in - add_val_spec prefix_id (typq, forwards_prefix_typ) env - else if strip_typ typ2 = string_typ then - let backwards_prefix_typ = Typ_aux (Typ_fn ([typ2], app_typ (mk_id "option") [A_aux (A_typ (tuple_typ [typ1; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in - add_val_spec prefix_id (typq, backwards_prefix_typ) env - else - env - end - end + typ_print (lazy (adding ^ "mapping " ^ string_of_id id)); + let forwards_id = mk_id (string_of_id id ^ "_forwards") in + let forwards_matches_id = mk_id (string_of_id id ^ "_forwards_matches") in + let backwards_id = mk_id (string_of_id id ^ "_backwards") in + let backwards_matches_id = mk_id (string_of_id id ^ "_backwards_matches") in + let forwards_typ = Typ_aux (Typ_fn ([typ1], typ2, no_effect), Parse_ast.Unknown) in + let forwards_matches_typ = Typ_aux (Typ_fn ([typ1], bool_typ, no_effect), Parse_ast.Unknown) in + let backwards_typ = Typ_aux (Typ_fn ([typ2], typ1, no_effect), Parse_ast.Unknown) in + let backwards_matches_typ = Typ_aux (Typ_fn ([typ2], bool_typ, no_effect), Parse_ast.Unknown) in + let env = + { env with mappings = Bindings.add id (typq, typ1, typ2) env.mappings } + |> add_val_spec forwards_id (typq, forwards_typ) + |> add_val_spec backwards_id (typq, backwards_typ) + |> add_val_spec forwards_matches_id (typq, forwards_matches_typ) + |> add_val_spec backwards_matches_id (typq, backwards_matches_typ) + in + let prefix_id = mk_id (string_of_id id ^ "_matches_prefix") in + if strip_typ typ1 = string_typ then + let forwards_prefix_typ = Typ_aux (Typ_fn ([typ1], app_typ (mk_id "option") [A_aux (A_typ (tuple_typ [typ2; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in + add_val_spec prefix_id (typq, forwards_prefix_typ) env + else if strip_typ typ2 = string_typ then + let backwards_prefix_typ = Typ_aux (Typ_fn ([typ2], app_typ (mk_id "option") [A_aux (A_typ (tuple_typ [typ1; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in + add_val_spec prefix_id (typq, backwards_prefix_typ) env + else + env let define_val_spec id env = if IdSet.mem id env.defined_val_specs @@ -921,18 +930,6 @@ end = struct match Bindings.find_opt id env.variants with | Some (typq, tus) -> typq, tus | None -> typ_error (id_loc id) ("union " ^ string_of_id id ^ " not found") - - let add_union_id id bind env = - typ_print (lazy (adding ^ "union identifier " ^ string_of_id id ^ " : " ^ string_of_bind bind)); - { env with union_ids = Bindings.add id bind env.union_ids } - - let get_union_id id env = - try - let bind = Bindings.find id env.union_ids in - List.fold_left (fun bind (kid, _) -> freshen_kid env kid bind) bind (KBindings.bindings env.typ_vars) - with - | Not_found -> typ_error (id_loc id) ("No union constructor found for " ^ string_of_id id) - let get_flow id env = try Bindings.find id env.flow with | Not_found -> fun typ -> typ @@ -1730,6 +1727,8 @@ let rec subtyp l env typ1 typ2 = else typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env)) | None, None -> match typ_aux1, typ_aux2 with + | _, Typ_internal_unknown when Env.allow_unknowns env -> () + | Typ_tup typs1, Typ_tup typs2 when List.length typs1 = List.length typs2 -> List.iter2 (subtyp l env) typs1 typs2 @@ -2598,7 +2597,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) | P_app (f, pats) when Env.is_mapping f env -> begin - let (typq, mapping_typ) = Env.get_union_id f env in + let (typq, mapping_typ) = Env.get_val_spec f env in let quants = quant_items typq in let untuple (Typ_aux (typ_aux, _) as typ) = match typ_aux with | Typ_tup typs -> typs @@ -3317,14 +3316,15 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ = typ_debug (lazy ("Existentials: " ^ string_of_list ", " string_of_kid existentials)); typ_debug (lazy ("Existential constraints: " ^ string_of_list ", " string_of_n_constraint ex_constraints)); + let universals = KBindings.bindings universals |> List.map fst |> KidSet.of_list in let typ_ret = - if KidSet.is_empty (KidSet.of_list existentials) || KidSet.is_empty (typ_frees !typ_ret) + if KidSet.is_empty (KidSet.of_list existentials) || KidSet.is_empty (KidSet.diff (typ_frees !typ_ret) universals) then !typ_ret else mk_typ (Typ_exist (existentials, List.fold_left nc_and nc_true ex_constraints, !typ_ret)) in let typ_ret = simp_typ typ_ret in let exp = annot_exp (E_app (f, xs)) typ_ret eff in - typ_debug (lazy ("RETURNING: " ^ string_of_exp exp)); + typ_debug (lazy ("Returning: " ^ string_of_exp exp)); exp, !all_unifiers -- cgit v1.2.3 From c65aecd008d34102f4c95649113ed7f9afcc903b Mon Sep 17 00:00:00 2001 From: Alasdair Date: Wed, 12 Dec 2018 00:49:32 +0000 Subject: Fix various boolean type-variable related issues Remove some dead code in Pretty_print_common Start thinking a bit about Minisail-esque syntactic sugar in initial_check --- src/ast_util.ml | 8 +++ src/ast_util.mli | 4 +- src/initial_check.ml | 5 +- src/parse_ast.ml | 1 + src/parser.mly | 2 + src/pretty_print_common.ml | 128 --------------------------------------------- src/pretty_print_sail.ml | 10 ++-- src/type_check.ml | 10 +++- 8 files changed, 33 insertions(+), 135 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index 8544700b..6c67e6e7 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -143,6 +143,10 @@ let is_typ_kopt = function | KOpt_aux (KOpt_kind (K_aux (K_type, _), _), _) -> true | _ -> false +let is_bool_kopt = function + | KOpt_aux (KOpt_kind (K_aux (K_bool, _), _), _) -> true + | _ -> false + let string_of_kid = function | Kid_aux (Var v, _) -> v @@ -321,6 +325,9 @@ let mk_infix_id str = Id_aux (DeIid str, Parse_ast.Unknown) let mk_id_typ id = Typ_aux (Typ_id id, Parse_ast.Unknown) +let mk_kopt kind_aux id = + KOpt_aux (KOpt_kind (K_aux (kind_aux, Parse_ast.Unknown), id), Parse_ast.Unknown) + let mk_ord ord_aux = Ord_aux (ord_aux, Parse_ast.Unknown) let unknown_typ = mk_typ Typ_internal_unknown @@ -673,6 +680,7 @@ and string_of_typ_aux = function | Typ_var kid -> string_of_kid kid | Typ_tup typs -> "(" ^ string_of_list ", " string_of_typ typs ^ ")" | Typ_app (id, args) when Id.compare id (mk_id "atom") = 0 -> "int(" ^ string_of_list ", " string_of_typ_arg args ^ ")" + | Typ_app (id, args) when Id.compare id (mk_id "atom_bool") = 0 -> "bool(" ^ string_of_list ", " string_of_typ_arg args ^ ")" | Typ_app (id, args) -> string_of_id id ^ "(" ^ string_of_list ", " string_of_typ_arg args ^ ")" | Typ_fn ([typ_arg], typ_ret, eff) -> string_of_typ typ_arg ^ " -> " ^ string_of_typ typ_ret ^ " effect " ^ string_of_effect eff diff --git a/src/ast_util.mli b/src/ast_util.mli index fe36dfb6..c0123ce1 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -90,6 +90,7 @@ val mk_qi_nc : n_constraint -> quant_item val mk_qi_kopt : kinded_id -> quant_item val mk_fexp : id -> unit exp -> unit fexp val mk_letbind : unit pat -> unit exp -> unit letbind +val mk_kopt : kind_aux -> kid -> kinded_id val unaux_exp : 'a exp -> 'a exp_aux val unaux_pat : 'a pat -> 'a pat_aux @@ -110,7 +111,8 @@ val kopt_kid : kinded_id -> kid val is_nat_kopt : kinded_id -> bool val is_order_kopt : kinded_id -> bool val is_typ_kopt : kinded_id -> bool - +val is_bool_kopt : kinded_id -> bool + (* Some handy utility functions for constructing types. *) val mk_typ : typ_aux -> typ val mk_typ_arg : typ_arg_aux -> typ_arg diff --git a/src/initial_check.ml b/src/initial_check.ml index 44f36892..da6c7b84 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -96,7 +96,7 @@ let to_ast_id (P.Id_aux(id, l)) = | P.DeIid x -> DeIid x), l) -let to_ast_var (P.Kid_aux(P.Var v,l)) = Kid_aux(Var v,l) +let to_ast_var (P.Kid_aux (P.Var v, l)) = Kid_aux (Var v, l) let to_ast_effects = function | P.ATyp_aux (P.ATyp_set effects, l) -> @@ -161,6 +161,8 @@ let rec to_ast_typ ctx (P.ATyp_aux (aux, l)) = let kids = List.map to_ast_var kids in let ctx = { ctx with kinds = List.fold_left (fun kinds kid -> KBindings.add kid K_int kinds) ctx.kinds kids } in Typ_exist (kids, to_ast_constraint ctx nc, to_ast_typ ctx atyp) + | P.ATyp_base (id, kind, nc) -> + raise (Reporting.err_unreachable l __POS__ "TODO") | _ -> raise (Reporting.err_typ l "Invalid type") in Typ_aux (aux, l) @@ -763,6 +765,7 @@ let initial_ctx = { ("atom", [K_int]); ("implicit", [K_int]); ("itself", [K_int]); + ("not", [K_bool]); ]; kinds = KBindings.empty; scattereds = Bindings.empty; diff --git a/src/parse_ast.ml b/src/parse_ast.ml index c57daa26..a5dbf66e 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -164,6 +164,7 @@ atyp_aux = (* expressions of all kinds, to be translated to types, nats, orders | ATyp_tup of (atyp) list (* Tuple type *) | ATyp_app of id * (atyp) list (* type constructor application *) | ATyp_exist of kid list * atyp * atyp + | ATyp_base of id * atyp * atyp and atyp = ATyp_aux of atyp_aux * l diff --git a/src/parser.mly b/src/parser.mly index 83e6936d..544438c0 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -555,6 +555,8 @@ atomic_typ: { mk_typ (ATyp_exist ($2, ATyp_aux (ATyp_lit (L_aux (L_true, loc $startpos $endpos)), loc $startpos $endpos), $4)) $startpos $endpos } | Lcurly kid_list Comma typ Dot typ Rcurly { mk_typ (ATyp_exist ($2, $4, $6)) $startpos $endpos } + | Lcurly id Colon typ Dot typ Rcurly + { mk_typ (ATyp_base ($2, $4, $6)) $startpos $endpos } typ_list: | typ diff --git a/src/pretty_print_common.ml b/src/pretty_print_common.ml index 0f1dee90..c01896ac 100644 --- a/src/pretty_print_common.ml +++ b/src/pretty_print_common.ml @@ -94,133 +94,5 @@ let rec doc_range (BF_aux(r,_)) = match r with | BF_range(i1,i2) -> doc_op dotdot (doc_int i1) (doc_int i2) | BF_concat(ir1,ir2) -> (doc_range ir1) ^^ comma ^^ (doc_range ir2) -let doc_effect (BE_aux (e,_)) = - string (match e with - | BE_rreg -> "rreg" - | BE_wreg -> "wreg" - | BE_rmem -> "rmem" - | BE_rmemt -> "rmemt" - | BE_wmem -> "wmem" - | BE_wmv -> "wmv" - | BE_wmvt -> "wmvt" - (*| BE_lset -> "lset" - | BE_lret -> "lret"*) - | BE_eamem -> "eamem" - | BE_exmem -> "exmem" - | BE_barr -> "barr" - | BE_depend -> "depend" - | BE_escape -> "escape" - | BE_undef -> "undef" - | BE_unspec -> "unspec" - | BE_nondet -> "nondet" - | BE_config -> "config") - -let doc_effects (Effect_aux(e,_)) = match e with - | Effect_set [] -> string "pure" - | Effect_set s -> braces (separate_map comma_sp doc_effect s) - -let doc_ord (Ord_aux(o,_)) = match o with - | Ord_var v -> doc_var v - | Ord_inc -> string "inc" - | Ord_dec -> string "dec" - -let doc_typ, doc_atomic_typ, doc_nexp, doc_nexp_constraint = - (* following the structure of parser for precedence *) - let rec typ ty = fn_typ ty - and fn_typ ((Typ_aux (t, _)) as ty) = match t with - | Typ_fn(args,ret,efct) -> - separate space [parens (separate_map (comma ^^ space) tup_typ args); arrow; fn_typ ret; string "effect"; doc_effects efct] - | Typ_bidir (t1, t2) -> - separate space [tup_typ t1; bidir; tup_typ t2] - | _ -> tup_typ ty - and tup_typ ((Typ_aux (t, _)) as ty) = match t with - | Typ_exist (kids, nc, ty) -> - separate space [string "exist"; separate_map space doc_var kids ^^ comma; nexp_constraint nc ^^ dot; typ ty] - | Typ_tup typs -> parens (separate_map comma_sp app_typ typs) - | _ -> app_typ ty - and app_typ ((Typ_aux (t, _)) as ty) = match t with - | Typ_app(Id_aux (Id "range", _), [ - A_aux(A_nexp (Nexp_aux(Nexp_constant n, _)), _); - A_aux(A_nexp m, _);]) -> - (squarebars (if Big_int.equal n Big_int.zero then nexp m else doc_op colon (doc_int n) (nexp m))) - | Typ_app(Id_aux (Id "atom", _), [A_aux(A_nexp n,_)]) -> - (squarecolons (nexp n)) - | Typ_app(id,args) -> - (* trailing space to avoid >> token in case of nested app types *) - (doc_id id) ^^ (angles (separate_map comma_sp doc_typ_arg args)) ^^ space - | _ -> atomic_typ ty (* for simplicity, skip vec_typ - which is only sugar *) - and atomic_typ ((Typ_aux (t, _)) as ty) = match t with - | Typ_id id -> doc_id id - | Typ_var v -> doc_var v - | Typ_app _ | Typ_tup _ | Typ_fn _ | Typ_bidir _ | Typ_exist _ -> - (* exhaustiveness matters here to avoid infinite loops - * if we add a new Typ constructor *) - group (parens (typ ty)) - | Typ_internal_unknown -> string "UNKNOWN" - - and doc_typ_arg (A_aux(t,_)) = match t with - (* Be careful here because typ_arg is implemented as nexp in the - * parser - in practice falling through app_typ after all the proper nexp - * cases; so A_typ has the same precedence as a Typ_app *) - | A_typ t -> app_typ t - | A_nexp n -> nexp n - | A_order o -> doc_ord o - - (* same trick to handle precedence of nexp *) - and nexp ne = sum_typ ne - and sum_typ ((Nexp_aux(n,_)) as ne) = match n with - | Nexp_sum(n1,n2) -> doc_op plus (sum_typ n1) (star_typ n2) - | Nexp_minus(n1,n2) -> doc_op minus (sum_typ n1) (star_typ n2) - | _ -> star_typ ne - and star_typ ((Nexp_aux(n,_)) as ne) = match n with - | Nexp_times(n1,n2) -> doc_op star (star_typ n1) (exp_typ n2) - | _ -> exp_typ ne - and exp_typ ((Nexp_aux(n,_)) as ne) = match n with - | Nexp_exp n1 -> doc_unop (string "2**") (atomic_nexp_typ n1) - | _ -> neg_typ ne - and neg_typ ((Nexp_aux(n,_)) as ne) = match n with - | Nexp_neg n1 -> - (* XXX this is not valid Sail, only an internal representation - - * work around by commenting it *) - let minus = concat [string "(*"; minus; string "*)"] in - minus ^^ (atomic_nexp_typ n1) - | _ -> atomic_nexp_typ ne - and atomic_nexp_typ ((Nexp_aux(n,_)) as ne) = match n with - | Nexp_var v -> doc_var v - | Nexp_id i -> braces (doc_id i) - | Nexp_app (op, args) -> doc_id op ^^ parens (separate_map (comma ^^ space) nexp args) - | Nexp_constant i -> if Big_int.less i Big_int.zero then parens(doc_int i) else doc_int i - | Nexp_neg _ | Nexp_exp _ | Nexp_times _ | Nexp_sum _ | Nexp_minus _-> - group (parens (nexp ne)) - - and nexp_constraint (NC_aux(nc,_)) = match nc with - | NC_equal(n1,n2) -> doc_op equals (nexp n1) (nexp n2) - | NC_not_equal (n1, n2) -> doc_op (string "!=") (nexp n1) (nexp n2) - | NC_bounded_ge(n1,n2) -> doc_op (string ">=") (nexp n1) (nexp n2) - | NC_bounded_le(n1,n2) -> doc_op (string "<=") (nexp n1) (nexp n2) - | NC_set(v,bounds) -> - doc_op (string "IN") (doc_var v) - (braces (separate_map comma_sp doc_int bounds)) - | NC_or (nc1, nc2) -> - parens (separate space [nexp_constraint nc1; string "|"; nexp_constraint nc2]) - | NC_and (nc1, nc2) -> - separate space [nexp_constraint nc1; string "&"; nexp_constraint nc2] - | NC_true -> string "true" - | NC_false -> string "false" - - (* expose doc_typ, doc_atomic_typ, doc_nexp and doc_nexp_constraint *) - in typ, atomic_typ, nexp, nexp_constraint - -let pp_format_id (Id_aux(i,_)) = - match i with - | Id(i) -> i - | DeIid(x) -> "(deinfix " ^ x ^ ")" - -let rec list_format (sep : string) (fmt : 'a -> string) (ls : 'a list) : string = - match ls with - | [] -> "" - | [a] -> fmt a - | a::ls -> (fmt a) ^ sep ^ (list_format sep fmt ls) - let print ?(len=100) channel doc = ToChannel.pretty 1. len channel doc let to_buf ?(len=100) buf doc = ToBuffer.pretty 1. len buf doc diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index 94bcd54b..f756f3d2 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -113,7 +113,7 @@ let rec doc_nexp = in nexp0 -let doc_nc nc = +let rec doc_nc nc = let nc_op op n1 n2 = separate space [doc_nexp n1; string op; doc_nexp n2] in let rec atomic_nc (NC_aux (nc_aux, _) as nc) = match nc_aux with @@ -125,7 +125,10 @@ let doc_nc nc = | NC_bounded_le (n1, n2) -> nc_op "<=" n1 n2 | NC_set (kid, ints) -> separate space [doc_kid kid; string "in"; braces (separate_map (comma ^^ space) doc_int ints)] - | _ -> nc0 ~parenthesize:true nc + | NC_app (id, args) -> + doc_id id ^^ parens (separate_map (comma ^^ space) doc_typ_arg args) + | NC_var kid -> doc_kid kid + | NC_or _ | NC_and _ -> nc0 ~parenthesize:true nc and nc0 ?parenthesize:(parenthesize=false) (NC_aux (nc_aux, _) as nc) = (* Rather than parens (nc0 x) we use nc0 ~parenthesize:true x, because if we rewrite a disjunction as a set constraint, then we can @@ -151,7 +154,7 @@ let doc_nc nc = in atomic_nc (constraint_simp nc) -let rec doc_typ ?(simple=false) (Typ_aux (typ_aux, l)) = +and doc_typ ?(simple=false) (Typ_aux (typ_aux, l)) = match typ_aux with | Typ_id id -> doc_id id | Typ_app (id, []) -> doc_id id @@ -186,6 +189,7 @@ and doc_typ_arg (A_aux (ta_aux, _)) = | A_typ typ -> doc_typ typ | A_nexp nexp -> doc_nexp nexp | A_order o -> doc_ord o + | A_bool nc -> doc_nc nc and doc_arg_typs = function | [typ] -> doc_typ typ | typs -> parens (separate_map (comma ^^ space) doc_typ typs) diff --git a/src/type_check.ml b/src/type_check.ml index 51625d4a..2f4561b5 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -449,7 +449,8 @@ end = struct ("real", []); ("list", [K_type]); ("string", []); - ("itself", [K_int]) + ("itself", [K_int]); + ("atom_bool", [K_bool]) ] let builtin_mappings = @@ -499,6 +500,8 @@ end = struct subst_args kopts args | kopt :: kopts, A_aux (A_order arg, _) :: args when is_order_kopt kopt -> subst_args kopts args + | kopt :: kopts, A_aux (A_bool arg, _) :: args when is_bool_kopt kopt -> + subst_args kopts args | [], [] -> ncs | _, A_aux (_, l) :: _ -> typ_error l ("Error when processing type quantifer arguments " ^ string_of_typquant typq) | _, _ -> typ_error Parse_ast.Unknown ("Error when processing type quantifer arguments " ^ string_of_typquant typq) @@ -1624,8 +1627,9 @@ let rec alpha_equivalent env typ1 typ2 = in Typ_aux (relabelled_aux, l) and relabel_arg (A_aux (aux, l) as arg) = + (* FIXME relabel constraint *) match aux with - | A_nexp _ | A_order _ -> arg + | A_nexp _ | A_order _ | A_bool _ -> arg | A_typ typ -> A_aux (A_typ (relabel typ), l) in @@ -1729,6 +1733,8 @@ let rec subtyp l env typ1 typ2 = match typ_aux1, typ_aux2 with | _, Typ_internal_unknown when Env.allow_unknowns env -> () + | Typ_app (id1, _), Typ_id id2 when string_of_id id1 = "atom_bool" && string_of_id id2 = "bool" -> () + | Typ_tup typs1, Typ_tup typs2 when List.length typs1 = List.length typs2 -> List.iter2 (subtyp l env) typs1 typs2 -- cgit v1.2.3 From cdf287dfb69275e479d79ebc0d305e365dd3ee7b Mon Sep 17 00:00:00 2001 From: Alasdair Date: Wed, 12 Dec 2018 01:45:20 +0000 Subject: Remove KOpt_none constructor We should infer type variable kinds better in initial_check.ml, but we really don't want to have to deal with that everywhere, especially when we can no longer easily cheat and assume KOpt_none implies K_int. --- src/ast_util.ml | 14 ++++---------- src/ast_util.mli | 2 ++ src/initial_check.ml | 7 +------ src/monomorphise.ml | 4 ++-- src/pretty_print_coq.ml | 5 ----- src/pretty_print_lem.ml | 2 -- src/pretty_print_sail.ml | 3 --- src/spec_analysis.ml | 1 - src/state.ml | 2 +- src/type_check.ml | 13 ++++++------- 10 files changed, 16 insertions(+), 37 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index 6c67e6e7..bd7a51bb 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -126,13 +126,11 @@ let mk_letbind pat exp = LB_aux (LB_val (pat, exp), no_annot) let mk_val_spec vs_aux = DEF_spec (VS_aux (vs_aux, no_annot)) -let kopt_kid (KOpt_aux (kopt_aux, _)) = - match kopt_aux with - | KOpt_none kid | KOpt_kind (_, kid) -> kid +let kopt_kid (KOpt_aux (KOpt_kind (_, kid), _)) = kid +let kopt_kind (KOpt_aux (KOpt_kind (k, _), _)) = k let is_nat_kopt = function | KOpt_aux (KOpt_kind (K_aux (K_int, _), _), _) -> true - | KOpt_aux (KOpt_none _, _) -> true | _ -> false let is_order_kopt = function @@ -713,9 +711,7 @@ and string_of_n_constraint = function | NC_aux (NC_true, _) -> "true" | NC_aux (NC_false, _) -> "false" -let string_of_kinded_id = function - | KOpt_aux (KOpt_none kid, _) -> string_of_kid kid - | KOpt_aux (KOpt_kind (k, kid), _) -> "(" ^ string_of_kid kid ^ " : " ^ string_of_kind k ^ ")" +let string_of_kinded_id (KOpt_aux (KOpt_kind (k, kid), _)) = "(" ^ string_of_kid kid ^ " : " ^ string_of_kind k ^ ")" let string_of_quant_item_aux = function | QI_id kopt -> string_of_kinded_id kopt @@ -1192,7 +1188,7 @@ and tyvars_of_typ_arg (A_aux (ta,_)) = | A_bool nc -> tyvars_of_constraint nc let tyvars_of_quant_item (QI_aux (qi, _)) = match qi with - | QI_id (KOpt_aux ((KOpt_none kid | KOpt_kind (_, kid)), _)) -> + | QI_id (KOpt_aux (KOpt_kind (_, kid), _)) -> KidSet.singleton kid | QI_const nc -> tyvars_of_constraint nc @@ -1660,8 +1656,6 @@ let subst_kid subst sv v x = |> subst sv (mk_typ_arg (A_typ (mk_typ (Typ_var v)))) let quant_item_subst_kid_aux sv subst = function - | QI_id (KOpt_aux (KOpt_none kid, l)) as qid -> - if Kid.compare kid sv = 0 then QI_id (KOpt_aux (KOpt_none subst, l)) else qid | QI_id (KOpt_aux (KOpt_kind (k, kid), l)) as qid -> if Kid.compare kid sv = 0 then QI_id (KOpt_aux (KOpt_kind (k, subst), l)) else qid | QI_const nc -> diff --git a/src/ast_util.mli b/src/ast_util.mli index c0123ce1..8155acde 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -108,6 +108,7 @@ val dec_ord : order (* Utilites for working with kinded_ids *) val kopt_kid : kinded_id -> kid +val kopt_kind : kinded_id -> kind val is_nat_kopt : kinded_id -> bool val is_order_kopt : kinded_id -> bool val is_typ_kopt : kinded_id -> bool @@ -173,6 +174,7 @@ val nc_true : n_constraint val nc_false : n_constraint val nc_set : kid -> Big_int.num list -> n_constraint val nc_int_set : kid -> int list -> n_constraint +val nc_var : kid -> n_constraint val arg_nexp : ?loc:l -> nexp -> typ_arg val arg_order : ?loc:l -> order -> typ_arg diff --git a/src/initial_check.ml b/src/initial_check.ml index da6c7b84..62f0dcf4 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -234,7 +234,7 @@ let to_ast_quant_item ctx (P.QI_aux (aux, l)) = let aux, ctx = match aux with | P.KOpt_none v -> let v = to_ast_var v in - KOpt_none v, { ctx with kinds = KBindings.add v K_int ctx.kinds } + KOpt_kind (K_aux (K_int, gen_loc kopt_l), v), { ctx with kinds = KBindings.add v K_int ctx.kinds } | P.KOpt_kind (k, v) -> let v = to_ast_var v in let k = to_ast_kind k in @@ -496,11 +496,6 @@ let to_ast_type_union ctx (P.Tu_aux (P.Tu_ty_id (atyp, id), l)) = let typ = to_ast_typ ctx atyp in Tu_aux (Tu_ty_id (typ, to_ast_id id), l) -let kopt_kind (KOpt_aux (aux, l)) = - match aux with - | KOpt_none _ -> K_aux (K_int, gen_loc l) - | KOpt_kind (k, _) -> k - let add_constructor id typq ctx = let kinds = List.map (fun kopt -> unaux_kind (kopt_kind kopt)) (quant_kopts typq) in { ctx with type_constructors = Bindings.add id kinds ctx.type_constructors } diff --git a/src/monomorphise.ml b/src/monomorphise.ml index 113db3a2..9206332d 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -3358,7 +3358,7 @@ let initial_env fn_id fn_l (TypQ_aux (tq,_)) pat body set_assertions = in aux pat in let quant = function - | QI_aux (QI_id (KOpt_aux ((KOpt_none kid | KOpt_kind (_,kid)),_)),_) -> + | QI_aux (QI_id (KOpt_aux (KOpt_kind (_,kid),_)),_) -> Some kid | QI_aux (QI_const _,_) -> None in @@ -4264,7 +4264,7 @@ let rewrite_toplevel_nexps (Defs defs) = match nexp_map with | [] -> None | _ -> - let new_vars = List.map (fun (kid,nexp) -> QI_aux (QI_id (KOpt_aux (KOpt_none kid,Generated Unknown)), Generated tq_l)) nexp_map in + let new_vars = List.map (fun (kid,nexp) -> QI_aux (QI_id (mk_kopt K_int kid), Generated tq_l)) nexp_map in let new_constraints = List.map (fun (kid,nexp) -> QI_aux (QI_const (nc_eq (nvar kid) nexp), Generated tq_l)) nexp_map in let tqs = TypQ_aux (TypQ_tq (qs @ new_vars @ new_constraints),tq_l) in let vs = diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index f00a93b7..6dfc6191 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -595,9 +595,6 @@ let doc_lit (L_aux(lit,l)) = let doc_quant_item_id ctx delimit (QI_aux (qi,_)) = match qi with - | QI_id (KOpt_aux (KOpt_none kid,_)) -> - if KBindings.mem kid ctx.kid_id_renames then None else - Some (delimit (separate space [doc_var ctx kid; colon; string "Z"])) | QI_id (KOpt_aux (KOpt_kind (K_aux (kind,_),kid),_)) -> begin if KBindings.mem kid ctx.kid_id_renames then None else match kind with @@ -605,7 +602,6 @@ let doc_quant_item_id ctx delimit (QI_aux (qi,_)) = | K_int -> Some (delimit (separate space [doc_var ctx kid; colon; string "Z"])) | K_order -> None end - | QI_id _ -> failwith "Quantifier with multiple kinds" | QI_const nc -> None let doc_quant_item_constr ctx delimit (QI_aux (qi,_)) = @@ -1726,7 +1722,6 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = match td with let rectyp = match typq with | TypQ_aux (TypQ_tq qs, _) -> let quant_item = function - | QI_aux (QI_id (KOpt_aux (KOpt_none kid, _)), l) | QI_aux (QI_id (KOpt_aux (KOpt_kind (_, kid), _)), l) -> [A_aux (A_nexp (Nexp_aux (Nexp_var kid, l)), l)] | _ -> [] in diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index 1764ab92..6e2a2b55 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -412,7 +412,6 @@ let doc_lit_lem (L_aux(lit,l)) = (* typ_doc is the doc for the type being quantified *) let doc_quant_item vars_included (QI_aux (qi, _)) = match qi with -| QI_id (KOpt_aux (KOpt_none kid, _)) | QI_id (KOpt_aux (KOpt_kind (_, kid), _)) -> (match vars_included with None -> doc_var kid @@ -1020,7 +1019,6 @@ let doc_typdef_lem (TD_aux(td, (l, annot))) = match td with let rectyp = match typq with | TypQ_aux (TypQ_tq qs, _) -> let quant_item = function - | QI_aux (QI_id (KOpt_aux (KOpt_none kid, _)), l) | QI_aux (QI_id (KOpt_aux (KOpt_kind (_, kid), _)), l) -> [A_aux (A_nexp (Nexp_aux (Nexp_var kid, l)), l)] | _ -> [] in diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index f756f3d2..d779b3a7 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -195,7 +195,6 @@ and doc_arg_typs = function | typs -> parens (separate_map (comma ^^ space) doc_typ typs) let doc_kopt = function - | KOpt_aux (KOpt_none kid, _) -> doc_kid kid | kopt when is_nat_kopt kopt -> doc_kid (kopt_kid kopt) | kopt when is_typ_kopt kopt -> parens (separate space [doc_kid (kopt_kid kopt); colon; string "Type"]) | kopt -> parens (separate space [doc_kid (kopt_kid kopt); colon; string "Order"]) @@ -203,7 +202,6 @@ let doc_kopt = function let doc_quants quants = let doc_qi_kopt (QI_aux (qi_aux, _)) = match qi_aux with - | QI_id (KOpt_aux (KOpt_none kid, _)) -> [doc_kid kid] | QI_id kopt when is_nat_kopt kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Int"])] | QI_id kopt when is_typ_kopt kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Type"])] | QI_id kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Order"])] @@ -224,7 +222,6 @@ let doc_quants quants = let doc_param_quants quants = let doc_qi_kopt (QI_aux (qi_aux, _)) = match qi_aux with - | QI_id (KOpt_aux (KOpt_none kid, _)) -> [doc_kid kid] | QI_id kopt when is_nat_kopt kopt -> [doc_kid (kopt_kid kopt) ^^ colon ^^ space ^^ string "Int"] | QI_id kopt when is_typ_kopt kopt -> [doc_kid (kopt_kid kopt) ^^ colon ^^ space ^^ string "Type"] | QI_id kopt -> [doc_kid (kopt_kid kopt) ^^ colon ^^ space ^^ string "Order"] diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index 2ab64f1c..65614b8d 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -151,7 +151,6 @@ let typq_bindings (TypQ_aux(tq,_)) = match tq with match qi with | QI_id (KOpt_aux(k,_)) -> (match k with - | KOpt_none (Kid_aux (Var s,_)) -> Nameset.add s bounds | KOpt_kind (_, Kid_aux (Var s,_)) -> Nameset.add s bounds) | _ -> bounds) quants mt | TypQ_no_forall -> mt diff --git a/src/state.ml b/src/state.ml index 4fc2e1e8..c9a47b06 100644 --- a/src/state.ml +++ b/src/state.ml @@ -128,7 +128,7 @@ let generate_initial_regstate defs = | _ -> raise Not_found in let typ_subst_quant_item typ (QI_aux (qi, _)) arg = match qi with - | QI_id (KOpt_aux ((KOpt_none kid | KOpt_kind (_, kid)), _)) -> + | QI_id (KOpt_aux (KOpt_kind (_, kid), _)) -> typ_subst kid arg typ | _ -> typ in diff --git a/src/type_check.ml b/src/type_check.ml index 2f4561b5..f1d9b961 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -210,7 +210,6 @@ and strip_qi_aux = function and strip_kinded_id = function | KOpt_aux (kinded_id_aux, _) -> KOpt_aux (strip_kinded_id_aux kinded_id_aux, Parse_ast.Unknown) and strip_kinded_id_aux = function - | KOpt_none kid -> KOpt_none (strip_kid kid) | KOpt_kind (kind, kid) -> KOpt_kind (strip_kind kind, strip_kid kid) and strip_kind = function | K_aux (k_aux, _) -> K_aux (k_aux, Parse_ast.Unknown) @@ -1108,7 +1107,6 @@ let add_typquant l (quant : typquant) (env : Env.t) : Env.t = | QI_aux (qi, _) -> add_quant_item_aux env qi and add_quant_item_aux env = function | QI_const constr -> Env.add_constraint constr env - | QI_id (KOpt_aux (KOpt_none kid, _)) -> Env.add_typ_var l kid K_int env | QI_id (KOpt_aux (KOpt_kind (K_aux (k, _), kid), _)) -> Env.add_typ_var l kid k env in match quant with @@ -1823,7 +1821,6 @@ let infer_lit env (L_aux (lit_aux, l) as lit) = let is_nat_kid kid = function | KOpt_aux (KOpt_kind (K_aux (K_int, _), kid'), _) -> Kid.compare kid kid' = 0 - | KOpt_aux (KOpt_none kid', _) -> Kid.compare kid kid' = 0 | _ -> false let is_order_kid kid = function @@ -4228,12 +4225,14 @@ let check_default env (DT_aux (ds, l)) = let kinded_id_arg kind_id = let typ_arg arg = A_aux (arg, Parse_ast.Unknown) in match kind_id with - | KOpt_aux (KOpt_none kid, _) -> typ_arg (A_nexp (nvar kid)) - | KOpt_aux (KOpt_kind (K_aux (K_int, _), kid), _) -> typ_arg (A_nexp (nvar kid)) + | KOpt_aux (KOpt_kind (K_aux (K_int, _), kid), _) -> + typ_arg (A_nexp (nvar kid)) | KOpt_aux (KOpt_kind (K_aux (K_order, _), kid), _) -> typ_arg (A_order (Ord_aux (Ord_var kid, Parse_ast.Unknown))) | KOpt_aux (KOpt_kind (K_aux (K_type, _), kid), _) -> typ_arg (A_typ (mk_typ (Typ_var kid))) + | KOpt_aux (KOpt_kind (K_aux (K_bool, _), kid), _) -> + typ_arg (A_bool (nc_var kid)) let fold_union_quant quants (QI_aux (qi, l)) = match qi with @@ -4403,13 +4402,13 @@ let initial_env = |> Env.add_extern (mk_id "size_itself_int") (fun _ -> Some "size_itself_int") |> Env.add_val_spec (mk_id "size_itself_int") - (TypQ_aux (TypQ_tq [QI_aux (QI_id (KOpt_aux (KOpt_none (mk_kid "n"),Parse_ast.Unknown)), + (TypQ_aux (TypQ_tq [QI_aux (QI_id (mk_kopt K_int (mk_kid "n")), Parse_ast.Unknown)],Parse_ast.Unknown), function_typ [app_typ (mk_id "itself") [mk_typ_arg (A_nexp (nvar (mk_kid "n")))]] (atom_typ (nvar (mk_kid "n"))) no_effect) |> Env.add_extern (mk_id "make_the_value") (fun _ -> Some "make_the_value") |> Env.add_val_spec (mk_id "make_the_value") - (TypQ_aux (TypQ_tq [QI_aux (QI_id (KOpt_aux (KOpt_none (mk_kid "n"),Parse_ast.Unknown)), + (TypQ_aux (TypQ_tq [QI_aux (QI_id (mk_kopt K_int (mk_kid "n")), Parse_ast.Unknown)],Parse_ast.Unknown), function_typ [atom_typ (nvar (mk_kid "n"))] (app_typ (mk_id "itself") [mk_typ_arg (A_nexp (nvar (mk_kid "n")))]) no_effect) -- cgit v1.2.3 From ed5b58ba3a5a73253565edcb6460d2b48f56f887 Mon Sep 17 00:00:00 2001 From: Alasdair Date: Wed, 12 Dec 2018 03:42:10 +0000 Subject: Generalise existentials for non-integer type variables --- src/ast_util.ml | 63 ++++++++++++++++--- src/ast_util.mli | 19 ++++++ src/initial_check.ml | 4 +- src/monomorphise.ml | 53 +++++++++------- src/pretty_print_coq.ml | 41 ++++++------ src/pretty_print_lem.ml | 7 ++- src/pretty_print_sail.ml | 23 +++---- src/rewrites.ml | 2 +- src/spec_analysis.ml | 7 ++- src/specialize.ml | 16 ++--- src/type_check.ml | 161 +++++++++++++++++++++++++---------------------- src/type_check.mli | 14 ++--- 12 files changed, 249 insertions(+), 161 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index bd7a51bb..02e297cb 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -128,7 +128,7 @@ let mk_val_spec vs_aux = let kopt_kid (KOpt_aux (KOpt_kind (_, kid), _)) = kid let kopt_kind (KOpt_aux (KOpt_kind (k, _), _)) = k - + let is_nat_kopt = function | KOpt_aux (KOpt_kind (K_aux (K_int, _), _), _) -> true | _ -> false @@ -144,7 +144,7 @@ let is_typ_kopt = function let is_bool_kopt = function | KOpt_aux (KOpt_kind (K_aux (K_bool, _), _), _) -> true | _ -> false - + let string_of_kid = function | Kid_aux (Var v, _) -> v @@ -153,6 +153,27 @@ module Kid = struct let compare kid1 kid2 = String.compare (string_of_kid kid1) (string_of_kid kid2) end +module Kind = struct + type t = kind + let compare (K_aux (aux1, _)) (K_aux (aux2, _)) = + match aux1, aux2 with + | K_int, K_int -> 0 + | K_type, K_type -> 0 + | K_order, K_order -> 0 + | K_bool, K_bool -> 0 + | K_int, _ -> 1 | _, K_int -> -1 + | K_type, _ -> 1 | _, K_type -> -1 + | K_order, _ -> 1 | _, K_order -> -1 +end + +module KOpt = struct + type t = kinded_id + let compare kopt1 kopt2 = + let lex_ord c1 c2 = if c1 = 0 then c2 else c1 in + lex_ord (Kid.compare (kopt_kid kopt1) (kopt_kid kopt2)) + (Kind.compare (kopt_kind kopt1) (kopt_kind kopt2)) +end + module Id = struct type t = id let compare id1 id2 = @@ -200,6 +221,8 @@ module Bindings = Map.Make(Id) module IdSet = Set.Make(Id) module KBindings = Map.Make(Kid) module KidSet = Set.Make(Kid) +module KOptSet = Set.Make(KOpt) +module KOptMap = Map.Make(KOpt) module NexpSet = Set.Make(Nexp) module NexpMap = Map.Make(Nexp) @@ -389,6 +412,13 @@ let arg_order ?loc:(l=Parse_ast.Unknown) ord = A_aux (A_order ord, l) let arg_typ ?loc:(l=Parse_ast.Unknown) typ = A_aux (A_typ typ, l) let arg_bool ?loc:(l=Parse_ast.Unknown) nc = A_aux (A_bool nc, l) +let arg_kopt (KOpt_aux (KOpt_kind (K_aux (k, _), v), l)) = + match k with + | K_int -> arg_nexp (nvar v) + | K_order -> arg_order (Ord_aux (Ord_var v, l)) + | K_bool -> arg_bool (nc_var v) + | K_type -> arg_typ (mk_typ (Typ_var v)) + let nc_not nc = mk_nc (NC_app (mk_id "not", [arg_bool nc])) let mk_typschm typq typ = TypSchm_aux (TypSchm_ts (typq, typ), Parse_ast.Unknown) @@ -644,6 +674,9 @@ let string_of_kind_aux = function let string_of_kind (K_aux (k, _)) = string_of_kind_aux k +let string_of_kinded_id (KOpt_aux (KOpt_kind (k, kid), _)) = + "(" ^ string_of_kid kid ^ " : " ^ string_of_kind k ^ ")" + let string_of_base_effect = function | BE_aux (beff, _) -> string_of_base_effect_aux beff @@ -687,7 +720,7 @@ and string_of_typ_aux = function ^ string_of_typ typ_ret ^ " effect " ^ string_of_effect eff | Typ_bidir (typ1, typ2) -> string_of_typ typ1 ^ " <-> " ^ string_of_typ typ2 | Typ_exist (kids, nc, typ) -> - "{" ^ string_of_list " " string_of_kid kids ^ ", " ^ string_of_n_constraint nc ^ ". " ^ string_of_typ typ ^ "}" + "{" ^ string_of_list " " string_of_kinded_id kids ^ ", " ^ string_of_n_constraint nc ^ ". " ^ string_of_typ typ ^ "}" and string_of_typ_arg = function | A_aux (typ_arg, l) -> string_of_typ_arg_aux typ_arg and string_of_typ_arg_aux = function @@ -995,7 +1028,7 @@ module Typ = struct | n -> n) | Typ_tup ts1, Typ_tup ts2 -> Util.compare_list compare ts1 ts2 | Typ_exist (ks1,nc1,t1), Typ_exist (ks2,nc2,t2) -> - (match Util.compare_list Kid.compare ks1 ks2 with + (match Util.compare_list KOpt.compare ks1 ks2 with | 0 -> (match NC.compare nc1 nc2 with | 0 -> compare t1 t2 | n -> n) @@ -1016,8 +1049,10 @@ module Typ = struct | A_nexp n1, A_nexp n2 -> Nexp.compare n1 n2 | A_typ t1, A_typ t2 -> compare t1 t2 | A_order o1, A_order o2 -> order_compare o1 o2 + | A_bool nc1, A_bool nc2 -> NC.compare nc1 nc2 | A_nexp _, _ -> -1 | _, A_nexp _ -> 1 | A_typ _, _ -> -1 | _, A_typ _ -> 1 + | A_order _, _ -> -1 | _, A_order _ -> 1 end module TypMap = Map.Make(Typ) @@ -1179,7 +1214,7 @@ and tyvars_of_typ (Typ_aux (t,_)) = KidSet.empty tas | Typ_exist (kids, nc, t) -> let s = KidSet.union (tyvars_of_typ t) (tyvars_of_constraint nc) in - List.fold_left (fun s k -> KidSet.remove k s) s kids + List.fold_left (fun s k -> KidSet.remove k s) s (List.map kopt_kid kids) and tyvars_of_typ_arg (A_aux (ta,_)) = match ta with | A_nexp nexp -> tyvars_of_nexp nexp @@ -1387,6 +1422,11 @@ let locate_id f (Id_aux (name, l)) = Id_aux (name, f l) let locate_kid f (Kid_aux (name, l)) = Kid_aux (name, f l) +let locate_kind f (K_aux (kind, l)) = K_aux (kind, f l) + +let locate_kinded_id f (KOpt_aux (KOpt_kind (k, kid), l)) = + KOpt_aux (KOpt_kind (locate_kind f k, locate_kid f kid), f l) + let locate_lit f (L_aux (lit, l)) = L_aux (lit, f l) let locate_base_effect f (BE_aux (base_effect, l)) = BE_aux (base_effect, f l) @@ -1427,10 +1467,12 @@ let rec locate_nc f (NC_aux (nc_aux, l)) = | NC_and (nc1, nc2) -> NC_and (locate_nc f nc1, locate_nc f nc2) | NC_true -> NC_true | NC_false -> NC_false + | NC_var v -> NC_var (locate_kid f v) + | NC_app (id, args) -> NC_app (locate_id f id, List.map (locate_typ_arg f) args) in NC_aux (nc_aux, f l) -let rec locate_typ f (Typ_aux (typ_aux, l)) = +and locate_typ f (Typ_aux (typ_aux, l)) = let typ_aux = match typ_aux with | Typ_internal_unknown -> Typ_internal_unknown | Typ_id id -> Typ_id (locate_id f id) @@ -1439,7 +1481,7 @@ let rec locate_typ f (Typ_aux (typ_aux, l)) = Typ_fn (List.map (locate_typ f) arg_typs, locate_typ f ret_typ, locate_effect f effect) | Typ_bidir (typ1, typ2) -> Typ_bidir (locate_typ f typ1, locate_typ f typ2) | Typ_tup typs -> Typ_tup (List.map (locate_typ f) typs) - | Typ_exist (kids, constr, typ) -> Typ_exist (List.map (locate_kid f) kids, locate_nc f constr, locate_typ f typ) + | Typ_exist (kopts, constr, typ) -> Typ_exist (List.map (locate_kinded_id f) kopts, locate_nc f constr, locate_typ f typ) | Typ_app (id, typ_args) -> Typ_app (locate_id f id, List.map (locate_typ_arg f) typ_args) in Typ_aux (typ_aux, f l) @@ -1449,6 +1491,7 @@ and locate_typ_arg f (A_aux (typ_arg_aux, l)) = | A_nexp nexp -> A_nexp (locate_nexp f nexp) | A_typ typ -> A_typ (locate_typ f typ) | A_order ord -> A_order (locate_order f ord) + | A_bool nc -> A_bool (locate_nc f nc) in A_aux (typ_arg_aux, f l) @@ -1638,8 +1681,10 @@ and typ_subst_aux sv subst = function | Typ_bidir (typ1, typ2) -> Typ_bidir (typ_subst sv subst typ1, typ_subst sv subst typ2) | Typ_tup typs -> Typ_tup (List.map (typ_subst sv subst) typs) | Typ_app (f, args) -> Typ_app (f, List.map (typ_arg_subst sv subst) args) - | Typ_exist (kids, nc, typ) when KidSet.mem sv (KidSet.of_list kids) -> Typ_exist (kids, nc, typ) - | Typ_exist (kids, nc, typ) -> Typ_exist (kids, constraint_subst sv subst nc, typ_subst sv subst typ) + | Typ_exist (kopts, nc, typ) when KidSet.mem sv (KidSet.of_list (List.map kopt_kid kopts)) -> + Typ_exist (kopts, nc, typ) + | Typ_exist (kopts, nc, typ) -> + Typ_exist (kopts, constraint_subst sv subst nc, typ_subst sv subst typ) and typ_arg_subst sv subst (A_aux (arg, l)) = A_aux (typ_arg_subst_aux sv subst arg, l) and typ_arg_subst_aux sv subst = function diff --git a/src/ast_util.mli b/src/ast_util.mli index 8155acde..ca3a9598 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -180,6 +180,7 @@ val arg_nexp : ?loc:l -> nexp -> typ_arg val arg_order : ?loc:l -> order -> typ_arg val arg_typ : ?loc:l -> typ -> typ_arg val arg_bool : ?loc:l -> n_constraint -> typ_arg +val arg_kopt : kinded_id -> typ_arg (* Functions for working with type quantifiers *) val quant_add : quant_item -> typquant -> typquant @@ -260,6 +261,16 @@ module Kid : sig val compare : kid -> kid -> int end +module Kind : sig + type t = kind + val compare : kind -> kind -> int +end + +module KOpt : sig + type t = kinded_id + val compare : kinded_id -> kinded_id -> int +end + module Nexp : sig type t = nexp val compare : nexp -> nexp -> int @@ -288,6 +299,14 @@ module NexpMap : sig include Map.S with type key = nexp end +module KOptSet : sig + include Set.S with type elt = kinded_id +end + +module KOptMap : sig + include Map.S with type key = kinded_id +end + module BESet : sig include Set.S with type elt = base_effect end diff --git a/src/initial_check.ml b/src/initial_check.ml index 62f0dcf4..d394fde9 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -160,7 +160,7 @@ let rec to_ast_typ ctx (P.ATyp_aux (aux, l)) = | P.ATyp_exist (kids, nc, atyp) -> let kids = List.map to_ast_var kids in let ctx = { ctx with kinds = List.fold_left (fun kinds kid -> KBindings.add kid K_int kinds) ctx.kinds kids } in - Typ_exist (kids, to_ast_constraint ctx nc, to_ast_typ ctx atyp) + Typ_exist (List.map (mk_kopt K_int) kids, to_ast_constraint ctx nc, to_ast_typ ctx atyp) | P.ATyp_base (id, kind, nc) -> raise (Reporting.err_unreachable l __POS__ "TODO") | _ -> raise (Reporting.err_typ l "Invalid type") @@ -984,7 +984,7 @@ let generate_enum_functions vs_ids (Defs defs) = (* Create a function that converts from an enum to a number. *) let from_enum = let kid = mk_kid "e" in - let to_typ = mk_typ (Typ_exist ([kid], range_constraint kid, atom_typ (nvar kid))) in + let to_typ = mk_typ (Typ_exist ([mk_kopt K_int kid], range_constraint kid, atom_typ (nvar kid))) in let name = prepend_id "num_of_" id in let pexp n id = mk_pexp (Pat_exp (mk_pat (P_id id), mk_lit_exp (L_num (Big_int.of_int n)))) in let funcl = diff --git a/src/monomorphise.ml b/src/monomorphise.ml index 9206332d..0e362d3b 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -139,9 +139,9 @@ let subst_src_typ substs t = | Typ_bidir (t1, t2) -> re (Typ_bidir (s_styp substs t1, s_styp substs t2)) | Typ_tup ts -> re (Typ_tup (List.map (s_styp substs) ts)) | Typ_app (id,tas) -> re (Typ_app (id,List.map (s_starg substs) tas)) - | Typ_exist (kids,nc,t) -> - let substs = List.fold_left (fun sub v -> KBindings.remove v sub) substs kids in - re (Typ_exist (kids,nc,s_styp substs t)) + | Typ_exist (kopts,nc,t) -> + let substs = List.fold_left (fun sub kopt -> KBindings.remove (kopt_kid kopt) sub) substs kopts in + re (Typ_exist (kopts,nc,s_styp substs t)) | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" and s_starg substs (A_aux (ta,l) as targ) = match ta with @@ -330,13 +330,15 @@ let rec inst_src_type insts (Typ_aux (ty,l) as typ) = (fun arg (insts,args) -> let insts,arg = inst_src_typ_arg insts arg in insts,arg::args) args (insts,[]) in insts, Typ_aux (Typ_app (id,ts),l) - | Typ_exist (kids, nc, t) -> begin + | Typ_exist (kopts, nc, t) -> begin + (* TODO handle non-integer existentials *) + let kids = List.map kopt_kid kopts in let kid_insts, insts' = peel (kids,insts) in let kids', t' = apply_kid_insts kid_insts t in (* TODO: subst in nc *) match kids' with | [] -> insts', t' - | _ -> insts', Typ_aux (Typ_exist (kids', nc, t'), l) + | _ -> insts', Typ_aux (Typ_exist (List.map (mk_kopt K_int) kids', nc, t'), l) end | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" and inst_src_typ_arg insts (A_aux (ta,l) as tyarg) = @@ -408,7 +410,9 @@ let split_src_type id ty (TypQ_aux (q,ql)) = | Typ_app (_, tas) -> (KidSet.empty,[[],typ]) (* We only support sizes for bitvectors mentioned explicitly, not any buried inside another type *) - | Typ_exist (kids, nc, t) -> + | Typ_exist (kopts, nc, t) -> + (* TODO handle non integer existentials *) + let kids = List.map kopt_kid kopts in let (vars,tys) = size_nvars_ty t in let find_insts k (insts,nc) = let inst,nc' = @@ -426,7 +430,7 @@ let split_src_type id ty (TypQ_aux (q,ql)) = (* Typ_exist is not allowed an empty list of kids *) match kids with | [] -> ty - | _ -> Typ_aux (Typ_exist (kids, nc', ty),l) + | _ -> Typ_aux (Typ_exist (List.map (mk_kopt K_int) kids, nc', ty),l) in inst@inst0, ty in let tys = List.concat (List.map (fun instty -> List.map (ty_and_inst instty) insts) tys) in @@ -524,7 +528,9 @@ let refine_constructor refinements l env id args = let arg_ty = typ_of_args args in match Type_check.destruct_exist (Type_check.Env.expand_synonyms env constr_ty) with | None -> None - | Some (kids,nc,constr_ty) -> + | Some (kopts,nc,constr_ty) -> + (* TODO: Handle non-integer existentials *) + let kids = List.map kopt_kid kopts in let bindings = Type_check.unify l env (tyvars_of_typ constr_ty) constr_ty arg_ty in let find_kid kid = try Some (KBindings.find kid bindings) with Not_found -> None in let bindings = List.map find_kid kids in @@ -730,7 +736,8 @@ let fabricate_nexp l tannot = | Some (env,typ,_) -> match Type_check.destruct_exist (Type_check.Env.expand_synonyms env typ) with | None -> nint 32 - | Some (kids,nc,typ') -> fabricate_nexp_exist env l typ kids nc typ' + (* TODO: check this *) + | Some (kopts,nc,typ') -> fabricate_nexp_exist env l typ (List.map kopt_kid kopts) nc typ' let atom_typ_kid kid = function | Typ_aux (Typ_app (Id_aux (Id "atom",_), @@ -746,23 +753,23 @@ let reduce_cast typ exp l annot = let env = env_of_annot (l,annot) in let typ' = Env.base_typ_of env typ in match exp, destruct_exist (Env.expand_synonyms env typ') with - | E_aux (E_lit (L_aux (L_num n,_)),_), Some ([kid],nc,typ'') when atom_typ_kid kid typ'' -> - let nc_env = Env.add_typ_var l kid K_int env in - let nc_env = Env.add_constraint (nc_eq (nvar kid) (nconstant n)) nc_env in + | E_aux (E_lit (L_aux (L_num n,_)),_), Some ([kopt],nc,typ'') when atom_typ_kid (kopt_kid kopt) typ'' -> + let nc_env = Env.add_typ_var l kopt env in + let nc_env = Env.add_constraint (nc_eq (nvar (kopt_kid kopt)) (nconstant n)) nc_env in if prove nc_env nc then exp else raise (Reporting.err_unreachable l __POS__ ("Constant propagation error: literal " ^ Big_int.to_string n ^ " does not satisfy constraint " ^ string_of_n_constraint nc)) - | E_aux (E_lit (L_aux (L_undef,_)),_), Some ([kid],nc,typ'') when atom_typ_kid kid typ'' -> - let nexp = fabricate_nexp_exist env Unknown typ [kid] nc typ'' in - let newtyp = subst_src_typ (KBindings.singleton kid nexp) typ'' in + | E_aux (E_lit (L_aux (L_undef,_)),_), Some ([kopt],nc,typ'') when atom_typ_kid (kopt_kid kopt) typ'' -> + let nexp = fabricate_nexp_exist env Unknown typ [kopt_kid kopt] nc typ'' in + let newtyp = subst_src_typ (KBindings.singleton (kopt_kid kopt) nexp) typ'' in E_aux (E_cast (newtyp, exp), (Generated l,replace_typ newtyp annot)) | E_aux (E_cast (_, (E_aux (E_lit (L_aux (L_undef,_)),_) as exp)),_), - Some ([kid],nc,typ'') when atom_typ_kid kid typ'' -> - let nexp = fabricate_nexp_exist env Unknown typ [kid] nc typ'' in - let newtyp = subst_src_typ (KBindings.singleton kid nexp) typ'' in + Some ([kopt],nc,typ'') when atom_typ_kid (kopt_kid kopt) typ'' -> + let nexp = fabricate_nexp_exist env Unknown typ [kopt_kid kopt] nc typ'' in + let newtyp = subst_src_typ (KBindings.singleton (kopt_kid kopt) nexp) typ'' in E_aux (E_cast (newtyp, exp), (Generated l,replace_typ newtyp annot)) | _ -> E_aux (E_cast (typ,exp),(l,annot)) @@ -2185,8 +2192,8 @@ let rec sizes_of_typ (Typ_aux (t,l)) = "Function type on expression") | Typ_bidir _ -> raise (Reporting.err_general l "Mapping type on expression") | Typ_tup typs -> kidset_bigunion (List.map sizes_of_typ typs) - | Typ_exist (kids,_,typ) -> - List.fold_left (fun s k -> KidSet.remove k s) (sizes_of_typ typ) kids + | Typ_exist (kopts,_,typ) -> + List.fold_left (fun s k -> KidSet.remove (kopt_kid k) s) (sizes_of_typ typ) kopts | Typ_app (Id_aux (Id "vector",_), [A_aux (A_nexp size,_); _;A_aux (A_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_)]) -> @@ -3184,11 +3191,11 @@ let rec analyse_exp fn_id env assigns (E_aux (e,(l,annot)) as exp) = let env, tenv, typ = match destruct_exist (Env.expand_synonyms tenv typ) with | None -> env, tenv, typ - | Some (kids, nc, typ) -> + | Some (kopts, nc, typ) -> { env with kid_deps = - List.fold_left (fun kds kid -> KBindings.add kid deps kds) env.kid_deps kids }, + List.fold_left (fun kds kopt -> KBindings.add (kopt_kid kopt) deps kds) env.kid_deps kopts }, Env.add_constraint nc - (List.fold_left (fun tenv kid -> Env.add_typ_var l kid K_int tenv) tenv kids), + (List.fold_left (fun tenv kopt -> Env.add_typ_var l kopt tenv) tenv kopts), typ in if is_bitvector_typ typ then diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 6dfc6191..35aa9e20 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -277,7 +277,7 @@ let rec coq_nvars_of_typ (Typ_aux (t,l)) = List.fold_left (fun s ta -> KidSet.union s (coq_nvars_of_typ_arg ta)) KidSet.empty tas (* TODO: remove appropriate bound variables *) - | Typ_exist (kids,_,t) -> trec t + | Typ_exist (_,_,t) -> trec t | Typ_bidir _ -> unreachable l __POS__ "Coq doesn't support bidir types" | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" and coq_nvars_of_typ_arg (A_aux (ta,_)) = @@ -359,11 +359,11 @@ let maybe_expand_range_type (Typ_aux (typ,l) as full_typ) = let kid = mk_kid "rangevar" in let var = nvar kid in let nc = nc_and (nc_lteq low var) (nc_lteq var high) in - Some (Typ_aux (Typ_exist ([kid], nc, atom_typ var),Parse_ast.Generated l)) + Some (Typ_aux (Typ_exist ([mk_kopt K_int kid], nc, atom_typ var),Parse_ast.Generated l)) | Typ_id (Id_aux (Id "nat",_)) -> let kid = mk_kid "n" in let var = nvar kid in - Some (Typ_aux (Typ_exist ([kid], nc_gteq var (nconstant Nat_big_num.zero), atom_typ var), + Some (Typ_aux (Typ_exist ([mk_kopt K_int kid], nc_gteq var (nconstant Nat_big_num.zero), atom_typ var), Parse_ast.Generated l)) | _ -> None @@ -449,24 +449,25 @@ let doc_typ, doc_atomic_typ = * if we add a new Typ constructor *) let tpp = typ ty in if atyp_needed then parens tpp else tpp - | Typ_exist (kids,nc,ty') -> begin - let kids,nc,ty' = match maybe_expand_range_type ty' with - | Some (Typ_aux (Typ_exist (kids',nc',ty'),_)) -> - kids'@kids,nc_and nc nc',ty' - | _ -> kids,nc,ty' + (* TODO: handle non-integer kopts *) + | Typ_exist (kopts,nc,ty') -> begin + let kopts,nc,ty' = match maybe_expand_range_type ty' with + | Some (Typ_aux (Typ_exist (kopts',nc',ty'),_)) -> + kopts'@kopts,nc_and nc nc',ty' + | _ -> kopts,nc,ty' in match ty' with | Typ_aux (Typ_app (Id_aux (Id "atom",_), [A_aux (A_nexp nexp,_)]),_) -> - begin match nexp, kids with - | (Nexp_aux (Nexp_var kid,_)), [kid'] when Kid.compare kid kid' == 0 -> + begin match nexp, kopts with + | (Nexp_aux (Nexp_var kid,_)), [kopt] when Kid.compare kid (kopt_kid kopt) == 0 -> braces (separate space [doc_var ctx kid; colon; string "Z"; ampersand; doc_arithfact ctx nc]) | _ -> let var = mk_kid "_atom" in (* TODO collision avoid *) let nc = nice_and (nc_eq (nvar var) nexp) nc in braces (separate space [doc_var ctx var; colon; string "Z"; - ampersand; doc_arithfact ctx ~exists:kids nc]) + ampersand; doc_arithfact ctx ~exists:(List.map kopt_kid kopts) nc]) end | Typ_aux (Typ_app (Id_aux (Id "vector",_), [A_aux (A_nexp m, _); @@ -474,7 +475,7 @@ let doc_typ, doc_atomic_typ = A_aux (A_typ elem_typ, _)]),_) -> (* TODO: proper handling of m, complex elem type, dedup with above *) let var = mk_kid "_vec" in (* TODO collision avoid *) - let kid_set = KidSet.of_list kids in + let kid_set = KidSet.of_list (List.map kopt_kid kopts) in let m_pp = doc_nexp ctx ~skip_vars:kid_set m in let tpp, len_pp = match elem_typ with | Typ_aux (Typ_id (Id_aux (Id "bit",_)),_) -> @@ -489,7 +490,7 @@ let doc_typ, doc_atomic_typ = braces (separate space [doc_var ctx var; colon; tpp; ampersand; - doc_arithfact ctx ~exists:kids ?extra:length_constraint_pp nc]) + doc_arithfact ctx ~exists:(List.map kopt_kid kopts) ?extra:length_constraint_pp nc]) | _ -> raise (Reporting.err_todo l ("Non-atom existential type not yet supported in Coq: " ^ @@ -858,7 +859,7 @@ let replace_atom_return_type ret_typ = match ret_typ with | Typ_aux (Typ_app (Id_aux (Id "atom",_), [A_aux (A_nexp nexp,_)]),l) -> let kid = mk_kid "_retval" in (* TODO: collision avoidance *) - true, Typ_aux (Typ_exist ([kid], nc_eq (nvar kid) nexp, atom_typ (nvar kid)),Parse_ast.Generated l) + true, Typ_aux (Typ_exist ([mk_kopt K_int kid], nc_eq (nvar kid) nexp, atom_typ (nvar kid)),Parse_ast.Generated l) | _ -> false, ret_typ let is_range_from_atom env (Typ_aux (argty,_)) (Typ_aux (fnty,_)) = @@ -2031,15 +2032,15 @@ let doc_funcl (FCL_aux(FCL_Funcl(id, pexp), annot)) = when not (is_enum env id) -> begin let full_typ = (expand_range_type exp_typ) in match destruct_exist (Env.expand_synonyms env full_typ) with - | Some ([kid], NC_aux (NC_true,_), + | Some ([kopt], NC_aux (NC_true,_), Typ_aux (Typ_app (Id_aux (Id "atom",_), - [A_aux (A_nexp (Nexp_aux (Nexp_var kid',_)),_)]),_)) - when Kid.compare kid kid' == 0 -> + [A_aux (A_nexp (Nexp_aux (Nexp_var kid,_)),_)]),_)) + when Kid.compare (kopt_kid kopt) kid == 0 -> parens (separate space [doc_id id; colon; string "Z"]) - | Some ([kid], nc, + | Some ([kopt], nc, Typ_aux (Typ_app (Id_aux (Id "atom",_), - [A_aux (A_nexp (Nexp_aux (Nexp_var kid',_)),_)]),_)) - when Kid.compare kid kid' == 0 -> + [A_aux (A_nexp (Nexp_aux (Nexp_var kid,_)),_)]),_)) + when Kid.compare (kopt_kid kopt) kid == 0 -> (used_a_pattern := true; squote ^^ parens (separate space [string "existT"; underscore; doc_id id; underscore; colon; doc_typ ctxt typ])) | _ -> diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index 6e2a2b55..ac0195aa 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -313,7 +313,8 @@ let doc_typ_lem, doc_atomic_typ_lem = * if we add a new Typ constructor *) let tpp = typ ty in if atyp_needed then parens tpp else tpp - | Typ_exist (kids,_,ty) -> begin + | Typ_exist (kopts,_,ty) when List.for_all is_nat_kopt kopts -> begin + let kids = List.map kopt_kid kopts in let tpp = typ ty in let visible_vars = lem_tyvars_of_typ ty in match List.filter (fun kid -> KidSet.mem kid visible_vars) kids with @@ -323,6 +324,7 @@ let doc_typ_lem, doc_atomic_typ_lem = String.concat ", " (List.map string_of_kid bad) ^ " escape into Lem")) end + | Typ_exist _ -> unreachable l __POS__ "Non-integer existentials currently unsupported in Lem" (* TODO *) | Typ_bidir _ -> unreachable l __POS__ "Lem doesn't support bidir types" | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" and doc_typ_arg_lem (A_aux(t,_)) = match t with @@ -528,7 +530,8 @@ let rec typ_needs_printed (Typ_aux (t,_) as typ) = match t with | Typ_app (Id_aux (Id "itself",_),_) -> true | Typ_app (_, targs) -> is_bitvector_typ typ || List.exists typ_needs_printed_arg targs | Typ_fn (ts,t,_) -> List.exists typ_needs_printed ts || typ_needs_printed t - | Typ_exist (kids,_,t) -> + | Typ_exist (kopts,_,t) -> + let kids = List.map kopt_kid kopts in (* TODO: Check this *) let visible_kids = KidSet.inter (KidSet.of_list kids) (lem_tyvars_of_typ t) in typ_needs_printed t && KidSet.is_empty visible_kids | _ -> false diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index d779b3a7..e0223105 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -65,6 +65,12 @@ let doc_id (Id_aux (id_aux, _)) = let doc_kid kid = string (Ast_util.string_of_kid kid) +let doc_kopt = function + | kopt when is_nat_kopt kopt -> doc_kid (kopt_kid kopt) + | kopt when is_typ_kopt kopt -> parens (separate space [doc_kid (kopt_kid kopt); colon; string "Type"]) + | kopt when is_order_kopt kopt -> parens (separate space [doc_kid (kopt_kid kopt); colon; string "Order"]) + | kopt -> parens (separate space [doc_kid (kopt_kid kopt); colon; string "Bool"]) + let doc_int n = string (Big_int.to_string n) let docstring (l, _) = match l with @@ -166,13 +172,13 @@ and doc_typ ?(simple=false) (Typ_aux (typ_aux, l)) = | Typ_tup typs -> parens (separate_map (string ", ") doc_typ typs) | Typ_var kid -> doc_kid kid (* Resugar set types like {|1, 2, 3|} *) - | Typ_exist ([kid1], - NC_aux (NC_set (kid2, ints), _), - Typ_aux (Typ_app (id, [A_aux (A_nexp (Nexp_aux (Nexp_var kid3, _)), _)]), _)) - when Kid.compare kid1 kid2 == 0 && Kid.compare kid2 kid3 == 0 && Id.compare (mk_id "atom") id == 0 -> + | Typ_exist ([kopt], + NC_aux (NC_set (kid1, ints), _), + Typ_aux (Typ_app (id, [A_aux (A_nexp (Nexp_aux (Nexp_var kid2, _)), _)]), _)) + when Kid.compare (kopt_kid kopt) kid1 == 0 && Kid.compare kid1 kid2 == 0 && Id.compare (mk_id "atom") id == 0 -> enclose (string "{|") (string "|}") (separate_map (string ", ") doc_int ints) - | Typ_exist (kids, nc, typ) -> - braces (separate_map space doc_kid kids ^^ comma ^^ space ^^ doc_nc nc ^^ dot ^^ space ^^ doc_typ typ) + | Typ_exist (kopts, nc, typ) -> + braces (separate_map space doc_kopt kopts ^^ comma ^^ space ^^ doc_nc nc ^^ dot ^^ space ^^ doc_typ typ) | Typ_fn (typs, typ, Effect_aux (Effect_set [], _)) -> separate space [doc_arg_typs typs; string "->"; doc_typ typ] | Typ_fn (typs, typ, Effect_aux (Effect_set effs, _)) -> @@ -194,11 +200,6 @@ and doc_arg_typs = function | [typ] -> doc_typ typ | typs -> parens (separate_map (comma ^^ space) doc_typ typs) -let doc_kopt = function - | kopt when is_nat_kopt kopt -> doc_kid (kopt_kid kopt) - | kopt when is_typ_kopt kopt -> parens (separate space [doc_kid (kopt_kid kopt); colon; string "Type"]) - | kopt -> parens (separate space [doc_kid (kopt_kid kopt); colon; string "Order"]) - let doc_quants quants = let doc_qi_kopt (QI_aux (qi_aux, _)) = match qi_aux with diff --git a/src/rewrites.ml b/src/rewrites.ml index d8f1af75..79b5f619 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -3745,7 +3745,7 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = (* Bind the loop variable in the body, annotated with constraints *) let lvar_kid = mk_kid ("loop_" ^ string_of_id id) in let lvar_nc = nc_and constr (nc_and (nc_lteq lower (nvar lvar_kid)) (nc_lteq (nvar lvar_kid) upper)) in - let lvar_typ = mk_typ (Typ_exist (lvar_kid :: kids, lvar_nc, atom_typ (nvar lvar_kid))) in + let lvar_typ = mk_typ (Typ_exist (List.map (mk_kopt K_int) (lvar_kid :: kids), lvar_nc, atom_typ (nvar lvar_kid))) in let lvar_pat = unaux_pat (add_p_typ lvar_typ (annot_pat (P_var ( annot_pat (P_id id) el env (atom_typ (nvar lvar_kid)), TP_aux (TP_var lvar_kid, gen_loc el))) el env lvar_typ)) in diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index 65614b8d..0f8db0ff 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -94,7 +94,7 @@ let rec free_type_names_t consider_var (Typ_aux (t, l)) = match t with (free_type_names_t consider_var t2) | Typ_tup ts -> free_type_names_ts consider_var ts | Typ_app (name,targs) -> Nameset.add (string_of_id name) (free_type_names_t_args consider_var targs) - | Typ_exist (kids,_,t') -> List.fold_left (fun s kid -> Nameset.remove (string_of_kid kid) s) (free_type_names_t consider_var t') kids + | Typ_exist (kopts,_,t') -> List.fold_left (fun s kopt -> Nameset.remove (string_of_kid (kopt_kid kopt)) s) (free_type_names_t consider_var t') kopts | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" and free_type_names_ts consider_var ts = nameset_bigunion (List.map (free_type_names_t consider_var) ts) and free_type_names_maybe_t consider_var = function @@ -126,7 +126,10 @@ let rec fv_of_typ consider_var bound used (Typ_aux (t,l)) : Nameset.t = | Typ_tup ts -> List.fold_right (fun t n -> fv_of_typ consider_var bound n t) ts used | Typ_app(id,targs) -> List.fold_right (fun ta n -> fv_of_targ consider_var bound n ta) targs (conditional_add_typ bound used id) - | Typ_exist (kids,_,t') -> fv_of_typ consider_var (List.fold_left (fun b (Kid_aux (Var v,_)) -> Nameset.add v b) bound kids) used t' + | Typ_exist (kopts,_,t') -> + fv_of_typ consider_var + (List.fold_left (fun b (KOpt_aux (KOpt_kind (_, (Kid_aux (Var v,_))), _)) -> Nameset.add v b) bound kopts) + used t' | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" and fv_of_targ consider_var bound used (Ast.A_aux(targ,_)) : Nameset.t = match targ with diff --git a/src/specialize.ml b/src/specialize.ml index 583de600..1ba57bd0 100644 --- a/src/specialize.ml +++ b/src/specialize.ml @@ -100,13 +100,13 @@ let rec polymorphic_functions is_kopt (Defs defs) = let string_of_instantiation instantiation = let open Type_check in - let kid_names = ref KBindings.empty in + let kid_names = ref KOptMap.empty in let kid_counter = ref 0 in let kid_name kid = - try KBindings.find kid !kid_names with + try KOptMap.find kid !kid_names with | Not_found -> begin let n = string_of_int !kid_counter in - kid_names := KBindings.add kid n !kid_names; + kid_names := KOptMap.add kid n !kid_names; incr kid_counter; n end @@ -117,7 +117,7 @@ let string_of_instantiation instantiation = | Nexp_aux (nexp, _) -> string_of_nexp_aux nexp and string_of_nexp_aux = function | Nexp_id id -> string_of_id id - | Nexp_var kid -> kid_name kid + | Nexp_var kid -> kid_name (mk_kopt K_int kid) | Nexp_constant c -> Big_int.to_string c | Nexp_times (n1, n2) -> "(" ^ string_of_nexp n1 ^ " * " ^ string_of_nexp n2 ^ ")" | Nexp_sum (n1, n2) -> "(" ^ string_of_nexp n1 ^ " + " ^ string_of_nexp n2 ^ ")" @@ -131,7 +131,7 @@ let string_of_instantiation instantiation = | Typ_aux (typ, l) -> string_of_typ_aux typ and string_of_typ_aux = function | Typ_id id -> string_of_id id - | Typ_var kid -> kid_name kid + | Typ_var kid -> kid_name (mk_kopt K_type kid) | Typ_tup typs -> "(" ^ Util.string_of_list ", " string_of_typ typs ^ ")" | Typ_app (id, args) -> string_of_id id ^ "(" ^ Util.string_of_list ", " string_of_typ_arg args ^ ")" | Typ_fn (arg_typs, ret_typ, eff) -> @@ -158,7 +158,7 @@ let string_of_instantiation instantiation = | NC_aux (NC_and (nc1, nc2), _) -> "(" ^ string_of_n_constraint nc1 ^ " & " ^ string_of_n_constraint nc2 ^ ")" | NC_aux (NC_set (kid, ns), _) -> - kid_name kid ^ " in {" ^ Util.string_of_list ", " Big_int.to_string ns ^ "}" + kid_name (mk_kopt K_int kid) ^ " in {" ^ Util.string_of_list ", " Big_int.to_string ns ^ "}" | NC_aux (NC_true, _) -> "true" | NC_aux (NC_false, _) -> "false" in @@ -249,7 +249,7 @@ let rec typ_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) = | Typ_var kid -> KidSet.singleton kid | Typ_tup typs -> List.fold_left KidSet.union KidSet.empty (List.map (typ_frees ~exs:exs) typs) | Typ_app (f, args) -> List.fold_left KidSet.union KidSet.empty (List.map (typ_arg_frees ~exs:exs) args) - | Typ_exist (kids, nc, typ) -> typ_frees ~exs:(KidSet.of_list kids) typ + | Typ_exist (kopts, nc, typ) -> typ_frees ~exs:(KidSet.of_list (List.map kopt_kid kopts)) typ | Typ_fn (arg_typs, ret_typ, _) -> List.fold_left KidSet.union (typ_frees ~exs:exs ret_typ) (List.map (typ_frees ~exs:exs) arg_typs) | Typ_bidir (t1, t2) -> KidSet.union (typ_frees ~exs:exs t1) (typ_frees ~exs:exs t2) @@ -266,7 +266,7 @@ let rec typ_int_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) = | Typ_var kid -> KidSet.empty | Typ_tup typs -> List.fold_left KidSet.union KidSet.empty (List.map (typ_int_frees ~exs:exs) typs) | Typ_app (f, args) -> List.fold_left KidSet.union KidSet.empty (List.map (typ_arg_int_frees ~exs:exs) args) - | Typ_exist (kids, nc, typ) -> typ_int_frees ~exs:(KidSet.of_list kids) typ + | Typ_exist (kopts, nc, typ) -> typ_int_frees ~exs:(KidSet.of_list (List.map kopt_kid kopts)) typ | Typ_fn (arg_typs, ret_typ, _) -> List.fold_left KidSet.union (typ_int_frees ~exs:exs ret_typ) (List.map (typ_int_frees ~exs:exs) arg_typs) | Typ_bidir (t1, t2) -> KidSet.union (typ_int_frees ~exs:exs t1) (typ_int_frees ~exs:exs t2) diff --git a/src/type_check.ml b/src/type_check.ml index f1d9b961..5774a46f 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -194,7 +194,8 @@ and strip_typ_aux : typ_aux -> typ_aux = function | Typ_fn (arg_typs, ret_typ, effect) -> Typ_fn (List.map strip_typ arg_typs, strip_typ ret_typ, strip_effect effect) | Typ_bidir (typ1, typ2) -> Typ_bidir (strip_typ typ1, strip_typ typ2) | Typ_tup typs -> Typ_tup (List.map strip_typ typs) - | Typ_exist (kids, constr, typ) -> Typ_exist ((List.map strip_kid kids), strip_n_constraint constr, strip_typ typ) + | Typ_exist (kopts, constr, typ) -> + Typ_exist ((List.map strip_kinded_id kopts), strip_n_constraint constr, strip_typ typ) | Typ_app (id, args) -> Typ_app (strip_id id, List.map strip_typ_arg args) and strip_typ : typ -> typ = function | Typ_aux (typ_aux, _) -> Typ_aux (strip_typ_aux typ_aux, Parse_ast.Unknown) @@ -216,17 +217,21 @@ and strip_kind = function let ex_counter = ref 0 -let fresh_existential ?name:(n="") () = +let fresh_existential ?name:(n="") k = let fresh = Kid_aux (Var ("'ex" ^ string_of_int !ex_counter ^ "#" ^ n), Parse_ast.Unknown) in - incr ex_counter; fresh + incr ex_counter; mk_kopt k fresh let destruct_exist' typ = match typ with - | Typ_aux (Typ_exist (kids, nc, typ), _) -> - let fresh_kids = List.map (fun kid -> (kid, fresh_existential ~name:(string_of_id (id_of_kid kid)) ())) kids in - let nc = List.fold_left (fun nc (kid, fresh) -> constraint_subst kid (arg_nexp (nvar fresh)) nc) nc fresh_kids in - let typ = List.fold_left (fun typ (kid, fresh) -> typ_subst kid (arg_nexp (nvar fresh)) typ) typ fresh_kids in - Some (List.map snd fresh_kids, nc, typ) + | Typ_aux (Typ_exist (kopts, nc, typ), _) -> + let fresh_kopts = + List.map (fun kopt -> (kopt_kid kopt, + fresh_existential ~name:(string_of_id (id_of_kid (kopt_kid kopt))) (unaux_kind (kopt_kind kopt)))) + kopts + in + let nc = List.fold_left (fun nc (kid, fresh) -> constraint_subst kid (arg_kopt fresh) nc) nc fresh_kopts in + let typ = List.fold_left (fun typ (kid, fresh) -> typ_subst kid (arg_kopt fresh) typ) typ fresh_kopts in + Some (List.map snd fresh_kopts, nc, typ) | _ -> None (** Destructure and canonicalise a numeric type into a list of type @@ -240,23 +245,23 @@ let destruct_exist' typ = let destruct_numeric typ = match destruct_exist' typ, typ with | Some (kids, nc, Typ_aux (Typ_app (id, [A_aux (A_nexp nexp, _)]), _)), _ when string_of_id id = "atom" -> - Some (kids, nc, nexp) + Some (List.map kopt_kid kids, nc, nexp) | None, Typ_aux (Typ_app (id, [A_aux (A_nexp nexp, _)]), _) when string_of_id id = "atom" -> Some ([], nc_true, nexp) | None, Typ_aux (Typ_app (id, [A_aux (A_nexp lo, _); A_aux (A_nexp hi, _)]), _) when string_of_id id = "range" -> - let kid = fresh_existential () in + let kid = kopt_kid (fresh_existential K_int) in Some ([kid], nc_and (nc_lteq lo (nvar kid)) (nc_lteq (nvar kid) hi), nvar kid) | None, Typ_aux (Typ_id id, _) when string_of_id id = "nat" -> - let kid = fresh_existential () in + let kid = kopt_kid (fresh_existential K_int) in Some ([kid], nc_lteq (nint 0) (nvar kid), nvar kid) | None, Typ_aux (Typ_id id, _) when string_of_id id = "int" -> - let kid = fresh_existential () in + let kid = kopt_kid (fresh_existential K_int) in Some ([kid], nc_true, nvar kid) | _, _ -> None let destruct_exist typ = match destruct_numeric typ with - | Some (kids, nc, nexp) -> Some (kids, nc, atom_typ nexp) + | Some (kids, nc, nexp) -> Some (List.map (mk_kopt K_int) kids, nc, atom_typ nexp) | None -> destruct_exist' typ @@ -303,7 +308,7 @@ module Env : sig val get_typ_var_loc : kid -> t -> Ast.l val get_typ_vars : t -> kind_aux KBindings.t val get_typ_var_locs : t -> Ast.l KBindings.t - val add_typ_var : l -> kid -> kind_aux -> t -> t + val add_typ_var : l -> kinded_id -> t -> t val get_ret_typ : t -> typ option val add_ret_typ : typ -> t -> t val add_typ_synonym : id -> (t -> typ_arg list -> typ_arg) -> t -> t @@ -545,7 +550,7 @@ end = struct end with | Not_found -> Typ_aux (Typ_id id, l)) - | Typ_exist (kids, nc, typ) -> + | Typ_exist (kopts, nc, typ) -> (* When expanding an existential synonym we need to take care to add the type variables and constraints to the environment, so we can check constraints attached to type @@ -554,24 +559,27 @@ end = struct scope while doing this. *) let rebindings = ref [] in - let rename_kid kid = if KBindings.mem kid env.typ_vars then prepend_kid "syn#" kid else kid in - let add_typ_var env kid = + let rename_kopt (KOpt_aux (KOpt_kind (k, kid), l) as kopt) = + if KBindings.mem kid env.typ_vars then + KOpt_aux (KOpt_kind (k, prepend_kid "syn#" kid), l) + else kopt + in + let add_typ_var env (KOpt_aux (KOpt_kind (k, kid), l) as kopt) = try let (l, _) = KBindings.find kid env.typ_vars in rebindings := kid :: !rebindings; - { env with typ_vars = KBindings.add (prepend_kid "syn#" kid) (l, K_int) env.typ_vars } + { env with typ_vars = KBindings.add (prepend_kid "syn#" kid) (l, unaux_kind k) env.typ_vars } with | Not_found -> - { env with typ_vars = KBindings.add kid (l, K_int) env.typ_vars } + { env with typ_vars = KBindings.add kid (l, unaux_kind k) env.typ_vars } in - let env = List.fold_left add_typ_var env kids in - let kids = List.map rename_kid kids in + let env = List.fold_left add_typ_var env kopts in + let kopts = List.map rename_kopt kopts in let nc = List.fold_left (fun nc kid -> constraint_subst kid (arg_nexp (nvar (prepend_kid "syn#" kid))) nc) nc !rebindings in let typ = List.fold_left (fun typ kid -> typ_subst kid (arg_nexp (nvar (prepend_kid "syn#" kid))) typ) typ !rebindings in - typ_debug (lazy ("Synonym existential: {" ^ string_of_list " " string_of_kid kids ^ ", " ^ string_of_n_constraint nc ^ ". " ^ string_of_typ typ ^ "}")); let env = { env with constraints = nc :: env.constraints } in - Typ_aux (Typ_exist (kids, nc, expand_synonyms env typ), l) + Typ_aux (Typ_exist (kopts, nc, expand_synonyms env typ), l) | Typ_var v -> Typ_aux (Typ_var v, l) and expand_synonyms_arg env (A_aux (typ_arg, l)) = match typ_arg with @@ -623,9 +631,9 @@ end = struct check_args_typquant id env args (infer_kind env id) | Typ_app (id, _) -> typ_error l ("Undefined type " ^ string_of_id id) | Typ_exist ([], _, _) -> typ_error l ("Existential must have some type variables") - | Typ_exist (kids, nc, typ) when KidSet.is_empty exs -> - wf_constraint ~exs:(KidSet.of_list kids) env nc; - wf_typ ~exs:(KidSet.of_list kids) { env with constraints = nc :: env.constraints } typ + | Typ_exist (kopts, nc, typ) when KidSet.is_empty exs -> + wf_constraint ~exs:(KidSet.of_list (List.map kopt_kid kopts)) env nc; + wf_typ ~exs:(KidSet.of_list (List.map kopt_kid kopts)) { env with constraints = nc :: env.constraints } typ | Typ_exist (_, _, _) -> typ_error l ("Nested existentials are not allowed") | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" and wf_typ_arg ?exs:(exs=KidSet.empty) env (A_aux (typ_arg_aux, _)) = @@ -748,7 +756,7 @@ end = struct let existential_arg typq = function | None -> typq | Some (exs, nc, _) -> - List.fold_left (fun typq kid -> quant_add (mk_qi_id K_int kid) typq) (quant_add (mk_qi_nc nc) typq) exs + List.fold_left (fun typq kopt -> quant_add (mk_qi_kopt kopt) typq) (quant_add (mk_qi_nc nc) typq) exs in let typq = List.fold_left existential_arg typq base_args in let arg_typs = List.map2 (fun typ -> function Some (_, _, typ) -> typ | None -> typ) arg_typs base_args in @@ -999,9 +1007,9 @@ end = struct with | Not_found -> Unbound - let add_typ_var l kid k env = + let add_typ_var l (KOpt_aux (KOpt_kind (K_aux (k, _), kid), _) as kopt) env = if KBindings.mem kid env.typ_vars - then typ_error (kid_loc kid) ("type variable " ^ string_of_kid kid ^ " is already bound") + then typ_error (kid_loc kid) ("type variable " ^ string_of_kinded_id kopt ^ " is already bound") else begin typ_print (lazy (adding ^ "type variable " ^ string_of_kid kid ^ " : " ^ string_of_kind_aux k)); @@ -1107,7 +1115,7 @@ let add_typquant l (quant : typquant) (env : Env.t) : Env.t = | QI_aux (qi, _) -> add_quant_item_aux env qi and add_quant_item_aux env = function | QI_const constr -> Env.add_constraint constr env - | QI_id (KOpt_aux (KOpt_kind (K_aux (k, _), kid), _)) -> Env.add_typ_var l kid k env + | QI_id kopt -> Env.add_typ_var l kopt env in match quant with | TypQ_aux (TypQ_no_forall, _) -> env @@ -1123,24 +1131,24 @@ let default_order_error_string = let dvector_typ env n typ = vector_typ n (Env.get_default_order env) typ -let add_existential l kids nc env = - let env = List.fold_left (fun env kid -> Env.add_typ_var l kid K_int env) env kids in +let add_existential l kopts nc env = + let env = List.fold_left (fun env kopt -> Env.add_typ_var l kopt env) env kopts in Env.add_constraint nc env -let add_typ_vars l kids env = List.fold_left (fun env kid -> Env.add_typ_var l kid K_int env) env kids +let add_typ_vars l kopts env = List.fold_left (fun env kopt -> Env.add_typ_var l kopt env) env kopts let is_exist = function | Typ_aux (Typ_exist (_, _, _), _) -> true | _ -> false let exist_typ constr typ = - let fresh_kid = fresh_existential () in - mk_typ (Typ_exist ([fresh_kid], constr fresh_kid, typ fresh_kid)) + let fresh = fresh_existential K_int in + mk_typ (Typ_exist ([fresh], constr (kopt_kid fresh), typ (kopt_kid fresh))) let bind_numeric l typ env = match destruct_numeric (Env.expand_synonyms env typ) with | Some (kids, nc, nexp) -> - nexp, add_existential l kids nc env + nexp, add_existential l (List.map (mk_kopt K_int) kids) nc env | None -> typ_error l ("Expected " ^ string_of_typ typ ^ " to be numeric") (** Pull an (potentially)-existentially qualified type into the global @@ -1151,14 +1159,14 @@ let bind_existential l typ env = | None -> typ, env let destruct_range env typ = - let kids, constr, (Typ_aux (typ_aux, _)) = + let kopts, constr, (Typ_aux (typ_aux, _)) = Util.option_default ([], nc_true, typ) (destruct_exist (Env.expand_synonyms env typ)) in match typ_aux with | Typ_app (f, [A_aux (A_nexp n, _)]) - when string_of_id f = "atom" -> Some (kids, constr, n, n) + when string_of_id f = "atom" -> Some (List.map kopt_kid kopts, constr, n, n) | Typ_app (f, [A_aux (A_nexp n1, _); A_aux (A_nexp n2, _)]) - when string_of_id f = "range" -> Some (kids, constr, n1, n2) + when string_of_id f = "range" -> Some (List.map kopt_kid kopts, constr, n1, n2) | _ -> None let destruct_vector env typ = @@ -1312,7 +1320,7 @@ let rec typ_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) = | Typ_var kid -> KidSet.singleton kid | Typ_tup typs -> List.fold_left KidSet.union KidSet.empty (List.map (typ_frees ~exs:exs) typs) | Typ_app (f, args) -> List.fold_left KidSet.union KidSet.empty (List.map (typ_arg_frees ~exs:exs) args) - | Typ_exist (kids, nc, typ) -> typ_frees ~exs:(KidSet.of_list kids) typ + | Typ_exist (kopts, nc, typ) -> typ_frees ~exs:(KidSet.of_list (List.map kopt_kid kopts)) typ | Typ_fn (arg_typs, ret_typ, _) -> List.fold_left KidSet.union (typ_frees ~exs:exs ret_typ) (List.map (typ_frees ~exs:exs) arg_typs) | Typ_bidir (typ1, typ2) -> KidSet.union (typ_frees ~exs:exs typ1) (typ_frees ~exs:exs typ2) and typ_arg_frees ?exs:(exs=KidSet.empty) (A_aux (typ_arg_aux, l)) = @@ -1379,8 +1387,8 @@ let typ_identical env typ1 typ2 = try Id.compare f1 f2 = 0 && List.for_all2 typ_arg_identical args1 args2 with | Invalid_argument _ -> false end - | Typ_exist (kids1, nc1, typ1), Typ_exist (kids2, nc2, typ2) when List.length kids1 = List.length kids2 -> - List.for_all2 (fun k1 k2 -> Kid.compare k1 k2 = 0) kids1 kids2 && nc_identical nc1 nc2 && typ_identical' typ1 typ2 + | Typ_exist (kopts1, nc1, typ1), Typ_exist (kopts2, nc2, typ2) when List.length kopts1 = List.length kopts2 -> + List.for_all2 (fun k1 k2 -> KOpt.compare k1 k2 = 0) kopts1 kopts2 && nc_identical nc1 nc2 && typ_identical' typ1 typ2 | _, _ -> false and typ_arg_identical (A_aux (arg1, _)) (A_aux (arg2, _)) = match arg1, arg2 with @@ -1573,26 +1581,28 @@ let destruct_atom_kid env typ = only care about Int-kinded kids because those are the only type that can appear in an existential. *) -let rec kid_order_nexp kids (Nexp_aux (aux, l) as nexp) = +let rec kid_order_nexp kind_map (Nexp_aux (aux, l) as nexp) = match aux with - | Nexp_var kid when KidSet.mem kid kids -> ([kid], KidSet.remove kid kids) - | Nexp_var _ | Nexp_id _ | Nexp_constant _ -> ([], kids) - | Nexp_exp nexp | Nexp_neg nexp -> kid_order_nexp kids nexp + | Nexp_var kid when KBindings.mem kid kind_map -> + ([mk_kopt (unaux_kind (KBindings.find kid kind_map)) kid], KBindings.remove kid kind_map) + | Nexp_var _ | Nexp_id _ | Nexp_constant _ -> ([], kind_map) + | Nexp_exp nexp | Nexp_neg nexp -> kid_order_nexp kind_map nexp | Nexp_times (nexp1, nexp2) | Nexp_sum (nexp1, nexp2) | Nexp_minus (nexp1, nexp2) -> - let (ord, kids) = kid_order_nexp kids nexp1 in + let (ord, kids) = kid_order_nexp kind_map nexp1 in let (ord', kids) = kid_order_nexp kids nexp2 in (ord @ ord', kids) | Nexp_app (id, nexps) -> - List.fold_left (fun (ord, kids) nexp -> let (ord', kids) = kid_order_nexp kids nexp in (ord @ ord', kids)) ([], kids) nexps + List.fold_left (fun (ord, kids) nexp -> let (ord', kids) = kid_order_nexp kids nexp in (ord @ ord', kids)) ([], kind_map) nexps -let rec kid_order kids (Typ_aux (aux, l) as typ) = +let rec kid_order kind_map (Typ_aux (aux, l) as typ) = match aux with - | Typ_var kid when KidSet.mem kid kids -> ([kid], KidSet.remove kid kids) - | Typ_id _ | Typ_var _ -> ([], kids) + | Typ_var kid when KBindings.mem kid kind_map -> + ([mk_kopt (unaux_kind (KBindings.find kid kind_map)) kid], KBindings.remove kid kind_map) + | Typ_id _ | Typ_var _ -> ([], kind_map) | Typ_tup typs -> - List.fold_left (fun (ord, kids) typ -> let (ord', kids) = kid_order kids typ in (ord @ ord', kids)) ([], kids) typs + List.fold_left (fun (ord, kids) typ -> let (ord', kids) = kid_order kids typ in (ord @ ord', kids)) ([], kind_map) typs | Typ_app (_, args) -> - List.fold_left (fun (ord, kids) arg -> let (ord', kids) = kid_order_arg kids arg in (ord @ ord', kids)) ([], kids) args + List.fold_left (fun (ord, kids) arg -> let (ord', kids) = kid_order_arg kids arg in (ord @ ord', kids)) ([], kind_map) args | Typ_fn _ | Typ_bidir _ | Typ_exist _ -> typ_error l ("Existential or function type cannot appear within existential type: " ^ string_of_typ typ) | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" and kid_order_arg kids (A_aux (aux, l) as arg) = @@ -1613,13 +1623,14 @@ let rec alpha_equivalent env typ1 typ2 = | Typ_fn (arg_typs, ret_typ, eff) -> Typ_fn (List.map relabel arg_typs, relabel ret_typ, eff) | Typ_bidir (typ1, typ2) -> Typ_bidir (relabel typ1, relabel typ2) | Typ_tup typs -> Typ_tup (List.map relabel typs) - | Typ_exist (kids, nc, typ) -> - let (kids, _) = kid_order (KidSet.of_list kids) typ in - let kids = List.map (fun kid -> (kid, new_kid ())) kids in - let nc = List.fold_left (fun nc (kid, nk) -> constraint_subst kid (arg_nexp (nvar nk)) nc) nc kids in - let typ = List.fold_left (fun nc (kid, nk) -> typ_subst kid (arg_nexp (nvar nk)) nc) typ kids in - let kids = List.map snd kids in - Typ_exist (kids, nc, typ) + | Typ_exist (kopts, nc, typ) -> + let kind_map = List.fold_left (fun m kopt -> KBindings.add (kopt_kid kopt) (kopt_kind kopt) m) KBindings.empty kopts in + let (kopts, _) = kid_order kind_map typ in + let kopts = List.map (fun kopt -> (kopt_kid kopt, mk_kopt (unaux_kind (kopt_kind kopt)) (new_kid ()))) kopts in + let nc = List.fold_left (fun nc (kid, nk) -> constraint_subst kid (arg_kopt nk) nc) nc kopts in + let typ = List.fold_left (fun nc (kid, nk) -> typ_subst kid (arg_kopt nk) nc) typ kopts in + let kopts = List.map snd kopts in + Typ_exist (kopts, nc, typ) | Typ_app (id, args) -> Typ_app (id, List.map relabel_arg args) in @@ -1699,11 +1710,11 @@ let rec subtyp l env typ1 typ2 = | _, _ when alpha_equivalent env typ1 typ2 -> () (* Special cases for two numeric (atom) types *) | Some (kids1, nc1, nexp1), Some ([], _, nexp2) -> - let env = add_existential l kids1 nc1 env in + let env = add_existential l (List.map (mk_kopt K_int) kids1) nc1 env in if prove env (nc_eq nexp1 nexp2) then () else typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env)) | Some (kids1, nc1, nexp1), Some (kids2, nc2, nexp2) -> - let env = add_existential l kids1 nc1 env in - let env = add_typ_vars l (KidSet.elements (KidSet.inter (nexp_frees nexp2) (KidSet.of_list kids2))) env in + let env = add_existential l (List.map (mk_kopt K_int) kids1) nc1 env in + let env = add_typ_vars l (List.map (mk_kopt K_int) (KidSet.elements (KidSet.inter (nexp_frees nexp2) (KidSet.of_list kids2)))) env in let kids2 = KidSet.elements (KidSet.diff (KidSet.of_list kids2) (nexp_frees nexp2)) in if not (kids2 = []) then typ_error l ("Universally quantified constraint generated: " ^ Util.string_of_list ", " string_of_kid kids2) else (); let env = Env.add_constraint (nc_eq nexp1 nexp2) env in @@ -1711,13 +1722,13 @@ let rec subtyp l env typ1 typ2 = else typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env)) | _, _ -> match destruct_exist' typ1, destruct_exist (canonicalize env typ2) with - | Some (kids, nc, typ1), _ -> - let env = add_existential l kids nc env in subtyp l env typ1 typ2 - | None, Some (kids, nc, typ2) -> + | Some (kopts, nc, typ1), _ -> + let env = add_existential l kopts nc env in subtyp l env typ1 typ2 + | None, Some (kopts, nc, typ2) -> typ_debug (lazy "Subtype check with unification"); let typ1 = canonicalize env typ1 in - let env = add_typ_vars l kids env in - let kids' = KidSet.elements (KidSet.diff (KidSet.of_list kids) (typ_frees typ2)) in + let env = add_typ_vars l kopts env in + let kids' = KidSet.elements (KidSet.diff (KidSet.of_list (List.map kopt_kid kopts)) (typ_frees typ2)) in if not (kids' = []) then typ_error l "Universally quantified constraint generated" else (); let unifiers = try unify l env (KidSet.diff (tyvars_of_typ typ2) (tyvars_of_typ typ1)) typ2 typ1 with @@ -2760,7 +2771,7 @@ and bind_typ_pat env (TP_aux (typ_pat_aux, l) as typ_pat) (Typ_aux (typ_aux, _) begin match typ_nexps typ with | [nexp] -> - Env.add_constraint (nc_eq (nvar kid) nexp) (Env.add_typ_var l kid K_int env) + Env.add_constraint (nc_eq (nvar kid) nexp) (Env.add_typ_var l (mk_kopt K_int kid) env) | [] -> typ_error l ("No numeric expressions in " ^ string_of_typ typ ^ " to bind " ^ string_of_kid kid ^ " to") | nexps -> @@ -2773,7 +2784,7 @@ and bind_typ_pat_arg env (TP_aux (typ_pat_aux, l) as typ_pat) (A_aux (typ_arg_au match typ_pat_aux, typ_arg_aux with | TP_wild, _ -> env | TP_var kid, A_nexp nexp -> - Env.add_constraint (nc_eq (nvar kid) nexp) (Env.add_typ_var l kid K_int env) + Env.add_constraint (nc_eq (nvar kid) nexp) (Env.add_typ_var l (mk_kopt K_int kid) env) | _, A_typ typ -> bind_typ_pat env typ_pat typ | _, A_order _ -> typ_error l "Cannot bind type pattern against order" | _, _ -> typ_error l ("Couldn't bind type argument " ^ string_of_typ_arg typ_arg ^ " with " ^ string_of_typ_pat typ_pat) @@ -3117,7 +3128,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = match destruct_numeric (typ_of inferred_f), destruct_numeric (typ_of inferred_t) with | Some (kids1, nc1, nexp1), Some (kids2, nc2, nexp2) -> let loop_kid = mk_kid ("loop_" ^ string_of_id v) in - let env = List.fold_left (fun env kid -> Env.add_typ_var l kid K_int env) env (loop_kid :: kids1 @ kids2) in + let env = List.fold_left (fun env kid -> Env.add_typ_var l (mk_kopt K_int kid) env) env (loop_kid :: kids1 @ kids2) in let env = Env.add_constraint (nc_and nc1 nc2) env in let env = Env.add_constraint (nc_and (nc_lteq nexp1 (nvar loop_kid)) (nc_lteq (nvar loop_kid) nexp2)) env in let loop_vtyp = atom_typ (nvar loop_kid) in @@ -3311,17 +3322,17 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ = typ_raise l (Err_unresolved_quants (f, !quants, Env.get_locals env, Env.get_constraints env)) else (); - let ty_vars = List.map fst (KBindings.bindings (Env.get_typ_vars env)) in - let existentials = List.filter (fun kid -> not (KBindings.mem kid universals)) ty_vars in + let ty_vars = KBindings.bindings (Env.get_typ_vars env) |> List.map (fun (v, k) -> mk_kopt k v) in + let existentials = List.filter (fun kopt -> not (KBindings.mem (kopt_kid kopt) universals)) ty_vars in let num_new_ncs = List.length (Env.get_constraints env) - List.length universal_constraints in let ex_constraints = take num_new_ncs (Env.get_constraints env) in - typ_debug (lazy ("Existentials: " ^ string_of_list ", " string_of_kid existentials)); + typ_debug (lazy ("Existentials: " ^ string_of_list ", " string_of_kinded_id existentials)); typ_debug (lazy ("Existential constraints: " ^ string_of_list ", " string_of_n_constraint ex_constraints)); let universals = KBindings.bindings universals |> List.map fst |> KidSet.of_list in let typ_ret = - if KidSet.is_empty (KidSet.of_list existentials) || KidSet.is_empty (KidSet.diff (typ_frees !typ_ret) universals) + if KidSet.is_empty (KidSet.of_list (List.map kopt_kid existentials)) || KidSet.is_empty (KidSet.diff (typ_frees !typ_ret) universals) then !typ_ret else mk_typ (Typ_exist (existentials, List.fold_left nc_and nc_true ex_constraints, !typ_ret)) in diff --git a/src/type_check.mli b/src/type_check.mli index 47b9d172..0a0e18f7 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -134,7 +134,7 @@ module Env : sig val get_typ_var_locs : t -> Ast.l KBindings.t - val add_typ_var : Ast.l -> kid -> kind_aux -> t -> t + val add_typ_var : Ast.l -> kinded_id -> t -> t val is_record : id -> t -> bool @@ -208,9 +208,12 @@ end an environment *) val add_typquant : Ast.l -> typquant -> Env.t -> Env.t -val destruct_exist : Env.t -> typ -> (kid list * n_constraint * typ) option +(** Safely destructure an existential type. Returns None if the type + is not existential. This function will pick a fresh name for the + existential to ensure that no name-clashes occur. *) +val destruct_exist : typ -> (kinded_id list * n_constraint * typ) option -val add_existential : Ast.l -> kid list -> n_constraint -> Env.t -> Env.t +val add_existential : Ast.l -> kinded_id list -> n_constraint -> Env.t -> Env.t (** When the typechecker creates new type variables it gives them fresh names of the form 'fvXXX#name, where XXX is a number (not @@ -349,11 +352,6 @@ val expected_typ_of : Ast.l * tannot -> typ option val destruct_atom_nexp : Env.t -> typ -> nexp option -(** Safely destructure an existential type. Returns None if the type - is not existential. This function will pick a fresh name for the - existential to ensure that no name-clashes occur. *) -val destruct_exist : typ -> (kid list * n_constraint * typ) option - val destruct_range : Env.t -> typ -> (kid list * n_constraint * nexp * nexp) option val destruct_numeric : typ -> (kid list * n_constraint * nexp) option -- cgit v1.2.3 From 54914eff75322309ad6505905c24806f3c7396f3 Mon Sep 17 00:00:00 2001 From: Alasdair Date: Wed, 12 Dec 2018 03:57:32 +0000 Subject: Get typechecking example with boolean argument flow-typing working --- src/type_check.ml | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'src') diff --git a/src/type_check.ml b/src/type_check.ml index 5774a46f..cc0b9843 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -1997,6 +1997,10 @@ let rec combine_constraint b f x y = match b, x, y with | _, _, _ -> None let rec assert_constraint env b (E_aux (exp_aux, _) as exp) = + match typ_of exp with + | Typ_aux (Typ_app (Id_aux (Id "atom_bool", _), [A_aux (A_bool nc, _)]), _) -> + Some nc + | _ -> match exp_aux with | E_constraint nc -> Some nc -- cgit v1.2.3 From 56fb5bf999d7cc900d6535da4168e220862d3d9c Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 12 Dec 2018 17:37:13 +0000 Subject: Add a test case for various simple boolean properties test/typecheck/pass/tautology.sail constaints tests of various boolean properties, e.g. // de Morgan _prove(constraint(not('p | 'q) <--> not('p) & not('q))); _prove(constraint(not('p & 'q) <--> not('p) | not('q))); introduce a new _not_prove case which allows us to assert in tests that a constraint is not provable. This test essentially tests that constraints map to sensible problems in the SMT solver, without testing flow typing or any other features. Add a script test/typecheck/update_errors.sh, which regenerates the expected error messages. Testing that type-checking failures is important, but can be brittle when the error messages change for inconsequential reasons. This script automates fixing this. Also ensure that this test case works correctly in Lem --- src/ast_util.ml | 2 ++ src/initial_check.ml | 47 +++++++++++++++--------- src/parse_ast.ml | 4 +-- src/parser.mly | 8 +++-- src/pretty_print_lem.ml | 5 +++ src/pretty_print_sail.ml | 17 +++++++-- src/rewrites.ml | 2 ++ src/spec_analysis.ml | 9 +++-- src/type_check.ml | 94 +++++++++++++++++++++++++++++++++--------------- src/type_check.mli | 2 +- 10 files changed, 132 insertions(+), 58 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index 02e297cb..a771291e 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -739,6 +739,8 @@ and string_of_n_constraint = function "(" ^ string_of_n_constraint nc1 ^ " & " ^ string_of_n_constraint nc2 ^ ")" | NC_aux (NC_set (kid, ns), _) -> string_of_kid kid ^ " in {" ^ string_of_list ", " Big_int.to_string ns ^ "}" + | NC_aux (NC_app (Id_aux (DeIid op, _), [arg1; arg2]), _) -> + "(" ^ string_of_typ_arg arg1 ^ " " ^ op ^ " " ^ string_of_typ_arg arg2 ^ ")" | NC_aux (NC_app (id, args), _) -> string_of_id id ^ "(" ^ string_of_list ", " string_of_typ_arg args ^ ")" | NC_aux (NC_var v, _) -> string_of_kid v | NC_aux (NC_true, _) -> "true" diff --git a/src/initial_check.ml b/src/initial_check.ml index d394fde9..61cde224 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -129,6 +129,18 @@ let format_kind_aux_list = function | [kind] -> string_of_kind_aux kind | kinds -> "(" ^ Util.string_of_list ", " string_of_kind_aux kinds ^ ")" +let to_ast_kopt ctx (P.KOpt_aux (aux, l)) = + let aux, ctx = match aux with + | P.KOpt_none v -> + let v = to_ast_var v in + KOpt_kind (K_aux (K_int, gen_loc l), v), { ctx with kinds = KBindings.add v K_int ctx.kinds } + | P.KOpt_kind (k, v) -> + let v = to_ast_var v in + let k = to_ast_kind k in + KOpt_kind (k, v), { ctx with kinds = KBindings.add v (unaux_kind k) ctx.kinds } + in + KOpt_aux (aux, l), ctx + let rec to_ast_typ ctx (P.ATyp_aux (aux, l)) = let aux = match aux with | P.ATyp_id id -> Typ_id (to_ast_id id) @@ -157,10 +169,11 @@ let rec to_ast_typ ctx (P.ATyp_aux (aux, l)) = | Some kinds -> Typ_app (id, List.map2 (to_ast_typ_arg ctx) args kinds) end - | P.ATyp_exist (kids, nc, atyp) -> - let kids = List.map to_ast_var kids in - let ctx = { ctx with kinds = List.fold_left (fun kinds kid -> KBindings.add kid K_int kinds) ctx.kinds kids } in - Typ_exist (List.map (mk_kopt K_int) kids, to_ast_constraint ctx nc, to_ast_typ ctx atyp) + | P.ATyp_exist (kopts, nc, atyp) -> + let kopts, ctx = + List.fold_right (fun kopt (kopts, ctx) -> let kopt, ctx = to_ast_kopt ctx kopt in (kopt :: kopts, ctx)) kopts ([], ctx) + in + Typ_exist (kopts, to_ast_constraint ctx nc, to_ast_typ ctx atyp) | P.ATyp_base (id, kind, nc) -> raise (Reporting.err_unreachable l __POS__ "TODO") | _ -> raise (Reporting.err_typ l "Invalid type") @@ -197,7 +210,7 @@ and to_ast_order ctx (P.ATyp_aux (aux, l)) = and to_ast_constraint ctx (P.ATyp_aux (aux, l) as atyp) = let aux = match aux with - | P.ATyp_app (Id_aux (DeIid op, _), [t1; t2]) -> + | P.ATyp_app (Id_aux (DeIid op, _) as id, [t1; t2]) -> begin match op with | "==" -> NC_equal (to_ast_nexp ctx t1, to_ast_nexp ctx t2) | "!=" -> NC_equal (to_ast_nexp ctx t1, to_ast_nexp ctx t2) @@ -207,7 +220,15 @@ and to_ast_constraint ctx (P.ATyp_aux (aux, l) as atyp) = | "<" -> NC_bounded_le (nsum (to_ast_nexp ctx t1) (nint 1), to_ast_nexp ctx t2) | "&" -> NC_and (to_ast_constraint ctx t1, to_ast_constraint ctx t2) | "|" -> NC_or (to_ast_constraint ctx t1, to_ast_constraint ctx t2) - | _ -> raise (Reporting.err_typ l ("Invalid operator in constraint")) + | _ -> + let id = to_ast_id id in + match Bindings.find_opt id ctx.type_constructors with + | None -> raise (Reporting.err_typ l (sprintf "Could not find type constructor %s" (string_of_id id))) + | Some kinds when List.length kinds <> 2 -> + raise (Reporting.err_typ l (sprintf "%s : %s -> Bool expected %d arguments, given 2" + (string_of_id id) (format_kind_aux_list kinds) + (List.length kinds))) + | Some kinds -> NC_app (id, List.map2 (to_ast_typ_arg ctx) [t1; t2] kinds) end | P.ATyp_app (id, args) -> let id = to_ast_id id in @@ -230,17 +251,9 @@ and to_ast_constraint ctx (P.ATyp_aux (aux, l) as atyp) = let to_ast_quant_item ctx (P.QI_aux (aux, l)) = match aux with | P.QI_const nc -> QI_aux (QI_const (to_ast_constraint ctx nc), l), ctx - | P.QI_id (KOpt_aux (aux, kopt_l)) -> - let aux, ctx = match aux with - | P.KOpt_none v -> - let v = to_ast_var v in - KOpt_kind (K_aux (K_int, gen_loc kopt_l), v), { ctx with kinds = KBindings.add v K_int ctx.kinds } - | P.KOpt_kind (k, v) -> - let v = to_ast_var v in - let k = to_ast_kind k in - KOpt_kind (k, v), { ctx with kinds = KBindings.add v (unaux_kind k) ctx.kinds } - in - QI_aux (QI_id (KOpt_aux (aux, kopt_l)), l), ctx + | P.QI_id kopt -> + let kopt, ctx = to_ast_kopt ctx kopt in + QI_aux (QI_id kopt, l), ctx let to_ast_typquant ctx (P.TypQ_aux (aux, l)) = match aux with diff --git a/src/parse_ast.ml b/src/parse_ast.ml index a5dbf66e..9b855837 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -163,7 +163,7 @@ atyp_aux = (* expressions of all kinds, to be translated to types, nats, orders | ATyp_wild | ATyp_tup of (atyp) list (* Tuple type *) | ATyp_app of id * (atyp) list (* type constructor application *) - | ATyp_exist of kid list * atyp * atyp + | ATyp_exist of kinded_id list * atyp * atyp | ATyp_base of id * atyp * atyp and atyp = @@ -175,7 +175,7 @@ kinded_id_aux = (* optionally kind-annotated identifier *) KOpt_none of kid (* identifier *) | KOpt_kind of kind * kid (* kind-annotated variable *) -type +and kinded_id = KOpt_aux of kinded_id_aux * l diff --git a/src/parser.mly b/src/parser.mly index 544438c0..1957d7fd 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -78,6 +78,8 @@ let prepend_id str1 = function let mk_id i n m = Id_aux (i, loc n m) let mk_kid str n m = Kid_aux (Var str, loc n m) +let mk_kopt k n m = KOpt_aux (k, loc n m) + let id_of_kid = function | Kid_aux (Var v, l) -> Id_aux (Id (String.sub v 1 (String.length v - 1)), l) @@ -550,10 +552,10 @@ atomic_typ: { let v = mk_kid "n" $startpos $endpos in let atom_id = mk_id (Id "atom") $startpos $endpos in let atom_of_v = mk_typ (ATyp_app (atom_id, [mk_typ (ATyp_var v) $startpos $endpos])) $startpos $endpos in - mk_typ (ATyp_exist ([v], ATyp_aux (ATyp_nset (v, $2), loc $startpos($2) $endpos($2)), atom_of_v)) $startpos $endpos } - | Lcurly kid_list Dot typ Rcurly + mk_typ (ATyp_exist ([mk_kopt (KOpt_none v) $startpos $endpos], ATyp_aux (ATyp_nset (v, $2), loc $startpos($2) $endpos($2)), atom_of_v)) $startpos $endpos } + | Lcurly kopt_list Dot typ Rcurly { mk_typ (ATyp_exist ($2, ATyp_aux (ATyp_lit (L_aux (L_true, loc $startpos $endpos)), loc $startpos $endpos), $4)) $startpos $endpos } - | Lcurly kid_list Comma typ Dot typ Rcurly + | Lcurly kopt_list Comma typ Dot typ Rcurly { mk_typ (ATyp_exist ($2, $4, $6)) $startpos $endpos } | Lcurly id Colon typ Dot typ Rcurly { mk_typ (ATyp_base ($2, $4, $6)) $startpos $endpos } diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index ac0195aa..9d169108 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -247,6 +247,7 @@ and lem_nexps_of_typ_arg (A_aux (ta,_)) = | A_nexp nexp -> NexpSet.singleton (nexp_simp (orig_nexp nexp)) | A_typ typ -> lem_nexps_of_typ typ | A_order _ -> NexpSet.empty + | A_bool _ -> NexpSet.empty let lem_tyvars_of_typ typ = NexpSet.fold (fun nexp ks -> KidSet.union ks (tyvars_of_nexp nexp)) @@ -296,6 +297,8 @@ let doc_typ_lem, doc_atomic_typ_lem = (string "integer") | Typ_app(Id_aux (Id "atom", _), [A_aux(A_nexp n,_)]) -> (string "integer") + | Typ_app(Id_aux (Id "atom_bool", _), [A_aux(A_bool nc,_)]) -> + (string "bool") | Typ_app(id,args) -> let tpp = (doc_id_lem_type id) ^^ space ^^ (separate_map space doc_typ_arg_lem args) in if atyp_needed then parens tpp else tpp @@ -331,6 +334,7 @@ let doc_typ_lem, doc_atomic_typ_lem = | A_typ t -> app_typ true t | A_nexp n -> doc_nexp_lem (nexp_simp n) | A_order o -> empty + | A_bool _ -> empty in typ', atomic_typ (* Check for variables in types that would be pretty-printed. *) @@ -1013,6 +1017,7 @@ let doc_typdef_lem (TD_aux(td, (l, annot))) = match td with doc_op equals (separate space [string "type"; doc_id_lem_type id; doc_typquant_items_lem None typq]) (doc_typschm_lem false typschm) + | TD_abbrev _ -> empty | TD_record(id,nm,typq,fs,_) -> let fname fid = if prefix_recordtype && string_of_id id <> "regstate" then concat [doc_id_lem id;string "_";doc_id_lem_type fid;] diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index e0223105..c4b9bdd3 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -70,7 +70,7 @@ let doc_kopt = function | kopt when is_typ_kopt kopt -> parens (separate space [doc_kid (kopt_kid kopt); colon; string "Type"]) | kopt when is_order_kopt kopt -> parens (separate space [doc_kid (kopt_kid kopt); colon; string "Order"]) | kopt -> parens (separate space [doc_kid (kopt_kid kopt); colon; string "Bool"]) - + let doc_int n = string (Big_int.to_string n) let docstring (l, _) = match l with @@ -168,6 +168,8 @@ and doc_typ ?(simple=false) (Typ_aux (typ_aux, l)) = separate space [doc_typ_arg x; doc_typ_arg y] | Typ_app (id, typs) when Id.compare id (mk_id "atom") = 0 -> string "int" ^^ parens (separate_map (string ", ") doc_typ_arg typs) + | Typ_app (id, typs) when Id.compare id (mk_id "atom_bool") = 0 -> + string "bool" ^^ parens (separate_map (string ", ") doc_typ_arg typs) | Typ_app (id, typs) -> doc_id id ^^ parens (separate_map (string ", ") doc_typ_arg typs) | Typ_tup typs -> parens (separate_map (string ", ") doc_typ typs) | Typ_var kid -> doc_kid kid @@ -205,6 +207,7 @@ let doc_quants quants = match qi_aux with | QI_id kopt when is_nat_kopt kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Int"])] | QI_id kopt when is_typ_kopt kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Type"])] + | QI_id kopt when is_bool_kopt kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Bool"])] | QI_id kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Order"])] | QI_const nc -> [] in @@ -225,6 +228,7 @@ let doc_param_quants quants = match qi_aux with | QI_id kopt when is_nat_kopt kopt -> [doc_kid (kopt_kid kopt) ^^ colon ^^ space ^^ string "Int"] | QI_id kopt when is_typ_kopt kopt -> [doc_kid (kopt_kid kopt) ^^ colon ^^ space ^^ string "Type"] + | QI_id kopt when is_bool_kopt kopt -> [doc_kid (kopt_kid kopt) ^^ colon ^^ space ^^ string "Bool"] | QI_id kopt -> [doc_kid (kopt_kid kopt) ^^ colon ^^ space ^^ string "Order"] | QI_const nc -> [] in @@ -567,14 +571,21 @@ let doc_field (typ, id) = let doc_union (Tu_aux (Tu_ty_id (typ, id), l)) = separate space [doc_id id; colon; doc_typ typ] +let doc_typ_arg_kind (A_aux (aux, _)) = + match aux with + | A_nexp _ -> space ^^ string "->" ^^ space ^^string "Int" + | A_bool _ -> space ^^ string "->" ^^ space ^^ string "Bool" + | A_order _ -> space ^^ string "->" ^^ space ^^ string "Order" + | A_typ _ -> empty + let doc_typdef (TD_aux(td,_)) = match td with | TD_abbrev (id, typq, typ_arg) -> begin match doc_typquant typq with | Some qdoc -> - doc_op equals (concat [string "type"; space; doc_id id; qdoc]) (doc_typ_arg typ_arg) + doc_op equals (concat [string "type"; space; doc_id id; qdoc; doc_typ_arg_kind typ_arg]) (doc_typ_arg typ_arg) | None -> - doc_op equals (concat [string "type"; space; doc_id id]) (doc_typ_arg typ_arg) + doc_op equals (concat [string "type"; space; doc_id id; doc_typ_arg_kind typ_arg]) (doc_typ_arg typ_arg) end | TD_enum (id, _, ids, _) -> separate space [string "enum"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_id ids) rbrace] diff --git a/src/rewrites.ml b/src/rewrites.ml index 79b5f619..30318e3f 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -271,6 +271,8 @@ let rewrite_defs_nexp_ids, rewrite_typ_nexp_ids = A_aux (A_typ (rewrite_typ env typ), l) | A_order ord -> A_aux (A_order ord, l) + | A_bool nc -> + A_aux (A_bool nc, l) in let rewrite_annot (l, tannot) = diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index 0f8db0ff..940fbfe5 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -310,10 +310,13 @@ let typ_variants consider_var bound tunions = let fv_of_kind_def consider_var (KD_aux(k,_)) = match k with | KD_nabbrev(_,id,_,nexp) -> init_env (string_of_id id), fv_of_nexp consider_var mt mt nexp +let fv_of_abbrev consider_var bound used typq typ_arg = + let ts_bound = if consider_var then typq_bindings typq else mt in + ts_bound, fv_of_targ consider_var (Nameset.union bound ts_bound) used typ_arg + let fv_of_type_def consider_var (TD_aux(t,_)) = match t with - | TD_abbrev(id,typq,A_aux(A_typ typ, l)) -> - let typschm = TypSchm_aux (TypSchm_ts (typq,typ), l) in - init_env (string_of_id id), snd (fv_of_typschm consider_var mt mt typschm) + | TD_abbrev(id,typq,typ_arg) -> + init_env (string_of_id id), snd (fv_of_abbrev consider_var mt mt typq typ_arg) | TD_record(id,_,typq,tids,_) -> let binds = init_env (string_of_id id) in let bounds = if consider_var then typq_bindings typq else mt in diff --git a/src/type_check.ml b/src/type_check.ml index cc0b9843..befc7302 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -82,7 +82,7 @@ let rec indent n = match n with (* Lazily evaluate debugging message. This can make a big performance difference; for example, repeated calls to string_of_exp can be costly for deeply nested expressions, e.g. with long sequences of monadic binds. *) -let typ_debug m = if !opt_tc_debug > 1 then prerr_endline (indent !depth ^ Lazy.force m) else () +let typ_debug ?level:(level=1) m = if !opt_tc_debug > level then prerr_endline (indent !depth ^ Lazy.force m) else () let typ_print m = if !opt_tc_debug > 0 then prerr_endline (indent !depth ^ Lazy.force m) else () @@ -516,6 +516,7 @@ end = struct else typ_error (id_loc id) ("Could not prove " ^ string_of_list ", " string_of_n_constraint ncs ^ " for type constructor " ^ string_of_id id) let rec expand_constraint_synonyms env (NC_aux (aux, l) as nc) = + typ_debug ~level:2 (lazy ("Expanding " ^ string_of_n_constraint nc)); match aux with | NC_or (nc1, nc2) -> NC_aux (NC_or (expand_constraint_synonyms env nc1, expand_constraint_synonyms env nc2), l) | NC_and (nc1, nc2) -> NC_aux (NC_and (expand_constraint_synonyms env nc1, expand_constraint_synonyms env nc2), l) @@ -523,7 +524,7 @@ end = struct (try begin match Bindings.find id env.typ_synonyms env args with | A_aux (A_bool nc, _) -> expand_constraint_synonyms env nc - | _ -> typ_error l ("Expected Type when expanding synonym " ^ string_of_id id) + | arg -> typ_error l ("Expected Bool when expanding synonym " ^ string_of_id id ^ " got " ^ string_of_typ_arg arg) end with Not_found -> NC_aux (NC_app (id, List.map (expand_synonyms_arg env) args), l)) | NC_true | NC_false | NC_equal _ | NC_not_equal _ | NC_bounded_le _ | NC_bounded_ge _ | NC_var _ | NC_set _ -> nc @@ -602,9 +603,13 @@ end = struct | A_order _ | A_typ _ | A_bool _ -> arg | A_nexp n -> A_aux (A_nexp (f n), l) + let wf_debug str f x exs = + typ_debug ~level:2 (lazy ("wf_" ^ str ^ ": " ^ f x ^ " exs: " ^ Util.string_of_list ", " string_of_kid (KidSet.elements exs))) + (* Check if a type, order, n-expression or constraint is well-formed. Throws a type error if the type is badly formed. *) let rec wf_typ ?exs:(exs=KidSet.empty) env typ = + wf_debug "typ" string_of_typ typ exs; let (Typ_aux (typ_aux, l)) = expand_synonyms env typ in match typ_aux with | Typ_id id when bound_typ_id env id -> @@ -643,6 +648,7 @@ end = struct | A_order ord -> wf_order env ord | A_bool nc -> wf_constraint ~exs:exs env nc and wf_nexp ?exs:(exs=KidSet.empty) env (Nexp_aux (nexp_aux, l) as nexp) = + wf_debug "nexp" string_of_nexp nexp exs; match nexp_aux with | Nexp_id _ -> () | Nexp_var kid when KidSet.mem kid exs -> () @@ -662,7 +668,7 @@ end = struct | Nexp_minus (nexp1, nexp2) -> wf_nexp ~exs:exs env nexp1; wf_nexp ~exs:exs env nexp2 | Nexp_exp nexp -> wf_nexp ~exs:exs env nexp (* MAYBE: Could put restrictions on what is allowed here *) | Nexp_neg nexp -> wf_nexp ~exs:exs env nexp - and wf_order env (Ord_aux (ord_aux, l)) = + and wf_order env (Ord_aux (ord_aux, l) as ord) = match ord_aux with | Ord_var kid -> begin @@ -674,6 +680,7 @@ end = struct end | Ord_inc | Ord_dec -> () and wf_constraint ?exs:(exs=KidSet.empty) env (NC_aux (nc_aux, l) as nc) = + wf_debug "constraint" string_of_n_constraint nc exs; match nc_aux with | NC_equal (n1, n2) -> wf_nexp ~exs:exs env n1; wf_nexp ~exs:exs env n2 | NC_not_equal (n1, n2) -> wf_nexp ~exs:exs env n1; wf_nexp ~exs:exs env n2 @@ -690,6 +697,7 @@ end = struct | NC_or (nc1, nc2) -> wf_constraint ~exs:exs env nc1; wf_constraint ~exs:exs env nc2 | NC_and (nc1, nc2) -> wf_constraint ~exs:exs env nc1; wf_constraint ~exs:exs env nc2 | NC_app (id, args) -> List.iter (wf_typ_arg ~exs:exs env) args + | NC_var kid when KidSet.mem kid exs -> () | NC_var kid -> begin match get_typ_var kid env with | K_bool -> () @@ -1031,8 +1039,9 @@ end = struct let get_constraints env = env.constraints - let add_constraint (NC_aux (nc_aux, l) as constr) env = + let add_constraint constr env = wf_constraint env constr; + let (NC_aux (nc_aux, l) as constr) = expand_constraint_synonyms env constr in match nc_aux with | NC_true -> env | _ -> @@ -1261,6 +1270,7 @@ let solve env nexp = failwith "WIP" let prove env nc = typ_print (lazy (Util.("Prove " |> red |> clear) ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_n_constraint nc)); let (NC_aux (nc_aux, _) as nc) = Env.expand_constraint_synonyms env nc in + typ_debug ~level:2 (lazy (Util.("Prove " |> red |> clear) ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_n_constraint nc)); let compare_const f (Nexp_aux (n1, _)) (Nexp_aux (n2, _)) = match n1, n2 with | Nexp_constant c1, Nexp_constant c2 when f c1 c2 -> true @@ -1362,6 +1372,7 @@ let rec nc_identical (NC_aux (nc1, _)) (NC_aux (nc2, _)) = | NC_false, NC_false -> true | NC_set (kid1, ints1), NC_set (kid2, ints2) when List.length ints1 = List.length ints2 -> Kid.compare kid1 kid2 = 0 && List.for_all2 (fun i1 i2 -> i1 = i2) ints1 ints2 + | NC_var kid1, NC_var kid2 -> Kid.compare kid1 kid2 = 0 | _, _ -> false let typ_identical env typ1 typ2 = @@ -1449,8 +1460,15 @@ and unify_typ_arg l env goals (A_aux (aux1, _) as typ_arg1) (A_aux (aux2, _) as | A_typ typ1, A_typ typ2 -> unify_typ l env goals typ1 typ2 | A_nexp nexp1, A_nexp nexp2 -> unify_nexp l env goals nexp1 nexp2 | A_order ord1, A_order ord2 -> unify_order l goals ord1 ord2 + | A_bool nc1, A_bool nc2 -> unify_constraint l goals nc1 nc2 | _, _ -> unify_error l ("Could not unify type arguments " ^ string_of_typ_arg typ_arg1 ^ " and " ^ string_of_typ_arg typ_arg2) +and unify_constraint l goals (NC_aux (aux1, _) as nc1) (NC_aux (aux2, _) as nc2) = + typ_debug (lazy (Util.("Unify constraint " |> magenta |> clear) ^ string_of_n_constraint nc1 ^ " and " ^ string_of_n_constraint nc2)); + match aux1, aux2 with + | NC_var v, _ when KidSet.mem v goals -> KBindings.singleton v (arg_bool nc2) + | _, _ -> unify_error l ("Could not unify constraints " ^ string_of_n_constraint nc1 ^ " and " ^ string_of_n_constraint nc2) + and unify_order l goals (Ord_aux (aux1, _) as ord1) (Ord_aux (aux2, _) as ord2) = typ_print (lazy (Util.("Unify order " |> magenta |> clear) ^ string_of_order ord1 ^ " and " ^ string_of_order ord2)); match aux1, aux2 with @@ -1594,6 +1612,7 @@ let rec kid_order_nexp kind_map (Nexp_aux (aux, l) as nexp) = | Nexp_app (id, nexps) -> List.fold_left (fun (ord, kids) nexp -> let (ord', kids) = kid_order_nexp kids nexp in (ord @ ord', kids)) ([], kind_map) nexps + let rec kid_order kind_map (Typ_aux (aux, l) as typ) = match aux with | Typ_var kid when KBindings.mem kid kind_map -> @@ -1605,11 +1624,18 @@ let rec kid_order kind_map (Typ_aux (aux, l) as typ) = List.fold_left (fun (ord, kids) arg -> let (ord', kids) = kid_order_arg kids arg in (ord @ ord', kids)) ([], kind_map) args | Typ_fn _ | Typ_bidir _ | Typ_exist _ -> typ_error l ("Existential or function type cannot appear within existential type: " ^ string_of_typ typ) | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" -and kid_order_arg kids (A_aux (aux, l) as arg) = +and kid_order_arg kind_map (A_aux (aux, l) as arg) = match aux with - | A_typ typ -> kid_order kids typ - | A_nexp nexp -> kid_order_nexp kids nexp - | A_order _ -> ([], kids) + | A_typ typ -> kid_order kind_map typ + | A_nexp nexp -> kid_order_nexp kind_map nexp + | A_bool nc -> kid_order_constraint kind_map nc + | A_order _ -> ([], kind_map) +and kid_order_constraint kind_map (NC_aux (aux, l) as nc) = + match aux with + | NC_var kid when KBindings.mem kid kind_map -> + ([mk_kopt (unaux_kind (KBindings.find kid kind_map)) kid], KBindings.remove kid kind_map) + | NC_var _ -> ([], kind_map) + | _ -> unreachable l __POS__ "bad constraint type" let rec alpha_equivalent env typ1 typ2 = let counter = ref 0 in @@ -1742,8 +1768,10 @@ let rec subtyp l env typ1 typ2 = match typ_aux1, typ_aux2 with | _, Typ_internal_unknown when Env.allow_unknowns env -> () - | Typ_app (id1, _), Typ_id id2 when string_of_id id1 = "atom_bool" && string_of_id id2 = "bool" -> () - + | Typ_app (id1, _), Typ_id id2 when string_of_id id1 = "atom_bool" && string_of_id id2 = "bool" -> + typ_debug (lazy "Boolean subtype"); + () + | Typ_tup typs1, Typ_tup typs2 when List.length typs1 = List.length typs2 -> List.iter2 (subtyp l env) typs1 typs2 @@ -1762,7 +1790,7 @@ and subtyp_arg l env (A_aux (aux1, _) as arg1) (A_aux (aux2, _) as arg2) = | A_nexp n1, A_nexp n2 when prove env (nc_eq n1 n2) -> () | A_typ typ1, A_typ typ2 -> subtyp l env typ1 typ2 | A_order ord1, A_order ord2 when ord_identical ord1 ord2 -> () - | A_bool nc1, A_bool nc2 -> assert false + | A_bool nc1, A_bool nc2 when nc_identical nc1 nc2 -> () | _, _ -> typ_error l "Mismatched argument types in subtype check" let typ_equality l env typ1 typ2 = @@ -1997,6 +2025,7 @@ let rec combine_constraint b f x y = match b, x, y with | _, _, _ -> None let rec assert_constraint env b (E_aux (exp_aux, _) as exp) = + typ_debug ~level:2 (lazy ("Asserting constraint for " ^ string_of_exp exp ^ " : " ^ string_of_typ (typ_of exp))); match typ_of exp with | Typ_aux (Typ_app (Id_aux (Id "atom_bool", _), [A_aux (A_bool nc, _)]), _) -> Some nc @@ -2243,14 +2272,11 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ if prove env nc then annot_exp (E_lit (L_aux (L_unit, Parse_ast.Unknown))) unit_typ else typ_error l ("Cannot prove " ^ string_of_n_constraint nc) - | E_app (f, [E_aux (E_sizeof nexp, _)]), _ when Id.compare f (mk_id "__solve") = 0 -> - Env.wf_nexp env nexp; - begin match solve env nexp with - | None -> typ_error l ("Coud not solve " ^ string_of_nexp nexp) - | Some n -> - print_endline ("Solved " ^ string_of_nexp nexp ^ " = " ^ Big_int.to_string n); - annot_exp (E_lit (L_aux (L_unit, Parse_ast.Unknown))) unit_typ - end + | E_app (f, [E_aux (E_constraint nc, _)]), _ when Id.compare f (mk_id "_not_prove") = 0 -> + Env.wf_constraint env nc; + if prove env nc + then typ_error l ("Can prove " ^ string_of_n_constraint nc) + else annot_exp (E_lit (L_aux (L_unit, Parse_ast.Unknown))) unit_typ (* All constructors and mappings are treated as having one argument so Ctor(x, y) is checked as Ctor((x, y)) *) | E_app (f, x :: y :: zs), _ when Env.is_union_constructor f env || Env.is_mapping f env -> @@ -2295,10 +2321,19 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ let inferred_exp = infer_funapp l env f xs (Some typ) in type_coercion env inferred_exp typ | E_if (cond, then_branch, else_branch), _ -> - let cond' = crule check_exp env cond (mk_typ (Typ_id (mk_id "bool"))) in - let then_branch' = crule check_exp (add_opt_constraint (assert_constraint env true cond') env) then_branch typ in - let else_branch' = crule check_exp (add_opt_constraint (option_map nc_not (assert_constraint env false cond')) env) else_branch typ in - annot_exp (E_if (cond', then_branch', else_branch')) typ + (* let cond' = crule check_exp env cond (mk_typ (Typ_id (mk_id "bool"))) in *) + let cond' = irule infer_exp env cond in + begin match destruct_exist (typ_of cond') with + | Some (kopts, nc, Typ_aux (Typ_app (ab, [A_aux (A_bool flow, _)]), _)) when string_of_id ab = "atom_bool" -> + let env = add_existential l kopts nc env in + let then_branch' = crule check_exp (Env.add_constraint flow env) then_branch typ in + let else_branch' = crule check_exp (Env.add_constraint flow env) else_branch typ in + annot_exp (E_if (cond', then_branch', else_branch')) typ + | _ -> + let then_branch' = crule check_exp (add_opt_constraint (assert_constraint env true cond') env) then_branch typ in + let else_branch' = crule check_exp (add_opt_constraint (option_map nc_not (assert_constraint env false cond')) env) else_branch typ in + annot_exp (E_if (cond', then_branch', else_branch')) typ + end | E_exit exp, _ -> let checked_exp = crule check_exp env exp (mk_typ (Typ_id (mk_id "unit"))) in annot_exp_effect (E_exit checked_exp) typ (mk_effect [BE_escape]) @@ -3251,7 +3286,7 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ = let updated_unifiers = KBindings.map (subst_unifiers_typ_arg unifiers) previous_unifiers in all_unifiers := merge_uvars l updated_unifiers unifiers; in - + let quants, typ_args, typ_ret, eff = match Env.expand_synonyms env f_typ with | Typ_aux (Typ_fn (typ_args, typ_ret, eff), _) -> ref (quant_items typq), typ_args, ref typ_ret, eff @@ -4271,6 +4306,10 @@ let check_type_union env variant typq (Tu_aux (tu, l)) = (* FIXME: This code is duplicated with general kind-checking code in environment, can they be merged? *) let mk_synonym typq typ_arg = let kopts, ncs = quant_split typq in + let kopts = List.map (fun kopt -> kopt, fresh_existential (unaux_kind (kopt_kind kopt))) kopts in + let ncs = List.map (fun nc -> List.fold_left (fun nc (kopt, fresh) -> constraint_subst (kopt_kid kopt) (arg_kopt fresh) nc) nc kopts) ncs in + let typ_arg = List.fold_left (fun typ_arg (kopt, fresh) -> typ_arg_subst (kopt_kid kopt) (arg_kopt fresh) typ_arg) typ_arg kopts in + let kopts = List.map snd kopts in let rec subst_args kopts args = match kopts, args with | kopt :: kopts, A_aux (A_nexp arg, _) :: args when is_nat_kopt kopt -> @@ -4283,7 +4322,7 @@ let mk_synonym typq typ_arg = | kopt :: kopts, A_aux (A_order arg, _) :: args when is_order_kopt kopt -> let typ_arg, ncs = subst_args kopts args in typ_arg_subst (kopt_kid kopt) (arg_order arg) typ_arg, ncs - | kopt :: kopts, A_aux (A_bool arg, _) :: args when is_order_kopt kopt -> + | kopt :: kopts, A_aux (A_bool arg, _) :: args when is_bool_kopt kopt -> let typ_arg, ncs = subst_args kopts args in typ_arg_subst (kopt_kid kopt) (arg_bool arg) typ_arg, ncs | [], [] -> typ_arg, ncs @@ -4310,11 +4349,8 @@ let rec check_typedef : 'a. Env.t -> 'a type_def -> (tannot def) list * Env.t = fun env (TD_aux (tdef, (l, _))) -> let td_err () = raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented Typedef") in match tdef with - | TD_abbrev (id, typq, (A_aux (A_typ _, _) as typ_arg)) -> - [DEF_type (TD_aux (tdef, (l, None)))], Env.add_typ_synonym id (mk_synonym typq typ_arg) env - (* For type synonyms for non-Type kinds we omit them from the AST *) | TD_abbrev (id, typq, typ_arg) -> - [], Env.add_typ_synonym id (mk_synonym typq typ_arg) env + [DEF_type (TD_aux (tdef, (l, None)))], Env.add_typ_synonym id (mk_synonym typq typ_arg) env | TD_record (id, nmscm, typq, fields, _) -> [DEF_type (TD_aux (tdef, (l, None)))], Env.add_record id typq fields env | TD_variant (id, nmscm, typq, arms, _) -> diff --git a/src/type_check.mli b/src/type_check.mli index 0a0e18f7..04ff48f7 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -84,7 +84,7 @@ type type_error = exception Type_error of l * type_error;; -val typ_debug : string Lazy.t -> unit +val typ_debug : ?level:int -> string Lazy.t -> unit val typ_print : string Lazy.t -> unit (** {2 Environments} *) -- cgit v1.2.3 From 6a40f1a1fca791c141c9c4e71dbb1876812666a6 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 12 Dec 2018 18:02:16 +0000 Subject: Add a test for flow typing as found in the ARM 32-bit instructions --- src/type_check.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/type_check.ml b/src/type_check.ml index befc7302..47275594 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -2327,7 +2327,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ | Some (kopts, nc, Typ_aux (Typ_app (ab, [A_aux (A_bool flow, _)]), _)) when string_of_id ab = "atom_bool" -> let env = add_existential l kopts nc env in let then_branch' = crule check_exp (Env.add_constraint flow env) then_branch typ in - let else_branch' = crule check_exp (Env.add_constraint flow env) else_branch typ in + let else_branch' = crule check_exp (Env.add_constraint (nc_not flow) env) else_branch typ in annot_exp (E_if (cond', then_branch', else_branch')) typ | _ -> let then_branch' = crule check_exp (add_opt_constraint (assert_constraint env true cond') env) then_branch typ in -- cgit v1.2.3 From f8d88d4cf2439f4920fa948b054c4f0b2899e368 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Wed, 12 Dec 2018 18:23:00 +0000 Subject: Move much of recursive function termination to a rewrite It now includes updating the effects so that morally pure recursive functions can be turned into this impure termination-by-assertion form. --- src/pretty_print_coq.ml | 103 ++++++++++++---------------------- src/rewrites.ml | 146 +++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 180 insertions(+), 69 deletions(-) (limited to 'src') diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index a851c5fa..0b9fe077 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -913,6 +913,11 @@ let general_typ_of_annot annot = let general_typ_of (E_aux (_,annot)) = general_typ_of_annot annot +let is_prefix s s' = + let l = String.length s in + String.length s' >= l && + String.sub s' 0 l = s + let prefix_recordtype = true let report = Reporting.err_unreachable let doc_exp, doc_let = @@ -1181,7 +1186,7 @@ let doc_exp, doc_let = if Env.is_extern f env "coq" then string (Env.get_extern f env "coq"), true, false, false else if IdSet.mem f ctxt.recursive_ids - then string "_rec_" ^^ doc_id f, false, false, true + then doc_id f, false, false, true else doc_id f, false, false, false in let (tqs,fn_ty) = Env.get_val_spec_orig f env in let arg_typs, ret_typ, eff = match fn_ty with @@ -1236,10 +1241,13 @@ let doc_exp, doc_let = then hang 2 (call ^^ break 1 ^^ parens (flow (comma ^^ break 1) (List.map2 (doc_arg false) args arg_typs))) else let main_call = call :: List.map2 (doc_arg true) args arg_typs in - let all = if is_rec then main_call @ - [parens (string "_limit - 1"); - parens (string "Acc_inv _acc (_limit_is_limit _limit_ok)")] - else main_call + let all = + if is_rec then main_call @ + [parens (string "_limit_reduces _acc")] + else match f with + | Id_aux (Id x,_) when is_prefix "#rec#" x -> + main_call @ [parens (string "Zwf_well_founded _ _")] + | _ -> main_call in hang 2 (flow (break 1) all) in (* Decide whether to unpack an existential result, pack one, or cast. @@ -2122,66 +2130,31 @@ let doc_funcl rec_opt (FCL_aux(FCL_Funcl(id, pexp), annot)) = then string "M" ^^ space ^^ parens (doc_typ ctxt ret_typ) else doc_typ ctxt ret_typ in - let intropp, idpp, accpp, measurepp, fixupspp, postpp = match rec_opt with - | Rec_aux (Rec_measure (meas_pat,meas_exp),_) -> - let check_ids (arg_pat,_) m_pat = - match arg_pat, m_pat with - | P_aux ((P_id arg_id | P_typ (_,P_aux (P_id arg_id,_))),_), - P_aux ((P_id m_id | P_typ (_,P_aux (P_id m_id,_))),_) -> - if Id.compare arg_id m_id == 0 then () else - failwith "TODO" - | _, P_aux (P_wild,_) -> () (* TODO generalise *) - | _ -> failwith "TODO" - in - let idpp = doc_id id in - let recidpp = string "_rec_" ^^ idpp in - let patnames = List.map (function - | P_aux (P_id id,_), _ -> doc_id id - | P_aux (P_typ (_,P_aux (P_id id,_)),_), _ -> doc_id id - | p,_ -> raise (Reporting.err_unreachable (pat_loc p) __POS__ - "Pattern has not been reduced to a simple binder")) - pats in - let quantnames, constrnames = typquant_names_separate ctxt tq in - let atomconstrsnames = List.map (fun _ -> underscore) atom_constrs in - let fixupspp = Util.map_filter (fun (pat,typ) -> - match pat_is_plain_binder env pat with - | Some id -> begin - match destruct_exist env (expand_range_type typ) with - | Some (_, NC_aux (NC_true,_), _) -> None - | Some ([kid], nc, - Typ_aux (Typ_app (Id_aux (Id "atom",_), - [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid',_)),_)]),_)) - when Kid.compare kid kid' == 0 -> - Some (string "let " ^^ doc_id id ^^ string " := projT1 " ^^ doc_id id ^^ string " in") - | _ -> None - end - | None -> None) pats - in - let no_fixups = match fixupspp with [] -> true | _ -> false in - let measure_pp = - match pats, meas_pat with - | _, P_aux (P_tup ps,_) when List.length pats = List.length ps -> - let () = List.iter2 check_ids pats ps in - doc_exp ctxt no_fixups meas_exp - | [pat], _ -> - let () = check_ids pat meas_pat in - doc_exp ctxt no_fixups meas_exp - | _, _ -> failwith "TODO" - in - let measure_pp = match fixupspp with - [] -> measure_pp - | _ -> parens (flow (break 1) fixupspp ^/^ measure_pp) + let idpp = doc_id id in + let intropp, accpp, measurepp, fixupspp = match rec_opt with + | Rec_aux (Rec_measure _,_) -> + let fixupspp = + Util.map_filter (fun (pat,typ) -> + match pat_is_plain_binder env pat with + | Some id -> begin + match destruct_exist env (expand_range_type typ) with + | Some (_, NC_aux (NC_true,_), _) -> None + | Some ([kid], nc, + Typ_aux (Typ_app (Id_aux (Id "atom",_), + [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid',_)),_)]),_)) + when Kid.compare kid kid' == 0 -> + Some (string "let " ^^ doc_id id ^^ string " := projT1 " ^^ doc_id id ^^ string " in") + | _ -> None + end + | None -> None) pats in string "Fixpoint", - recidpp, - [parens (string "_limit : Z"); - parens (string "_acc : Acc (Zwf 0) _limit")], + [parens (string "_acc : Acc (Zwf 0) _rec_limit")], [string "{struct _acc}"], - fixupspp, - hardline ^^ string "Definition " ^^ idpp ^/^ flow (break 1) (quantspp @ patspp :: constrspp @ atom_constrs) ^/^ coloneq ^/^ recidpp ^/^ flow (break 1) (quantnames @ patnames @ constrnames @ atomconstrsnames) ^/^ measure_pp ^/^ string "(Zwf_well_founded _ _)." + fixupspp | Rec_aux (r,_) -> let d = match r with Rec_nonrec -> "Definition" | _ -> "Fixpoint" in - string d, doc_id id, [], [], [], empty + string d, [], [], [] in (* Work around Coq bug 7975 about pattern binders followed by implicit arguments *) let implicitargs = @@ -2202,17 +2175,11 @@ let doc_funcl rec_opt (FCL_aux(FCL_Funcl(id, pexp), annot)) = "guarded pattern expression should have been rewritten before pretty-printing") in let bodypp = doc_fun_body ctxt exp in let bodypp = if effectful eff || not build_ex then bodypp else string "build_ex" ^^ parens bodypp in - let bodypp = match rec_opt with - | Rec_aux (Rec_measure _,_) -> - string "assert_exp' (_limit >? 0) \"termination limit reached\" >>= fun _limit_ok =>" ^/^ - separate (break 1) fixupspp ^/^ - bodypp - | _ -> bodypp - in + let bodypp = separate (break 1) fixupspp ^/^ bodypp in group (prefix 3 1 (flow (break 1) ([intropp; idpp] @ quantspp @ [patspp] @ constrspp @ [atom_constr_pp] @ accpp) ^/^ flow (break 1) (measurepp @ [colon; retpp; coloneq])) - (bodypp ^^ dot)) ^^ postpp ^^ implicitargs + (bodypp ^^ dot)) ^^ implicitargs let get_id = function | [] -> failwith "FD_function with empty list" diff --git a/src/rewrites.ml b/src/rewrites.ml index c6e2743e..33b50459 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -4760,7 +4760,150 @@ let minimise_recursive_functions (Defs defs) = | d -> d in Defs (List.map rewrite_def defs) +(* Make recursive functions with a measure use the measure as an + explicit recursion limit, enforced by an assertion. *) +let rewrite_explicit_measure (Defs defs) = + let scan_function measures = function + | FD_aux (FD_function (Rec_aux (Rec_measure (mpat,mexp),rl),topt,effopt, + FCL_aux (FCL_Funcl (id,_),_)::_),ann) -> + Bindings.add id (mpat,mexp) measures + | _ -> measures + in + let scan_def measures = function + | DEF_fundef fd -> scan_function measures fd + | _ -> measures + in + let measures = List.fold_left scan_def Bindings.empty defs in + let add_escape eff = + union_effects eff (mk_effect [BE_escape]) + in + (* NB: the Coq backend relies on recognising the #rec# prefix *) + let rec_id = function + | Id_aux (Id id,l) + | Id_aux (DeIid id,l) -> Id_aux (Id ("#rec#" ^ id),Generated l) + in + let limit = mk_id "#reclimit" in + (* Add helper function with extra argument to spec *) + let rewrite_spec (VS_aux (VS_val_spec (typsch,id,extern,flag),ann) as vs) = + match Bindings.find id measures with + | _ -> begin + match typsch with + | TypSchm_aux (TypSchm_ts (tq, + Typ_aux (Typ_fn (args,res,eff),typl)),tsl) -> + [VS_aux (VS_val_spec ( + TypSchm_aux (TypSchm_ts (tq, + Typ_aux (Typ_fn (args@[int_typ],res,add_escape eff),typl)),tsl) + ,rec_id id,extern,flag),ann); + VS_aux (VS_val_spec ( + TypSchm_aux (TypSchm_ts (tq, + Typ_aux (Typ_fn (args,res,add_escape eff),typl)),tsl) + ,id,extern,flag),ann)] + | _ -> [vs] (* TODO warn *) + end + | exception Not_found -> [vs] + in + (* Add extra argument and assertion to each funcl, and rewrite recursive calls *) + let rewrite_funcl (FCL_aux (FCL_Funcl (id,pexp),ann) as fcl) = + let loc = Parse_ast.Generated (fst ann) in + let P_aux (pat,pann),guard,body,ann = destruct_pexp pexp in + let extra_pat = P_aux (P_id limit,(loc,empty_tannot)) in + let pat = match pat with + | P_tup pats -> P_tup (pats@[extra_pat]) + | p -> P_tup [P_aux (p,pann);extra_pat] + in + let assert_exp = + E_aux (E_assert + (E_aux (E_app (mk_id "gteq_int", + [E_aux (E_id limit,(loc,empty_tannot)); + E_aux (E_lit (L_aux (L_num Big_int.zero,loc)),(loc,empty_tannot))]), + (loc,empty_tannot)), + (E_aux (E_lit (L_aux (L_string "recursion limit reached",loc)),(loc,empty_tannot)))), + (loc,empty_tannot)) + in + let tick = + E_aux (E_app (mk_id "sub_int", + [E_aux (E_id limit,(loc,empty_tannot)); + E_aux (E_lit (L_aux (L_num (Big_int.of_int 1),loc)),(loc,empty_tannot))]), + (loc,empty_tannot)) + in + let open Rewriter in + let body = + fold_exp { id_exp_alg with + e_app = (fun (f,args) -> + if Id.compare f id == 0 + then E_app (rec_id id, args@[tick]) + else E_app (f, args)) + } body + in + let body = E_aux (E_block [assert_exp; body],(loc,empty_tannot)) in + FCL_aux (FCL_Funcl (rec_id id, construct_pexp (P_aux (pat,pann),guard,body,ann)),ann) + in + let rewrite_function (FD_aux (FD_function (r,t,e,fcls),ann) as fd) = + let loc = Parse_ast.Generated (fst ann) in + match fcls with + | FCL_aux (FCL_Funcl (id,_),fcl_ann)::_ -> begin + match Bindings.find id measures with + | (measure_pat, measure_exp) -> + let e = match e with + | Effect_opt_aux (Effect_opt_pure, _) -> + Effect_opt_aux (Effect_opt_effect (mk_effect [BE_escape]), loc) + | Effect_opt_aux (Effect_opt_effect eff,_) -> + Effect_opt_aux (Effect_opt_effect (add_escape eff), loc) + in + let arg_typs = match Env.get_val_spec id (env_of_annot fcl_ann) with + | _, Typ_aux (Typ_fn (args,_,_),_) -> args + | _, _ -> raise (Reporting.err_unreachable (fst ann) __POS__ + "Function doesn't have function type") + in + let measure_pats = match arg_typs, measure_pat with + | [_], _ -> [measure_pat] + | _, P_aux (P_tup ps,_) -> ps + | _, _ -> [measure_pat] + in + let mk_wrap i (P_aux (p,(l,_))) = + let id = + match p with + | P_id id + | P_typ (_,(P_aux (P_id id,_))) -> id + | P_wild + | P_typ (_,(P_aux (P_wild,_))) -> + mk_id ("_arg" ^ string_of_int i) + | _ -> raise (Reporting.err_todo l "Measure patterns can only be identifiers or wildcards") + in + P_aux (P_id id,(loc,empty_tannot)), + E_aux (E_id id,(loc,empty_tannot)) + in + let wpats,wexps = List.split (Util.list_mapi mk_wrap measure_pats) in + let wpat = match wpats with + | [wpat] -> wpat + | _ -> P_aux (P_tup wpats,(loc,empty_tannot)) + in + let wbody = E_aux (E_app (rec_id id,wexps@[measure_exp]),(loc,empty_tannot)) in + let wrapper = + FCL_aux (FCL_Funcl (id, Pat_aux (Pat_exp (wpat,wbody),(loc,empty_tannot))),(loc,empty_tannot)) + in + let new_rec = + Rec_aux (Rec_measure (P_aux (P_tup (List.map (fun _ -> P_aux (P_wild,(loc,empty_tannot))) measure_pats @ [P_aux (P_id limit,(loc,empty_tannot))]),(loc,empty_tannot)), E_aux (E_id limit, (loc,empty_tannot))), loc) + in + [FD_aux (FD_function (new_rec,t,e,List.map rewrite_funcl fcls),ann); + FD_aux (FD_function (Rec_aux (Rec_nonrec,loc),t,e,[wrapper]),ann)] + | exception Not_found -> [fd] + end + | _ -> [fd] + in + let rewrite_def = function + | DEF_spec vs -> List.map (fun vs -> DEF_spec vs) (rewrite_spec vs) + | DEF_fundef fd -> List.map (fun f -> DEF_fundef f) (rewrite_function fd) + | d -> [d] + in + Defs (List.flatten (List.map rewrite_def defs)) + let recheck_defs defs = fst (Type_error.check initial_env defs) +let recheck_defs_without_effects defs = + let () = opt_no_effects := true in + let result,_ = Type_error.check initial_env defs in + let () = opt_no_effects := false in + result let remove_mapping_valspecs (Defs defs) = let allowed_def def = @@ -4888,8 +5031,9 @@ let rewrite_defs_coq = [ ("sizeof", rewrite_sizeof); ("early_return", rewrite_defs_early_return); ("make_cases_exhaustive", MakeExhaustive.rewrite); + ("rewrite_explicit_measure", rewrite_explicit_measure); + ("recheck_defs_without_effects", recheck_defs_without_effects); ("fix_val_specs", rewrite_fix_val_specs); - ("recheck_defs", recheck_defs); ("remove_blocks", rewrite_defs_remove_blocks); ("letbind_effects", rewrite_defs_letbind_effects); ("remove_e_assign", rewrite_defs_remove_e_assign); -- cgit v1.2.3 From aa6a4d4630e05e50782ec6880ada116ac4fbe795 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 12 Dec 2018 19:11:22 +0000 Subject: Add parallelism limit to C and builtins test Spawning a process for every test and running every test in parallel is quite RAM intensive (up to about 8gb) especially when running valgrind on every test in parallel. Now we only run up to TEST_PAR tests in parallel (default 4). --- src/type_check.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'src') diff --git a/src/type_check.ml b/src/type_check.ml index 47275594..8359dac2 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -2321,8 +2321,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ let inferred_exp = infer_funapp l env f xs (Some typ) in type_coercion env inferred_exp typ | E_if (cond, then_branch, else_branch), _ -> - (* let cond' = crule check_exp env cond (mk_typ (Typ_id (mk_id "bool"))) in *) - let cond' = irule infer_exp env cond in + let cond' = try irule infer_exp env cond with Type_error _ -> crule check_exp env cond bool_typ in begin match destruct_exist (typ_of cond') with | Some (kopts, nc, Typ_aux (Typ_app (ab, [A_aux (A_bool flow, _)]), _)) when string_of_id ab = "atom_bool" -> let env = add_existential l kopts nc env in -- cgit v1.2.3 From b9a051d186593fdd3bbf295e20f7ace78e668580 Mon Sep 17 00:00:00 2001 From: Alasdair Date: Wed, 12 Dec 2018 22:37:04 +0000 Subject: Fix some small bugs Now all ARM, RISC-V, and CHERI-MIPS all build successfully with type-checking changes. All typechecker/c/ocaml/lem/builtin/riscv/arm tests are now working as well. Now the python test scripts can run sequentially with TEST_PAR=1 there's no reason to keep the old shell versions around anymore. --- src/constraint.ml | 3 ++- src/type_check.ml | 34 ++++++++++++---------------------- 2 files changed, 14 insertions(+), 23 deletions(-) (limited to 'src') diff --git a/src/constraint.ml b/src/constraint.ml index a16b8c73..7ead0cc8 100644 --- a/src/constraint.ml +++ b/src/constraint.ml @@ -104,6 +104,8 @@ let to_smt l vars constr = | Nexp_times (nexp1, nexp2) -> sfun "*" [smt_nexp nexp1; smt_nexp nexp2] | Nexp_sum (nexp1, nexp2) -> sfun "+" [smt_nexp nexp1; smt_nexp nexp2] | Nexp_minus (nexp1, nexp2) -> sfun "-" [smt_nexp nexp1; smt_nexp nexp2] + | Nexp_exp (Nexp_aux (Nexp_constant c, _)) when Big_int.greater c Big_int.zero -> + Atom (Big_int.to_string (Big_int.pow_int_positive 2 (Big_int.to_int c))) | Nexp_exp nexp -> sfun "^" [Atom "2"; smt_nexp nexp] | Nexp_neg nexp -> sfun "-" [smt_nexp nexp] in @@ -228,7 +230,6 @@ let call_z3 l vars constraints = result let rec solve_z3 l vars constraints var = - let problems = [constraints] in let z3_file = smtlib_of_constraints ~get_model:true l vars constraints in (* prerr_endline (Printf.sprintf "SMTLIB2 constraints are: \n%s%!" z3_file); *) diff --git a/src/type_check.ml b/src/type_check.ml index 8359dac2..1216786e 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -1244,28 +1244,17 @@ let prove_z3 env (NC_aux (_, l) as nc) = | Constraint.Sat -> typ_debug (lazy "sat"); false | Constraint.Unknown -> typ_debug (lazy "unknown"); false -let solve env nexp = failwith "WIP" - - (* typ_print (lazy ("Solve " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_nexp nexp ^ " = ?")); +let solve env (Nexp_aux (_, l) as nexp) = + typ_print (lazy (Util.("Solve " |> red |> clear) ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) + ^ " |- " ^ string_of_nexp nexp ^ " = ?")); match nexp with | Nexp_aux (Nexp_constant n,_) -> Some n | _ -> - let bindings = ref KBindings.empty in - let fresh_var kid = - let n = KBindings.cardinal !bindings in - bindings := KBindings.add kid n !bindings; - n - in - let var_of kid = - try KBindings.find kid !bindings with - | Not_found -> fresh_var kid - in - let env = Env.add_typ_var Parse_ast.Unknown (mk_kid "solve#") K_int env in - let constr = Constraint.conj (nc_constraints env var_of (Env.get_constraints env)) - (nc_constraint env var_of (nc_eq (nvar (mk_kid "solve#")) nexp)) - in - Constraint.solve_z3 constr (var_of (mk_kid "solve#")) - *) + let env = Env.add_typ_var Parse_ast.Unknown (mk_kopt K_int (mk_kid "solve#")) env in + let vars = Env.get_typ_vars env in + let vars = KBindings.filter (fun _ k -> match k with K_int | K_bool -> true | _ -> false) vars in + let constr = List.fold_left nc_and (nc_eq (nvar (mk_kid "solve#")) nexp) (Env.get_constraints env) in + Constraint.solve_z3 l vars constr (mk_kid "solve#") let prove env nc = typ_print (lazy (Util.("Prove " |> red |> clear) ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_n_constraint nc)); @@ -1515,13 +1504,13 @@ and unify_nexp l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (nexp_au mod(m, C) = 0 && C != 0 --> (C * n = m <--> n = m / C) - to help us unify multiplications and divisions. *) + to help us unify multiplications and divisions. let valid n c = prove env (nc_eq (napp (mk_id "mod") [n; c]) (nint 0)) && prove env (nc_neq c (nint 0)) in if KidSet.is_empty (nexp_frees n1b) && valid nexp2 n1b then unify_nexp l env goals n1a (napp (mk_id "div") [nexp2; n1b]) else if KidSet.is_empty (nexp_frees n1a) && valid nexp2 n1a then - unify_nexp l env goals n1b (napp (mk_id "div") [nexp2; n1a]) - else if KidSet.is_empty (nexp_frees n1a) then + unify_nexp l env goals n1b (napp (mk_id "div") [nexp2; n1a]) *) + if KidSet.is_empty (nexp_frees n1a) then begin match nexp_aux2 with | Nexp_times (n2a, n2b) when prove env (NC_aux (NC_equal (n1a, n2a), Parse_ast.Unknown)) -> @@ -2329,6 +2318,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ let else_branch' = crule check_exp (Env.add_constraint (nc_not flow) env) else_branch typ in annot_exp (E_if (cond', then_branch', else_branch')) typ | _ -> + let cond' = type_coercion env cond' bool_typ in let then_branch' = crule check_exp (add_opt_constraint (assert_constraint env true cond') env) then_branch typ in let else_branch' = crule check_exp (add_opt_constraint (option_map nc_not (assert_constraint env false cond')) env) else_branch typ in annot_exp (E_if (cond', then_branch', else_branch')) typ -- cgit v1.2.3 From f19023bedee7b32a39b23907b0a1cd732a1e3bc9 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Thu, 13 Dec 2018 16:01:00 +0000 Subject: Add a stub file for future cgen generations --- src/cgen_backend.ml | 77 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 77 insertions(+) create mode 100644 src/cgen_backend.ml (limited to 'src') diff --git a/src/cgen_backend.ml b/src/cgen_backend.ml new file mode 100644 index 00000000..77029c9e --- /dev/null +++ b/src/cgen_backend.ml @@ -0,0 +1,77 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Ast_util +open PPrint + +let to_string doc = + let b = Buffer.create 120 in + ToBuffer.pretty 1. 120 b doc; + Buffer.contents b + +let do_mapdef_thing (MD_aux (MD_mapping (_, _, clauses), _)) = + print_endline ("Mapping has " ^ string_of_int (List.length clauses) ^ " clauses") + +let rec list_registers = function + | [] -> () + | (DEF_reg_dec reg) :: defs -> + print_endline (to_string (Pretty_print_sail.doc_dec reg)); + list_registers defs + | (DEF_mapdef mapdef) :: defs -> + do_mapdef_thing mapdef; + list_registers defs + | def :: defs -> + list_registers defs + +let output env (Defs defs) = + let xlenbits = mk_typ (Typ_id (mk_id "xlenbits")) in + print_endline (string_of_typ (Type_check.Env.expand_synonyms env xlenbits)); + list_registers defs -- cgit v1.2.3 From b167a59affdb6428fa0656a092b335a3a6899d56 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Thu, 13 Dec 2018 16:20:48 +0000 Subject: Add hooks to call cgen stub file for RISC-V --- src/sail.ml | 7 +++++++ src/sail_lib.ml | 19 +++++++++++++++---- 2 files changed, 22 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/sail.ml b/src/sail.ml index 73173946..0d26df9c 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -64,6 +64,7 @@ let opt_print_ocaml = ref false let opt_print_c = ref false let opt_print_latex = ref false let opt_print_coq = ref false +let opt_print_cgen = ref false let opt_memo_z3 = ref false let opt_sanity = ref false let opt_includes_c = ref ([]:string list) @@ -143,6 +144,9 @@ let options = Arg.align ([ ( "-trace", Arg.Tuple [Arg.Set C_backend.opt_trace; Arg.Set Ocaml_backend.opt_trace_ocaml], " Instrument ouput with tracing"); + ( "-cgen", + Arg.Set opt_print_cgen, + " Generate CGEN source"); ( "-lem", Arg.Set opt_print_lem, " output a Lem translated version of the input"); @@ -352,6 +356,9 @@ let main() = Util.opt_warnings := true; C_backend.compile_ast (C_backend.initial_ctx type_envs) (!opt_includes_c) ast_c else ()); + (if !(opt_print_cgen) + then Cgen_backend.output type_envs ast + else ()); (if !(opt_print_lem) then let mwords = !Pretty_print_lem.opt_mwords in diff --git a/src/sail_lib.ml b/src/sail_lib.ml index a718e6d5..620df900 100644 --- a/src/sail_lib.ml +++ b/src/sail_lib.ml @@ -578,8 +578,14 @@ let gteq_real (x, y) = Rational.geq x y let to_real x = Rational.of_int (Big_int.to_int x) (* FIXME *) let negate_real x = Rational.neg x -let print_real (str, r) = print_string "REAL\n" -let prerr_real (str, r) = prerr_string "REAL\n" +let real_to_string x = + if Big_int.equal (Rational.den x) (Big_int.of_int 1) then + Big_int.to_string (Rational.num x) + else + Big_int.to_string (Rational.num x) ^ "/" ^ Big_int.to_string (Rational.den x) + +let print_real (str, r) = print_endline (str ^ real_to_string r) +let prerr_real (str, r) = prerr_endline (str ^ real_to_string r) let round_down x = Rational.floor x (* Num.big_int_of_num (Num.floor_num x) *) let round_up x = Rational.ceiling x (* Num.big_int_of_num (Num.ceiling_num x) *) @@ -592,6 +598,12 @@ let sub_real (x, y) = Rational.sub x y let abs_real x = Rational.abs x +let sqrt x = + if Big_int.equal (Rational.den x) (Big_int.of_int 1) then + Big_int.sqrt (Rational.den x) + else + failwith "sqrt" + let lt (x, y) = Big_int.less x y let gt (x, y) = Big_int.greater x y let lteq (x, y) = Big_int.less_equal x y @@ -620,8 +632,7 @@ let real_of_string str = | [whole] -> Rational.of_int (int_of_string str) | _ -> failwith "invalid real literal" -(* Not a very good sqrt implementation *) -let sqrt_real x = failwith "sqrt_real" (* real_of_string (string_of_float (sqrt (Num.float_of_num x))) *) +let sqrt_real x = failwith "sqrt_real" let print str = Pervasives.print_string str -- cgit v1.2.3 From 976ce06c640a61838276f8b31a9f13dbe8d6e4ec Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Thu, 13 Dec 2018 17:26:36 +0000 Subject: Fixing rationals in Sail interpreter and OCaml --- src/constant_fold.ml | 1 + src/sail_lib.ml | 37 +++++++++++++++++++++++++++---------- src/value.ml | 44 ++++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 70 insertions(+), 12 deletions(-) (limited to 'src') diff --git a/src/constant_fold.ml b/src/constant_fold.ml index b86f4ea5..9e474912 100644 --- a/src/constant_fold.ml +++ b/src/constant_fold.ml @@ -96,6 +96,7 @@ let safe_primops = "print_bits"; "print_int"; "print_string"; + "print_real"; "prerr_bits"; "prerr_int"; "prerr_string"; diff --git a/src/sail_lib.ml b/src/sail_lib.ml index 620df900..7bb176c5 100644 --- a/src/sail_lib.ml +++ b/src/sail_lib.ml @@ -578,20 +578,21 @@ let gteq_real (x, y) = Rational.geq x y let to_real x = Rational.of_int (Big_int.to_int x) (* FIXME *) let negate_real x = Rational.neg x -let real_to_string x = +let string_of_real x = if Big_int.equal (Rational.den x) (Big_int.of_int 1) then Big_int.to_string (Rational.num x) else Big_int.to_string (Rational.num x) ^ "/" ^ Big_int.to_string (Rational.den x) -let print_real (str, r) = print_endline (str ^ real_to_string r) -let prerr_real (str, r) = prerr_endline (str ^ real_to_string r) +let print_real (str, r) = print_endline (str ^ string_of_real r) +let prerr_real (str, r) = prerr_endline (str ^ string_of_real r) -let round_down x = Rational.floor x (* Num.big_int_of_num (Num.floor_num x) *) -let round_up x = Rational.ceiling x (* Num.big_int_of_num (Num.ceiling_num x) *) +let round_down x = Rational.floor x +let round_up x = Rational.ceiling x let quotient_real (x, y) = Rational.div x y -let mult_real (x, y) = Rational.mul x y (* Num.mult_num x y *) -let real_power (x, y) = failwith "real_power" (* Num.power_num x (Num.num_of_big_int y) *) +let div_real (x, y) = Rational.div x y +let mult_real (x, y) = Rational.mul x y +let real_power (x, y) = failwith "real_power" let int_power (x, y) = Big_int.pow_int x (Big_int.to_int y) let add_real (x, y) = Rational.add x y let sub_real (x, y) = Rational.sub x y @@ -599,10 +600,26 @@ let sub_real (x, y) = Rational.sub x y let abs_real x = Rational.abs x let sqrt x = - if Big_int.equal (Rational.den x) (Big_int.of_int 1) then - Big_int.sqrt (Rational.den x) + let precision = 30 in + let s = Big_int.sqrt (Rational.num x) in + if Big_int.equal (Rational.den x) (Big_int.of_int 1) && Big_int.equal (Big_int.mul s s) (Rational.num x) then + to_real s else - failwith "sqrt" + let p = ref (to_real (Big_int.sqrt (Big_int.div (Rational.num x) (Rational.den x)))) in + let n = ref (Rational.of_int 0) in + let convergence = ref (Rational.div (Rational.of_int 1) (Rational.of_big_int (Big_int.pow_int_positive 10 precision))) in + let quit_loop = ref false in + while not !quit_loop do + n := Rational.div (Rational.add !p (Rational.div x !p)) (Rational.of_int 2); + + if Rational.lt (Rational.abs (Rational.sub !p !n)) !convergence then + quit_loop := true + else + p := !n + done; + !n + +let random_real () = Rational.div (Rational.of_int (Random.bits ())) (Rational.of_int (Random.bits())) let lt (x, y) = Big_int.less x y let gt (x, y) = Big_int.greater x y diff --git a/src/value.ml b/src/value.ml index 589e956a..a4ce225e 100644 --- a/src/value.ml +++ b/src/value.ml @@ -388,7 +388,7 @@ let rec string_of_value = function | V_unit -> "()" | V_string str -> "\"" ^ str ^ "\"" | V_ref str -> "ref " ^ str - | V_real r -> "REAL" (* No Rational.to_string *) + | V_real r -> Sail_lib.string_of_real r | V_ctor (str, vals) -> str ^ "(" ^ Util.string_of_list ", " string_of_value vals ^ ")" | V_record record -> "{" ^ Util.string_of_list ", " (fun (field, v) -> field ^ "=" ^ string_of_value v) (StringMap.bindings record) ^ "}" @@ -493,6 +493,18 @@ let value_to_real = function | [v] -> V_real (Sail_lib.to_real (coerce_int v)) | _ -> failwith "value to_real" +let value_print_real = function + | [v1; v2] -> output_endline (coerce_string v1 ^ string_of_value v2); V_unit + | _ -> failwith "value print_real" + +let value_random_real = function + | [_] -> V_real (Sail_lib.random_real ()) + | _ -> failwith "value random_real" + +let value_sqrt_real = function + | [v] -> V_real (Sail_lib.sqrt (coerce_real v)) + | _ -> failwith "value sqrt_real" + let value_quotient_real = function | [v1; v2] -> V_real (Sail_lib.quotient_real (coerce_real v1, coerce_real v2)) | _ -> failwith "value quotient_real" @@ -505,6 +517,26 @@ let value_round_down = function | [v] -> V_int (Sail_lib.round_down (coerce_real v)) | _ -> failwith "value round_down" +let value_add_real = function + | [v1; v2] -> V_real (Sail_lib.add_real (coerce_real v1, coerce_real v2)) + | _ -> failwith "value add_real" + +let value_sub_real = function + | [v1; v2] -> V_real (Sail_lib.sub_real (coerce_real v1, coerce_real v2)) + | _ -> failwith "value sub_real" + +let value_mult_real = function + | [v1; v2] -> V_real (Sail_lib.mult_real (coerce_real v1, coerce_real v2)) + | _ -> failwith "value mult_real" + +let value_div_real = function + | [v1; v2] -> V_real (Sail_lib.div_real (coerce_real v1, coerce_real v2)) + | _ -> failwith "value div_real" + +let value_abs_real = function + | [v] -> V_real (Sail_lib.abs_real (coerce_real v)) + | _ -> failwith "value abs_real" + let value_eq_real = function | [v1; v2] -> V_bool (Sail_lib.eq_real (coerce_real v1, coerce_real v2)) | _ -> failwith "value eq_real" @@ -615,9 +647,17 @@ let primops = ("gt_real", value_gt_real); ("lteq_real", value_lt_real); ("gteq_real", value_gt_real); + ("add_real", value_add_real); + ("sub_real", value_sub_real); + ("mult_real", value_mult_real); ("round_up", value_round_up); ("round_down", value_round_down); - ("quotient_real", value_quotient_real); + ("quotient_real", value_div_real); + ("abs_real", value_abs_real); + ("div_real", value_div_real); + ("sqrt_real", value_sqrt_real); + ("print_real", value_print_real); + ("random_real", value_random_real); ("undefined_unit", fun _ -> V_unit); ("undefined_bit", fun _ -> V_bit Sail_lib.B0); ("undefined_int", fun _ -> V_int Big_int.zero); -- cgit v1.2.3 From 7bbed580db0abeaa1acaa47610f01571ffe75ff4 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Thu, 13 Dec 2018 19:06:50 +0000 Subject: Fix issue with sizeof-rewriting and monomorphisation Sizeof-rewriting could introduce extra arguments to functions that instantiate_simple_equations could fill in with overly complicated types, causing unification to fail when building lem. --- src/type_check.ml | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/type_check.ml b/src/type_check.ml index 0f083823..3cfa4bb6 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -2897,7 +2897,7 @@ and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as let checked_exp = crule check_exp env exp (lexp_typ_of inferred_lexp) in annot_assign inferred_lexp checked_exp, env with Type_error (l, err') -> typ_raise l (Err_because (err', err)) - + and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = typ_print (lazy ("Binding mutable " ^ string_of_lexp lexp ^ " to " ^ string_of_typ typ)); let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, Some ((env, typ, eff),None))) in @@ -3260,6 +3260,7 @@ and instantiation_of_without_type (E_aux (exp_aux, (l, _)) as exp) = | _ -> invalid_arg ("instantiation_of expected application, got " ^ string_of_exp exp) and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ = + typ_print (lazy (Util.("Function " |> cyan |> clear) ^ string_of_id f)); let annot_exp exp typ eff = E_aux (exp, (l, Some ((env, typ, eff), expected_ret_typ))) in let is_bound env kid = KBindings.mem kid (Env.get_typ_vars env) in @@ -3282,6 +3283,14 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ = | _ -> typ_error l (string_of_typ f_typ ^ " is not a function type") in + let unifiers = instantiate_simple_equations !quants in + typ_debug (lazy "Instantiating from equations"); + typ_debug (lazy (string_of_list ", " (fun (kid, arg) -> string_of_kid kid ^ " => " ^ string_of_typ_arg arg) (KBindings.bindings unifiers))); + all_unifiers := unifiers; + let typ_args = List.map (subst_unifiers unifiers) typ_args in + List.iter (fun unifier -> quants := instantiate_quants !quants unifier) (KBindings.bindings unifiers); + List.iter (fun (v, arg) -> typ_ret := typ_subst v arg !typ_ret) (KBindings.bindings unifiers); + typ_debug (lazy ("Quantifiers " ^ Util.string_of_list ", " string_of_quant_item !quants)); if not (List.length typ_args = List.length xs) then -- cgit v1.2.3 From cbd4eedf0d278572e70b04d9e9ef8750c4cae0a4 Mon Sep 17 00:00:00 2001 From: Thomas Bauereiss Date: Thu, 13 Dec 2018 20:37:36 +0000 Subject: Remove redundant zero extensions more aggressively in mono rewrites subrange_subrange_concat does a zero extension internally, so another zero extension of its result is redundant and can lead to a type error in Lem (because Lem's type system cannot calculate the length of the intermediate result of subrange_subrange_concat). --- src/monomorphise.ml | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/monomorphise.ml b/src/monomorphise.ml index 0e362d3b..4bb1876c 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -3668,6 +3668,11 @@ let is_constant_vec_typ env typ = let rewrite_app env typ (id,args) = let is_append = is_id env (Id "append") in + let is_zero_extend = + is_id env (Id "Extend") id || is_id env (Id "ZeroExtend") id || + is_id env (Id "zero_extend") id || is_id env (Id "sail_zero_extend") id || + is_id env (Id "mips_zero_extend") id + in let try_cast_to_typ (E_aux (e,_) as exp) = let (size,order,bittyp) = vector_typ_args_of (Env.base_typ_of env typ) in match size with @@ -3824,7 +3829,7 @@ let rewrite_app env typ (id,args) = [vector1; start1; end1]) | _ -> E_app (id,args) - else if is_id env (Id "Extend") id || is_id env (Id "ZeroExtend") id || is_id env (Id "zero_extend") id then + else if is_zero_extend then let is_subrange = is_id env (Id "vector_subrange") in let is_slice = is_id env (Id "slice") in let is_zeros = is_id env (Id "Zeros") in @@ -3846,11 +3851,16 @@ let rewrite_app env typ (id,args) = -> E_app (mk_id "place_slice", [vector1; start1; length1; length2]) - (* If we've already rewritten to slice_slice_concat, we can just drop the - zero extension because it can do it *) - | (E_aux (E_cast (_, (E_aux (E_app (Id_aux (Id "slice_slice_concat",_), args),_))),_)):: + (* If we've already rewritten to slice_slice_concat or subrange_subrange_concat, + we can just drop the zero extension because those functions can do it + themselves *) + | (E_aux (E_cast (_, (E_aux (E_app (Id_aux ((Id "slice_slice_concat" | Id "subrange_subrange_concat"),_) as op, args),_))),_)):: + ([] | [_;E_aux (E_id (Id_aux (Id "unsigned",_)),_)]) + -> E_app (op, args) + + | (E_aux (E_app (Id_aux ((Id "slice_slice_concat" | Id "subrange_subrange_concat"),_) as op, args),_)):: ([] | [_;E_aux (E_id (Id_aux (Id "unsigned",_)),_)]) - -> E_app (mk_id "slice_slice_concat", args) + -> E_app (op, args) | [E_aux (E_app (slice1, [vector1; start1; length1]),_)] when is_slice slice1 && not (is_constant length1) -> -- cgit v1.2.3 From 2d17ea6097cdf6a948b0313cb02ddf7ceb0b1d1f Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Thu, 13 Dec 2018 23:19:57 +0000 Subject: Fix typo in boolean constraint desugaring --- src/initial_check.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/initial_check.ml b/src/initial_check.ml index 8730d909..17b4b515 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -213,7 +213,7 @@ and to_ast_constraint ctx (P.ATyp_aux (aux, l) as atyp) = | P.ATyp_app (Id_aux (DeIid op, _) as id, [t1; t2]) -> begin match op with | "==" -> NC_equal (to_ast_nexp ctx t1, to_ast_nexp ctx t2) - | "!=" -> NC_equal (to_ast_nexp ctx t1, to_ast_nexp ctx t2) + | "!=" -> NC_not_equal (to_ast_nexp ctx t1, to_ast_nexp ctx t2) | ">=" -> NC_bounded_ge (to_ast_nexp ctx t1, to_ast_nexp ctx t2) | "<=" -> NC_bounded_le (to_ast_nexp ctx t1, to_ast_nexp ctx t2) | ">" -> NC_bounded_ge (to_ast_nexp ctx t1, nsum (to_ast_nexp ctx t2) (nint 1)) -- cgit v1.2.3 From d6cd7d2069e780cfc4ae13e98be1d0c802a89b9d Mon Sep 17 00:00:00 2001 From: Alasdair Date: Fri, 14 Dec 2018 02:26:33 +0000 Subject: A few additional tests --- src/c_backend.ml | 2 ++ src/type_check.ml | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/c_backend.ml b/src/c_backend.ml index 43fa3719..65702764 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -139,6 +139,8 @@ let rec ctyp_of_typ ctx typ = | Typ_id id when string_of_id id = "string" -> CT_string | Typ_id id when string_of_id id = "real" -> CT_real + | Typ_app (id, _) when string_of_id id = "atom_bool" -> CT_bool + | Typ_app (id, _) when string_of_id id = "range" || string_of_id id = "atom" -> begin match destruct_range Env.empty typ with | None -> assert false (* Checked if range type in guard *) diff --git a/src/type_check.ml b/src/type_check.ml index 3cfa4bb6..df074567 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -264,7 +264,6 @@ let destruct_exist typ = | Some (kids, nc, nexp) -> Some (List.map (mk_kopt K_int) kids, nc, atom_typ nexp) | None -> destruct_exist' typ - let adding = Util.("Adding " |> darkgray |> clear) (**************************************************************************) @@ -1327,6 +1326,7 @@ and typ_arg_frees ?exs:(exs=KidSet.empty) (A_aux (typ_arg_aux, l)) = | A_nexp n -> nexp_frees ~exs:exs n | A_typ typ -> typ_frees ~exs:exs typ | A_order ord -> order_frees ord + | A_bool nc -> tyvars_of_constraint nc let rec nexp_identical (Nexp_aux (nexp1, _)) (Nexp_aux (nexp2, _)) = match nexp1, nexp2 with -- cgit v1.2.3 From 24f4067eeb9dbfe6c30137591394a8ea0413a21e Mon Sep 17 00:00:00 2001 From: Alasdair Date: Fri, 14 Dec 2018 02:41:34 +0000 Subject: Get real number tests working in OCaml/Interpreter --- src/sail_lib.ml | 4 +--- src/value.ml | 6 +++--- 2 files changed, 4 insertions(+), 6 deletions(-) (limited to 'src') diff --git a/src/sail_lib.ml b/src/sail_lib.ml index 7bb176c5..026172ec 100644 --- a/src/sail_lib.ml +++ b/src/sail_lib.ml @@ -599,7 +599,7 @@ let sub_real (x, y) = Rational.sub x y let abs_real x = Rational.abs x -let sqrt x = +let sqrt_real x = let precision = 30 in let s = Big_int.sqrt (Rational.num x) in if Big_int.equal (Rational.den x) (Big_int.of_int 1) && Big_int.equal (Big_int.mul s s) (Rational.num x) then @@ -649,8 +649,6 @@ let real_of_string str = | [whole] -> Rational.of_int (int_of_string str) | _ -> failwith "invalid real literal" -let sqrt_real x = failwith "sqrt_real" - let print str = Pervasives.print_string str let prerr str = Pervasives.prerr_string str diff --git a/src/value.ml b/src/value.ml index a4ce225e..729b3974 100644 --- a/src/value.ml +++ b/src/value.ml @@ -502,7 +502,7 @@ let value_random_real = function | _ -> failwith "value random_real" let value_sqrt_real = function - | [v] -> V_real (Sail_lib.sqrt (coerce_real v)) + | [v] -> V_real (Sail_lib.sqrt_real (coerce_real v)) | _ -> failwith "value sqrt_real" let value_quotient_real = function @@ -645,8 +645,8 @@ let primops = ("eq_real", value_eq_real); ("lt_real", value_lt_real); ("gt_real", value_gt_real); - ("lteq_real", value_lt_real); - ("gteq_real", value_gt_real); + ("lteq_real", value_lteq_real); + ("gteq_real", value_gteq_real); ("add_real", value_add_real); ("sub_real", value_sub_real); ("mult_real", value_mult_real); -- cgit v1.2.3 From 6f8d5bdacd5accbd4aa689071304d3255792030b Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Fri, 14 Dec 2018 11:06:31 +0000 Subject: Add truncateLSB builtin useful for implementing Cheri Concentrate. Also add bool_of_bit and bit_of_bool in sail_lib --- src/sail_lib.ml | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/sail_lib.ml b/src/sail_lib.ml index 026172ec..c0bf80fa 100644 --- a/src/sail_lib.ml +++ b/src/sail_lib.ml @@ -160,6 +160,8 @@ let update_subrange (xs, n, m, ys) = let vector_truncate (xs, n) = List.rev (take (Big_int.to_int n) (List.rev xs)) +let vector_truncateLSB (xs, n) = take (Big_int.to_int n) xs + let length xs = Big_int.of_int (List.length xs) let big_int_of_bit = function @@ -359,6 +361,14 @@ let int_of_bit = function | B0 -> 0 | B1 -> 1 +let bool_of_bit = function + | B0 -> false + | B1 -> true + +let bit_of_bool = function + | false -> B0 + | true -> B1 + let bigint_of_bit b = Big_int.of_int (int_of_bit b) let string_of_hex = function @@ -1138,7 +1148,7 @@ let rand_zvector (g : 'generators) (size : int) (order : bool) (elem_gen : 'gene Util.list_init size (fun _ -> elem_gen g) let rand_zbit (g : 'generators) : bit = - if Random.bool() then B0 else B1 + bit_of_bool (Random.bool()) let rand_zbool (g : 'generators) : bool = Random.bool() -- cgit v1.2.3 From 2dfcbdeedb0ac40d4865aaf5c2202dfba95f4a38 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Fri, 14 Dec 2018 15:17:42 +0000 Subject: Add a few more tests for Jenkins Some of the output from the tests scripts is odd on Jenkins, try to fix this by flushing stdout more regularly in the test scripts --- src/ocaml_backend.ml | 2 +- src/parser.mly | 6 ------ 2 files changed, 1 insertion(+), 7 deletions(-) (limited to 'src') diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index cfd79290..d075e693 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -978,7 +978,7 @@ let ocaml_compile spec defs generator_types = let tags_file = if !opt_ocaml_coverage then "_tags_coverage" else "_tags" in let _ = Unix.system ("cp -r " ^ sail_dir ^ "/lib/" ^ tags_file ^ " _tags") in let out_chan = open_out (spec ^ ".ml") in - if !opt_ocaml_coverage then + if !opt_ocaml_coverage then ignore(Unix.system ("cp -r " ^ sail_dir ^ "/lib/myocamlbuild_coverage.ml myocamlbuild.ml")); ocaml_pp_defs out_chan defs generator_types; close_out out_chan; diff --git a/src/parser.mly b/src/parser.mly index 6344db97..66902953 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -319,12 +319,6 @@ kid: | TyVar { mk_kid $1 $startpos $endpos } -kid_list: - | kid - { [$1] } - | kid kid_list - { $1 :: $2 } - num_list: | Num { [$1] } -- cgit v1.2.3 From c37666f691078e39102d125298cd70b210f83f63 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Fri, 14 Dec 2018 17:58:30 +0000 Subject: Add some experimental support for non-lexical flow-typing rules Add a file nl_flow.ml which can analyse a block of Sail expressions and insert constraints for flow-typing rules which do not follow the lexical structure of the code (and therefore the syntax-directed typing rules can't do any flow-typing for). A common case found in ASL translated Sail would be something like function decode(Rt: bits(4)) = { if Rt == 0xF then { throw(Error_see("instruction")); }; let t = unsigned(Rt); execute(t) } which would currently fail is execute has a 0 <= t <= 14 constraint for a register it writes to. However if we spot this pattern and add an assertion automatically: let t = unsigned(Rt); assert(t != 15); execute(t) Then everything works, because the assertion is in the correct place for regular flow typing. Currently it only works for this specific use-case, and is turned on using the -non_lexical_flow flag --- src/nl_flow.ml | 118 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/nl_flow.mli | 60 +++++++++++++++++++++++++++ src/sail.ml | 3 ++ src/type_check.ml | 2 +- 4 files changed, 182 insertions(+), 1 deletion(-) create mode 100644 src/nl_flow.ml create mode 100644 src/nl_flow.mli (limited to 'src') diff --git a/src/nl_flow.ml b/src/nl_flow.ml new file mode 100644 index 00000000..e38e5fa5 --- /dev/null +++ b/src/nl_flow.ml @@ -0,0 +1,118 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Ast_util + +let opt_nl_flow = ref false + +let rec escapes (E_aux (aux, _)) = + match aux with + | E_throw _ -> true + | E_block [] -> false + | E_block exps -> escapes (List.hd (List.rev exps)) + | _ -> false + +let is_bitvector_literal (L_aux (aux, _)) = + match aux with + | L_bin _ | L_hex _ -> true + | _ -> false + +let bitvector_unsigned (L_aux (aux, _)) = + let open Sail_lib in + match aux with + | L_bin str -> uint (List.map bin_char (Util.string_to_list str)) + | L_hex str -> uint (bits_of_string str) + | _ -> assert false + +let rec pat_id (P_aux (aux, _)) = + match aux with + | P_id id -> Some id + | P_as (_, id) -> Some id + | P_var (pat, _) -> pat_id pat + | _ -> None + +let add_assert cond (E_aux (aux, (l, ())) as exp) = + let msg = mk_lit_exp (L_string "") in + let assertion = locate (fun _ -> gen_loc l) (mk_exp (E_assert (cond, msg))) in + match aux with + | E_block exps -> E_aux (E_block (assertion :: exps), (l, ())) + | _ -> E_aux (E_block (assertion :: [exp]), (l, ())) + +(* If we know that x != bitv, then after any let y = unsigned(x) we + will also know that y != unsigned(bitv) *) +let modify_unsigned id value (E_aux (aux, annot) as exp) = + match aux with + | E_let (LB_aux (LB_val (pat, E_aux (E_app (f, [E_aux (E_id id', _)]), _)), _) as lb, exp') + when string_of_id f = "unsigned" && Id.compare id id' = 0 -> + begin match pat_id pat with + | None -> exp + | Some uid -> + E_aux (E_let (lb, + add_assert (mk_exp (E_app_infix (mk_exp (E_id uid), mk_id "!=", mk_lit_exp (L_num value)))) exp'), + annot) + end + | _ -> exp + +let analyze' exps = + match exps with + | E_aux (E_if (cond, then_exp, _), _) :: rest when escapes then_exp -> + begin match cond with + | E_aux (E_app_infix (E_aux (E_id id, _), op, E_aux (E_lit lit, _)), _) + | E_aux (E_app_infix (E_aux (E_lit lit, _), op, E_aux (E_id id, _)), _) + when string_of_id op = "==" && is_bitvector_literal lit -> + let value = bitvector_unsigned lit in + List.map (modify_unsigned id value) exps + | _ -> exps + end + | _ -> exps + +let analyze exps = + if !opt_nl_flow then analyze' exps else exps diff --git a/src/nl_flow.mli b/src/nl_flow.mli new file mode 100644 index 00000000..f2bf0035 --- /dev/null +++ b/src/nl_flow.mli @@ -0,0 +1,60 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast + +(** [opt_nl_flow] must be true for [analyze] to do anything. *) +val opt_nl_flow : bool ref + +(** Analyze a basic block for flow typing properties that do not + follow the lexical structure of the code (and therefore the + syntax-directed typing rules), and insert assertions for discovered + constraints *) +val analyze : unit exp list -> unit exp list diff --git a/src/sail.ml b/src/sail.ml index 0d26df9c..59190d15 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -194,6 +194,9 @@ let options = Arg.align ([ ( "-enum_casts", Arg.Set Initial_check.opt_enum_casts, " allow enumerations to be automatically casted to numeric range types"); + ( "-non_lexical_flow", + Arg.Set Nl_flow.opt_nl_flow, + " allow non-lexical flow typing"); ( "-no_lexp_bounds_check", Arg.Set Type_check.opt_no_lexp_bounds_check, " turn off bounds checking for vector assignments in l-expressions"); diff --git a/src/type_check.ml b/src/type_check.ml index df074567..8b6a9c45 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -2156,7 +2156,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ let rec check_block l env exps typ = let annot_exp_effect exp typ eff exp_typ = E_aux (exp, (l, Some ((env, typ, eff), exp_typ))) in let annot_exp exp typ exp_typ = annot_exp_effect exp typ no_effect exp_typ in - match exps with + match Nl_flow.analyze exps with | [] -> typ_equality l env typ unit_typ; [] | [exp] -> [crule check_exp env exp typ] | (E_aux (E_assign (lexp, bind), _) :: exps) -> -- cgit v1.2.3 From e5d108332cf700f73ea7b7527d0ae6006b0944c5 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Mon, 17 Dec 2018 12:23:30 +0000 Subject: Adapt Coq and termination measure support to typechecker changes Also output termination measures in Sail printer --- src/pretty_print_coq.ml | 20 ++++++++++---------- src/pretty_print_sail.ml | 9 ++++++++- src/type_check.ml | 12 ++++++------ src/type_check.mli | 4 +++- 4 files changed, 27 insertions(+), 18 deletions(-) (limited to 'src') diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 053020db..18e288dd 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -692,7 +692,7 @@ let is_ctor env id = match Env.lookup_id id env with let is_auto_decomposed_exist env typ = let typ = expand_range_type typ in - match destruct_exist (Env.expand_synonyms env typ) with + match destruct_exist_plain (Env.expand_synonyms env typ) with | Some (_, _, typ') -> Some typ' | _ -> None @@ -935,7 +935,7 @@ let doc_exp, doc_let = debug ctxt (lazy (" at type " ^ string_of_typ typ)) in let typ = expand_range_type typ in - match destruct_exist typ with + match destruct_exist_plain typ with | None -> epp | Some _ -> let epp = string "build_ex" ^/^ epp in @@ -951,12 +951,12 @@ let doc_exp, doc_let = | _ -> let typ' = expand_range_type (Env.expand_synonyms (env_of exp) typ) in let build_ex, out_typ = - match destruct_exist typ' with + match destruct_exist_plain typ' with | Some (_,_,t) -> true, t | None -> false, typ' in let in_typ = expand_range_type (Env.expand_synonyms (env_of exp) (typ_of exp)) in - let in_typ = match destruct_exist in_typ with Some (_,_,t) -> t | None -> in_typ in + let in_typ = match destruct_exist_plain in_typ with Some (_,_,t) -> t | None -> in_typ in let autocast = (* Avoid using helper functions which simplify the nexps *) is_bitvector_typ in_typ && is_bitvector_typ out_typ && @@ -1569,7 +1569,7 @@ let doc_exp, doc_let = | P_aux (P_var (P_aux (P_typ (typ, P_aux (P_id id,_)),_),_),_) when not (is_enum (env_of e1) id) -> let full_typ = (expand_range_type typ) in - let binder = match destruct_exist (Env.expand_synonyms (env_of e1) full_typ) with + let binder = match destruct_exist_plain (Env.expand_synonyms (env_of e1) full_typ) with | Some _ -> squote ^^ parens (separate space [string "existT"; underscore; doc_id id; underscore; colon; doc_typ ctxt typ]) | _ -> @@ -2039,7 +2039,7 @@ let doc_funcl rec_opt (FCL_aux(FCL_Funcl(id, pexp), annot)) = | _ -> failwith ("Function " ^ string_of_id id ^ " does not have function type") in let build_ex, ret_typ = replace_atom_return_type ret_typ in - let build_ex = match destruct_exist (Env.expand_synonyms env (expand_range_type ret_typ)) with + let build_ex = match destruct_exist_plain (Env.expand_synonyms env (expand_range_type ret_typ)) with | Some _ -> true | _ -> build_ex in @@ -2097,7 +2097,7 @@ let doc_funcl rec_opt (FCL_aux(FCL_Funcl(id, pexp), annot)) = parens (separate space [doc_id id; colon; doc_typ ctxt typ]) else begin let full_typ = (expand_range_type exp_typ) in - match destruct_exist (Env.expand_synonyms env full_typ) with + match destruct_exist_plain (Env.expand_synonyms env full_typ) with | Some ([kopt], NC_aux (NC_true,_), Typ_aux (Typ_app (Id_aux (Id "atom",_), [A_aux (A_nexp (Nexp_aux (Nexp_var kid,_)),_)]),_)) @@ -2131,7 +2131,7 @@ let doc_funcl rec_opt (FCL_aux(FCL_Funcl(id, pexp), annot)) = Util.map_filter (fun (pat,typ) -> match pat_is_plain_binder env pat with | Some id -> begin - match destruct_exist (Env.expand_synonyms env (expand_range_type typ)) with + match destruct_exist_plain (Env.expand_synonyms env (expand_range_type typ)) with | Some (_, NC_aux (NC_true,_), _) -> None | Some ([KOpt_aux (KOpt_kind (_, kid), _)], nc, Typ_aux (Typ_app (Id_aux (Id "atom",_), @@ -2143,7 +2143,7 @@ let doc_funcl rec_opt (FCL_aux(FCL_Funcl(id, pexp), annot)) = | None -> None) pats in string "Fixpoint", - [parens (string "_acc : Acc (Zwf 0) _rec_limit")], + [parens (string "_acc : Acc (Zwf 0) _reclimit")], [string "{struct _acc}"], fixupspp | Rec_aux (r,_) -> @@ -2343,7 +2343,7 @@ let doc_val pat exp = | None -> typpp, exp | Some typ -> let typ = expand_range_type (Env.expand_synonyms env typ) in - match destruct_exist typ with + match destruct_exist_plain typ with | None -> typpp, exp | Some _ -> empty, match exp with diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index c4b9bdd3..345312f7 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -509,14 +509,21 @@ let doc_funcl (FCL_aux (FCL_Funcl (id, Pat_aux (pexp,_)), _)) = let doc_default (DT_aux (DT_order ord, _)) = separate space [string "default"; string "Order"; doc_ord ord] +let doc_rec (Rec_aux (r,_)) = + match r with + | Rec_nonrec + | Rec_rec -> empty + | Rec_measure (pat,exp) -> braces (doc_pat pat ^^ string " => " ^^ doc_exp exp) ^^ space + let doc_fundef (FD_aux (FD_function (r, typa, efa, funcls), annot)) = docstring annot ^^ match funcls with | [] -> failwith "Empty function list" | _ -> + let rec_pp = doc_rec r in let sep = hardline ^^ string "and" ^^ space in let clauses = separate_map sep doc_funcl funcls in - string "function" ^^ space ^^ clauses + string "function" ^^ space ^^ rec_pp ^^ clauses let rec doc_mpat (MP_aux (mp_aux, _) as mpat) = match mp_aux with diff --git a/src/type_check.ml b/src/type_check.ml index 8b6a9c45..53d87a05 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -221,7 +221,7 @@ let fresh_existential ?name:(n="") k = let fresh = Kid_aux (Var ("'ex" ^ string_of_int !ex_counter ^ "#" ^ n), Parse_ast.Unknown) in incr ex_counter; mk_kopt k fresh -let destruct_exist' typ = +let destruct_exist_plain typ = match typ with | Typ_aux (Typ_exist (kopts, nc, typ), _) -> let fresh_kopts = @@ -243,7 +243,7 @@ let destruct_exist' typ = - atom('n) => [], true, 'n **) let destruct_numeric typ = - match destruct_exist' typ, typ with + match destruct_exist_plain typ, typ with | Some (kids, nc, Typ_aux (Typ_app (id, [A_aux (A_nexp nexp, _)]), _)), _ when string_of_id id = "atom" -> Some (List.map kopt_kid kids, nc, nexp) | None, Typ_aux (Typ_app (id, [A_aux (A_nexp nexp, _)]), _) when string_of_id id = "atom" -> @@ -262,7 +262,7 @@ let destruct_numeric typ = let destruct_exist typ = match destruct_numeric typ with | Some (kids, nc, nexp) -> Some (List.map (mk_kopt K_int) kids, nc, atom_typ nexp) - | None -> destruct_exist' typ + | None -> destruct_exist_plain typ let adding = Util.("Adding " |> darkgray |> clear) @@ -1736,7 +1736,7 @@ let rec subtyp l env typ1 typ2 = if prove env nc2 then () else typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env)) | _, _ -> - match destruct_exist' typ1, destruct_exist (canonicalize env typ2) with + match destruct_exist_plain typ1, destruct_exist (canonicalize env typ2) with | Some (kopts, nc, typ1), _ -> let env = add_existential l kopts nc env in subtyp l env typ1 typ2 | None, Some (kopts, nc, typ2) -> @@ -4184,17 +4184,17 @@ let check_fundef env (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls) in check_tannotopt env quant vtyp_ret tannotopt; typ_debug (lazy ("Checking fundef " ^ string_of_id id ^ " has type " ^ string_of_bind (quant, typ))); + let funcl_env = add_typquant l quant env in let recopt = match recopt with | Rec_aux (Rec_nonrec, l) -> Rec_aux (Rec_nonrec, l) | Rec_aux (Rec_rec, l) -> Rec_aux (Rec_rec, l) | Rec_aux (Rec_measure (measure_p, measure_e), l) -> let typ = match vtyp_args with [x] -> x | _ -> Typ_aux (Typ_tup vtyp_args,Unknown) in - let tpat, env = bind_pat_no_guard env (strip_pat measure_p) typ in + let tpat, env = bind_pat_no_guard funcl_env (strip_pat measure_p) typ in let texp = check_exp env (strip_exp measure_e) int_typ in Rec_aux (Rec_measure (tpat, texp), l) in - let funcl_env = add_typquant l quant env in let funcls = List.map (fun funcl -> check_funcl funcl_env funcl typ) funcls in let eff = List.fold_left union_effects no_effect (List.map funcl_effect funcls) in let vs_def, env, declared_eff = diff --git a/src/type_check.mli b/src/type_check.mli index 04ff48f7..81682606 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -210,7 +210,9 @@ val add_typquant : Ast.l -> typquant -> Env.t -> Env.t (** Safely destructure an existential type. Returns None if the type is not existential. This function will pick a fresh name for the - existential to ensure that no name-clashes occur. *) + existential to ensure that no name-clashes occur. The "plain" + version does not treat numeric types as existentials. *) +val destruct_exist_plain : typ -> (kinded_id list * n_constraint * typ) option val destruct_exist : typ -> (kinded_id list * n_constraint * typ) option val add_existential : Ast.l -> kinded_id list -> n_constraint -> Env.t -> Env.t -- cgit v1.2.3 From 07a332c856b3ee9fe26a9cd47ea6005f9d579810 Mon Sep 17 00:00:00 2001 From: Thomas Bauereiss Date: Tue, 18 Dec 2018 14:59:59 +0000 Subject: Check more carefully for recursive functions when generating Lem Annotating non-recursive functions as recursive in Lem output is allowed, but will make Lem use "fun"/"function" commands when generating Isabelle output, which is much slower to process than "definiton". --- src/pretty_print_lem.ml | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) (limited to 'src') diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index 9d169108..5c67f93a 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -1267,10 +1267,6 @@ let rec untuple_args_pat (P_aux (paux, ((l, _) as annot)) as pat) arg_typs = | _, _ -> [pat], identity -let doc_rec_lem force_rec (Rec_aux(r,_)) = match r with - | Rec_nonrec when not force_rec -> space - | _ -> space ^^ string "rec" ^^ space - let doc_tannot_opt_lem (Typ_annot_opt_aux(t,_)) = match t with | Typ_annot_opt_some(tq,typ) -> (*doc_typquant_lem tq*) (doc_typ_lem typ) | Typ_annot_opt_none -> empty @@ -1324,9 +1320,19 @@ let doc_mutrec_lem = function let rec doc_fundef_lem (FD_aux(FD_function(r, typa, efa, fcls),fannot) as fd) = match fcls with | [] -> failwith "FD_function with empty function list" - | FCL_aux (FCL_Funcl(id,_),annot) :: _ - when not (Env.is_extern id (env_of_annot annot) "lem") -> - string "let" ^^ (doc_rec_lem (List.length fcls > 1) r) ^^ (doc_fundef_rhs_lem fd) + | FCL_aux (FCL_Funcl(id, pexp),annot) :: _ + when not (Env.is_extern id (env_of_annot annot) "lem") -> + (* Output "rec" modifier if function calls itself. Mutually recursive + functions are handled separately by doc_mutrec_lem. *) + let is_funcl_rec = + fold_pexp + { (pure_exp_alg false (||)) with + e_app = (fun (id', args) -> List.fold_left (||) (Id.compare id id' = 0) args); + e_app_infix = (fun (l, id', r) -> l || (Id.compare id id' = 0) || r) } + pexp + in + let doc_rec = if is_funcl_rec then [string "rec"] else [] in + separate space ([string "let"] @ doc_rec @ [doc_fundef_rhs_lem fd]) | _ -> empty -- cgit v1.2.3 From 66b55de7e24ab546aff3eba17d21b86d47306a6d Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Tue, 18 Dec 2018 10:30:27 +0000 Subject: Coq: handle existentials in hypotheses during solving, add max_nat, better casts --- src/pretty_print_coq.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 18e288dd..4f6a0dfc 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -1383,7 +1383,11 @@ let doc_exp, doc_let = if effects then if inner_ex then if cast_ex - then string "derive_m" ^^ space ^^ epp + (* If the types are the same use the cast as a hint to Coq, + otherwise derive the new type from the old one. *) + then if alpha_equivalent env inner_typ cast_typ + then epp + else string "derive_m" ^^ space ^^ epp else string "projT1_m" ^^ space ^^ epp else if cast_ex then string "build_ex_m" ^^ space ^^ epp -- cgit v1.2.3 From 7524c25b16a4e393a17acde8b20f6a42d30d0f94 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Wed, 19 Dec 2018 17:54:23 +0000 Subject: Coq: handle pairs of ranges (and other existential types) properly (Needed for current CHERI.) --- src/pretty_print_coq.ml | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 4f6a0dfc..9bbe056b 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -65,6 +65,20 @@ let opt_debug_on : string list ref = ref [] * PPrint-based sail-to-coq pprinter ****************************************************************************) +(* Data representation: + * + * In pure computations we keep values with top level existential types + * (including ranges and nats) separate from the proofs of the accompanying + * constraints, which keeps the terms shorter and more manageable. + * Existentials embedded in types (e.g., in tuples or datatypes) are dependent + * pairs. + * + * Monadic values always includes the proof in a dependent pair because the + * constraint solving tactic won't see the term that defined the value, and + * must rely entirely on the type (like the Sail type checker). + *) + + type context = { early_ret : bool; kid_renames : kid KBindings.t; (* Plain tyvar -> tyvar renames *) @@ -761,9 +775,9 @@ let rec doc_pat ctxt apat_needed exists_as_pairs (P_aux (p,(l,annot)) as pat, ty | _ -> raise (Reporting.err_unreachable l __POS__ "tuple pattern doesn't have tuple type") in (match pats, typs with - | [p], [typ'] -> doc_pat ctxt apat_needed exists_as_pairs (p, typ') + | [p], [typ'] -> doc_pat ctxt apat_needed true (p, typ') | [_], _ -> raise (Reporting.err_unreachable l __POS__ "tuple pattern length does not match tuple type length") - | _ -> parens (separate_map comma_sp (doc_pat ctxt false exists_as_pairs) (List.combine pats typs))) + | _ -> parens (separate_map comma_sp (doc_pat ctxt false true) (List.combine pats typs))) | P_list pats -> let el_typ = match typ with | Typ_aux (Typ_app (f, [A_aux (A_typ el_typ,_)]),_) @@ -1413,7 +1427,7 @@ let doc_exp, doc_let = in if aexp_needed then parens epp else epp | E_tuple exps -> - parens (align (group (separate_map (comma ^^ break 1) expN exps))) + construct_dep_pairs (env_of_annot (l,annot)) true full_exp (general_typ_of full_exp) | E_record fexps -> let recordtyp = match destruct_tannot annot with | Some (env, Typ_aux (Typ_id tid,_), _) -- cgit v1.2.3 From 8dbe18b8976e30fa88814542ea913ddc4193cd8b Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Sat, 22 Dec 2018 15:40:32 +0000 Subject: Added RISC-V fence.tso --- src/lem_interp/sail2_instr_kinds.lem | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/lem_interp/sail2_instr_kinds.lem b/src/lem_interp/sail2_instr_kinds.lem index 3d238676..eadc85bf 100644 --- a/src/lem_interp/sail2_instr_kinds.lem +++ b/src/lem_interp/sail2_instr_kinds.lem @@ -155,6 +155,7 @@ type barrier_kind = | Barrier_RISCV_rw_r | Barrier_RISCV_r_w | Barrier_RISCV_w_r + | Barrier_RISCV_tso | Barrier_RISCV_i (* X86 *) | Barrier_x86_MFENCE @@ -184,6 +185,7 @@ instance (Show barrier_kind) | Barrier_RISCV_rw_r -> "Barrier_RISCV_rw_r" | Barrier_RISCV_r_w -> "Barrier_RISCV_r_w" | Barrier_RISCV_w_r -> "Barrier_RISCV_w_r" + | Barrier_RISCV_tso -> "Barrier_RISCV_tso" | Barrier_RISCV_i -> "Barrier_RISCV_i" | Barrier_x86_MFENCE -> "Barrier_x86_MFENCE" end @@ -300,7 +302,8 @@ instance (EnumerationType barrier_kind) | Barrier_RISCV_rw_r -> 19 | Barrier_RISCV_r_w -> 20 | Barrier_RISCV_w_r -> 21 - | Barrier_RISCV_i -> 22 - | Barrier_x86_MFENCE -> 23 + | Barrier_RISCV_tso -> 22 + | Barrier_RISCV_i -> 23 + | Barrier_x86_MFENCE -> 24 end end -- cgit v1.2.3 From f70f187dbf667df5e8610978e928d9ba76af8e0e Mon Sep 17 00:00:00 2001 From: Thomas Bauereiss Date: Sun, 23 Dec 2018 13:55:46 +0100 Subject: Remove a comment that breaks Isabelle build With the new comment syntax, Isabelle seems to barf on that comment, apparently due to the backslashes. --- src/gen_lib/sail2_string.lem | 4 ---- 1 file changed, 4 deletions(-) (limited to 'src') diff --git a/src/gen_lib/sail2_string.lem b/src/gen_lib/sail2_string.lem index de7588dc..33a665a0 100644 --- a/src/gen_lib/sail2_string.lem +++ b/src/gen_lib/sail2_string.lem @@ -64,10 +64,6 @@ let rec n_leading_spaces s = | _ -> 0 end else - (* match len with - * (\* | 0 -> 0 *\) - * (\* | 1 -> *\) - * | len -> *) (* Isabelle generation for pattern matching on characters is currently broken, so use an if-expression *) if nth s 0 = #' ' -- cgit v1.2.3 From 1940388163a9379cd6c157f3636439a93c5d4b67 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Thu, 27 Dec 2018 15:17:41 +0000 Subject: Coq: fix name clashes and instantiation calculation --- src/pretty_print_coq.ml | 33 ++++++++++++++++++++++++++++++--- 1 file changed, 30 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 9bbe056b..2f63327d 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -1196,13 +1196,39 @@ let doc_exp, doc_let = else if IdSet.mem f ctxt.recursive_ids then doc_id f, false, false, true else doc_id f, false, false, false in - let (tqs,fn_ty) = Env.get_val_spec_orig f env in + let (tqs,fn_ty) = Env.get_val_spec f env in + (* Calculate the renaming *) + let tqs_map = List.fold_left + (fun m k -> + let kid = kopt_kid k in + KBindings.add (orig_kid kid) kid m) + KBindings.empty (quant_kopts tqs) in let arg_typs, ret_typ, eff = match fn_ty with | Typ_aux (Typ_fn (arg_typs,ret_typ,eff),_) -> arg_typs, ret_typ, eff | _ -> raise (Reporting.err_unreachable l __POS__ "Function not a function type") in let inst = - match instantiation_of_without_type full_exp with + (* We attempt to get an instantiation of the function signature's + type variables which agrees with Coq by + 1. using dummy variables with the expected type of each argument + (avoiding the inferred type, which might have (e.g.) stripped + out an existential quantifier) + 2. calculating the instantiation without using the expected + return type, so that we can work out if we need a cast around + the function call. *) + let dummy_args = + Util.list_mapi (fun i exp -> mk_id ("#coq#arg" ^ string_of_int i), + general_typ_of exp) args + in + let dummy_exp = mk_exp (E_app (f, List.map (fun (id,_) -> mk_exp (E_id id)) dummy_args)) in + let dummy_env = List.fold_left (fun env (id,typ) -> Env.add_local id (Immutable,typ) env) env dummy_args in + let inst_exp = + try infer_exp dummy_env dummy_exp + with ex -> + debug ctxt (lazy (" cannot infer dummy application " ^ Printexc.to_string ex)); + full_exp + in + match instantiation_of_without_type inst_exp with | x -> x (* Not all function applications can be inferred, so try falling back to the type inferred when we know the target type. @@ -1210,7 +1236,8 @@ let doc_exp, doc_let = to cast. *) | exception _ -> instantiation_of full_exp in - let inst = KBindings.fold (fun k u m -> KBindings.add (orig_kid k) u m) inst KBindings.empty in + let inst = KBindings.fold (fun k u m -> KBindings.add (KBindings.find (orig_kid k) tqs_map) u m) inst KBindings.empty in + let () = debug ctxt (lazy (" instantiations: " ^ String.concat ", " (List.map (fun (kid,tyarg) -> string_of_kid kid ^ " => " ^ string_of_typ_arg tyarg) (KBindings.bindings inst)))) in (* Insert existential packing of arguments where necessary *) let doc_arg want_parens arg typ_from_fn = -- cgit v1.2.3 From 2c887e7d01331d3165120695594eac7a2650ec03 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Thu, 27 Dec 2018 20:00:56 +0000 Subject: Coq: avoid putting ambiguous numeric literals in Coq output There are situations when we really want a more refined expression, such as 8 * n instead of 64 (when we know n = 8 from a case split), but we might not be able to generate it. For now we generate an underscore and let Coq figure it out from the context. --- src/pretty_print_coq.ml | 29 ++++++++++++++++++++++------- 1 file changed, 22 insertions(+), 7 deletions(-) (limited to 'src') diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 2f63327d..09c6cafc 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -1262,14 +1262,29 @@ let doc_exp, doc_let = not (similar_nexps ctxt env n1 n2) | _ -> false in - let want_parens1 = want_parens || autocast in - let arg_pp = - construct_dep_pairs env want_parens1 arg typ_from_fn + (* If the argument is an integer that can be inferred from the + context in a different form, let Coq fill it in. E.g., + when "64" is really "8 * width". Avoid cases where the + type checker has introduced a phantom type variable while + calculating the instantiations. *) + let vars_in_env n = + let ekids = Env.get_typ_vars env in + KidSet.for_all (fun kid -> KBindings.mem kid ekids) (nexp_frees n) in - if autocast && false - then let arg_pp = string "autocast" ^^ space ^^ arg_pp in - if want_parens then parens arg_pp else arg_pp - else arg_pp + match typ_of_arg, typ_from_fn with + | Typ_aux (Typ_app (Id_aux (Id "atom",_),[A_aux (A_nexp n1,_)]),_), + Typ_aux (Typ_app (Id_aux (Id "atom",_),[A_aux (A_nexp n2,_)]),_) + when vars_in_env n2 && not (similar_nexps ctxt env n1 n2) -> + underscore + | _ -> + let want_parens1 = want_parens || autocast in + let arg_pp = + construct_dep_pairs env want_parens1 arg typ_from_fn + in + if autocast && false + then let arg_pp = string "autocast" ^^ space ^^ arg_pp in + if want_parens then parens arg_pp else arg_pp + else arg_pp in let epp = if is_ctor -- cgit v1.2.3