diff options
Diffstat (limited to 'src')
46 files changed, 1498 insertions, 1591 deletions
diff --git a/src/Makefile b/src/Makefile index 3e9d6f63..aeb23b9e 100644 --- a/src/Makefile +++ b/src/Makefile @@ -62,7 +62,7 @@ endif endif -.PHONY: all sail sail.native sail.byte test clean doc lib power test_power test_idempotence +.PHONY: all sail coverage sail.native sail.byte manifest.ml test clean doc lib power test_power test_idempotence # set to -p on command line to enable gprof profiling OCAML_OPTS?= @@ -90,19 +90,25 @@ bytecode.ml: bytecode.lem lem_interp/interp_ast.lem: ../language/l2.ott ott -sort false -generate_aux_rules true -o lem_interp/interp_ast.lem -picky_multiple_parses true ../language/l2.ott -share_directory.ml: - echo "(* Generated file -- do not edit. *)" > share_directory.ml - echo let d=\"$(SHARE_DIR)\" >> share_directory.ml +manifest.ml: + echo "(* Generated file -- do not edit. *)" > manifest.ml + echo let dir=\"$(SHARE_DIR)\" >> manifest.ml + echo let commit=\"$(shell git rev-parse HEAD)\" >> manifest.ml + echo let branch=\"$(shell git rev-parse --abbrev-ref HEAD)\" >> manifest.ml + echo let version=\"$(shell git describe)\" >> manifest.ml -sail: ast.ml bytecode.ml share_directory.ml +sail: ast.ml bytecode.ml manifest.ml ocamlbuild -use-ocamlfind sail.native sail_lib.cma sail_lib.cmxa -isail: ast.ml bytecode.ml share_directory.ml +isail: ast.ml bytecode.ml manifest.ml ocamlbuild -use-ocamlfind isail.native +coverage: ast.ml bytecode.ml manifest.ml + BISECT_COVERAGE=YES ocamlbuild -use-ocamlfind -plugin-tag 'package(bisect_ppx-ocamlbuild)' isail.native + sail.native: sail -sail.byte: ast.ml bytecode.ml share_directory.ml +sail.byte: ast.ml bytecode.ml manifest.ml ocamlbuild -use-ocamlfind -cflag -g sail.byte interpreter: lem_interp/interp_ast.lem @@ -148,7 +154,7 @@ clean: -rm -f bytecode.ml -rm -f bytecode.lem -rm -f bytecode.ml.bak - -rm -f share_directory.ml + -rm -f manifest.ml doc: ocamlbuild -use-ocamlfind sail.docdir/index.html @@ -1,5 +1,6 @@ true: -traverse, debug, use_menhir -<**/*.ml>: bin_annot, annot +<**/parser.ml>: bin_annot, annot +<**/*.ml> and not <**/parser.ml>: bin_annot, annot <sail.{byte,native}>: package(zarith), package(linksem), package(lem), package(omd), use_pprint <isail.{byte,native}>: package(zarith), package(linenoise), package(linksem), package(lem), package(omd), use_pprint @@ -699,9 +699,13 @@ let rec anf (E_aux (e_aux, ((l, _) as exp_annot)) as exp) = (* Interpreter specific *) raise (Reporting.err_unreachable l __POS__ "encountered E_internal_value when converting to ANF") - | E_sizeof _ | E_constraint _ -> + | E_sizeof nexp -> (* Sizeof nodes removed by sizeof rewriting pass *) - raise (Reporting.err_unreachable l __POS__ "encountered E_sizeof or E_constraint node when converting to ANF") + raise (Reporting.err_unreachable l __POS__ ("encountered E_sizeof node " ^ string_of_nexp nexp ^ " when converting to ANF")) + + | E_constraint _ -> + (* Sizeof nodes removed by sizeof rewriting pass *) + raise (Reporting.err_unreachable l __POS__ "encountered E_constraint node when converting to ANF") | E_nondet _ -> (* We don't compile E_nondet nodes *) diff --git a/src/ast_util.ml b/src/ast_util.ml index a771291e..c0e9fe02 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 @@ -321,10 +321,23 @@ 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) + let nexp1, nexp2 = nexp_simp nexp1, nexp_simp nexp2 in + begin match nexp1, nexp2 with + | Nexp_aux (Nexp_constant c1, _), Nexp_aux (Nexp_constant c2, _) -> + if Big_int.greater_equal c1 c2 then NC_true else NC_false + | _, _ -> NC_bounded_ge (nexp1, nexp2) + end + | NC_bounded_le (nexp1, nexp2) -> - NC_bounded_le (nexp_simp nexp1, nexp_simp nexp2) + let nexp1, nexp2 = nexp_simp nexp1, nexp_simp nexp2 in + begin match nexp1, nexp2 with + | Nexp_aux (Nexp_constant c1, _), Nexp_aux (Nexp_constant c2, _) -> + if Big_int.less_equal c1 c2 then NC_true else NC_false + | _, _ -> NC_bounded_le (nexp1, nexp2) + end + | _ -> nc_aux in NC_aux (nc_aux, l) @@ -365,6 +378,7 @@ let range_typ nexp1 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 atom_bool_typ nc = mk_typ (Typ_app (mk_id "atom_bool", [mk_typ_arg (A_bool nc)])) let string_typ = mk_id_typ (mk_id "string") 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) @@ -609,7 +623,6 @@ let exp_loc = function | E_aux (_, (l, _)) -> l let def_loc = function - | DEF_kind (KD_aux (_, (l, _))) | DEF_type (TD_aux (_, (l, _))) | DEF_fundef (FD_aux (_, (l, _))) | DEF_mapdef (MD_aux (_, (l, _))) @@ -934,9 +947,9 @@ let id_of_fundef (FD_aux (FD_function (_, _, _, funcls), (l, _))) = let id_of_type_def_aux = function | TD_abbrev (id, _, _) - | TD_record (id, _, _, _, _) - | TD_variant (id, _, _, _, _) - | TD_enum (id, _, _, _) + | TD_record (id, _, _, _) + | TD_variant (id, _, _, _) + | TD_enum (id, _, _) | TD_bitfield (id, _, _) -> id let id_of_type_def (TD_aux (td_aux, _)) = id_of_type_def_aux td_aux @@ -944,17 +957,16 @@ 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_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) | DEF_fundef fd -> IdSet.singleton (id_of_fundef fd) | DEF_val (LB_aux (LB_val (pat, _), _)) -> pat_ids pat - | DEF_reg_dec (DEC_aux (DEC_reg (_, id), _)) -> IdSet.singleton id + | DEF_reg_dec (DEC_aux (DEC_reg (_, _, _, id), _)) -> IdSet.singleton id | DEF_spec vs -> IdSet.singleton (id_of_val_spec vs) | DEF_internal_mutrec fds -> IdSet.of_list (List.map id_of_fundef fds) | _ -> IdSet.empty @@ -1172,6 +1184,67 @@ let equal_effects e1 e2 = | Effect_aux (Effect_set base_effs1, _), Effect_aux (Effect_set base_effs2, _) -> BESet.compare (BESet.of_list base_effs1) (BESet.of_list base_effs2) = 0 +let rec kopts_of_nexp (Nexp_aux (nexp,_)) = + match nexp with + | Nexp_id _ + | Nexp_constant _ -> KOptSet.empty + | Nexp_var kid -> KOptSet.singleton (mk_kopt K_int kid) + | Nexp_times (n1,n2) + | Nexp_sum (n1,n2) + | Nexp_minus (n1,n2) -> KOptSet.union (kopts_of_nexp n1) (kopts_of_nexp n2) + | Nexp_exp n + | Nexp_neg n -> kopts_of_nexp n + | Nexp_app (_, nexps) -> List.fold_left KOptSet.union KOptSet.empty (List.map kopts_of_nexp nexps) + +let kopts_of_order (Ord_aux (ord, _)) = + match ord with + | Ord_var kid -> KOptSet.singleton (mk_kopt K_order kid) + | Ord_inc | Ord_dec -> KOptSet.empty + +let rec kopts_of_constraint (NC_aux (nc, _)) = + match nc with + | NC_equal (nexp1, nexp2) + | NC_bounded_ge (nexp1, nexp2) + | NC_bounded_le (nexp1, nexp2) + | NC_not_equal (nexp1, nexp2) -> + KOptSet.union (kopts_of_nexp nexp1) (kopts_of_nexp nexp2) + | NC_set (kid, _) -> KOptSet.singleton (mk_kopt K_int kid) + | NC_or (nc1, nc2) + | NC_and (nc1, nc2) -> + KOptSet.union (kopts_of_constraint nc1) (kopts_of_constraint nc2) + | NC_app (id, args) -> + List.fold_left (fun s t -> KOptSet.union s (kopts_of_typ_arg t)) KOptSet.empty args + | NC_var kid -> KOptSet.singleton (mk_kopt K_bool kid) + | NC_true | NC_false -> KOptSet.empty + +and kopts_of_typ (Typ_aux (t,_)) = + match t with + | Typ_internal_unknown -> KOptSet.empty + | Typ_id _ -> KOptSet.empty + | Typ_var kid -> KOptSet.singleton (mk_kopt K_type kid) + | Typ_fn (ts, t, _) -> List.fold_left KOptSet.union (kopts_of_typ t) (List.map kopts_of_typ ts) + | Typ_bidir (t1, t2) -> KOptSet.union (kopts_of_typ t1) (kopts_of_typ t2) + | Typ_tup ts -> + List.fold_left (fun s t -> KOptSet.union s (kopts_of_typ t)) + KOptSet.empty ts + | Typ_app (_,tas) -> + List.fold_left (fun s ta -> KOptSet.union s (kopts_of_typ_arg ta)) + KOptSet.empty tas + | Typ_exist (kopts, nc, t) -> + let s = KOptSet.union (kopts_of_typ t) (kopts_of_constraint nc) in + KOptSet.diff s (KOptSet.of_list kopts) +and kopts_of_typ_arg (A_aux (ta,_)) = + match ta with + | A_nexp nexp -> kopts_of_nexp nexp + | A_typ typ -> kopts_of_typ typ + | A_order ord -> kopts_of_order ord + | A_bool nc -> kopts_of_constraint nc + +let kopts_of_quant_item (QI_aux (qi, _)) = match qi with + | QI_id kopt -> + KOptSet.singleton kopt + | QI_const nc -> kopts_of_constraint nc + let rec tyvars_of_nexp (Nexp_aux (nexp,_)) = match nexp with | Nexp_id _ diff --git a/src/ast_util.mli b/src/ast_util.mli index ca3a9598..df7f7efb 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -113,7 +113,7 @@ 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 @@ -127,6 +127,7 @@ val atom_typ : nexp -> typ val range_typ : nexp -> nexp -> typ val bit_typ : typ val bool_typ : typ +val atom_bool_typ : n_constraint -> typ val app_typ : id -> typ_arg list -> typ val register_typ : typ -> typ val unit_typ : typ @@ -191,7 +192,7 @@ 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 @@ -353,6 +354,13 @@ val effect_set : effect -> BESet.t val equal_effects : effect -> effect -> bool val union_effects : effect -> effect -> effect +val kopts_of_order : order -> KOptSet.t +val kopts_of_nexp : nexp -> KOptSet.t +val kopts_of_typ : typ -> KOptSet.t +val kopts_of_typ_arg : typ_arg -> KOptSet.t +val kopts_of_constraint : n_constraint -> KOptSet.t +val kopts_of_quant_item : quant_item -> KOptSet.t + val tyvars_of_nexp : nexp -> KidSet.t val tyvars_of_typ : typ -> KidSet.t val tyvars_of_constraint : n_constraint -> KidSet.t diff --git a/src/c_backend.ml b/src/c_backend.ml index 65702764..6e21dab6 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -150,7 +150,7 @@ let rec ctyp_of_typ ctx typ = 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 + if prove __POS__ ctx.local_env (nc_lteq (nconstant min_int64) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant max_int64)) then CT_int64 else CT_int @@ -171,7 +171,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_sbits direction + | n when ctx.optimize_z3 && prove __POS__ ctx.local_env (nc_lteq n (nint 64)) -> CT_sbits direction | _ -> CT_lbits direction end @@ -541,7 +541,7 @@ let analyze_primop' ctx id args typ = | 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)) -> + | n, m when prove __POS__ ctx.local_env (nc_lteq (nconstant min_int64) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant max_int64)) -> AE_val (AV_C_fragment (F_op (op1, "+", op2), typ, CT_int64)) | _ -> no_change end @@ -1390,16 +1390,16 @@ and compile_block ctx = function it returns a ctypdef * ctx pair. **) let compile_type_def ctx (TD_aux (type_def, _)) = match type_def with - | TD_enum (id, _, ids, _) -> + | TD_enum (id, ids, _) -> CTD_enum (id, ids), { ctx with enums = Bindings.add id (IdSet.of_list ids) ctx.enums } - | TD_record (id, _, _, ctors, _) -> + | TD_record (id, _, ctors, _) -> let ctors = List.fold_left (fun ctors (typ, id) -> Bindings.add id (ctyp_of_typ ctx typ) ctors) Bindings.empty ctors in CTD_struct (id, Bindings.bindings ctors), { ctx with records = Bindings.add id ctors ctx.records } - | TD_variant (id, _, _, tus, _) -> + | TD_variant (id, _, tus, _) -> let compile_tu = function | Tu_aux (Tu_ty_id (typ, id), _) -> ctyp_of_typ ctx typ, id in @@ -1623,8 +1623,8 @@ let fix_destructure fail_label = function let letdef_count = ref 0 (** Compile a Sail toplevel definition into an IR definition **) -let rec compile_def ctx = function - | DEF_reg_dec (DEC_aux (DEC_reg (typ, id), _)) -> +let rec compile_def n total ctx = function + | DEF_reg_dec (DEC_aux (DEC_reg (_, _, typ, id), _)) -> [CDEF_reg_dec (id, ctyp_of_typ ctx typ, [])], ctx | DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp), _)) -> let aexp = analyze_functions ctx analyze_primop (c_literals ctx (no_shadow IdSet.empty (anf exp))) in @@ -1645,6 +1645,8 @@ let rec compile_def ctx = function | DEF_fundef (FD_aux (FD_function (_, _, _, [FCL_aux (FCL_Funcl (id, Pat_aux (Pat_exp (pat, exp), _)), _)]), _)) -> c_debug (lazy ("Compiling function " ^ string_of_id id)); + Util.progress "Compiling " (string_of_id id) n total; + (* Find the function's type. *) let quant, Typ_aux (fn_typ, _) = try Env.get_val_spec id ctx.local_env @@ -1763,7 +1765,7 @@ let rec compile_def ctx = function | DEF_internal_mutrec fundefs -> let defs = List.map (fun fdef -> DEF_fundef fdef) fundefs in - List.fold_left (fun (cdefs, ctx) def -> let cdefs', ctx = compile_def ctx def in (cdefs @ cdefs', ctx)) ([], ctx) defs + List.fold_left (fun (cdefs, ctx) def -> let cdefs', ctx = compile_def n total ctx def in (cdefs @ cdefs', ctx)) ([], ctx) defs | def -> c_error ("Could not compile:\n" ^ Pretty_print_sail.to_string (Pretty_print_sail.doc_def def)) @@ -3321,7 +3323,10 @@ let bytecode_ast ctx rewrites (Defs defs) = 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 total = List.length defs in + let _, chunks, ctx = + List.fold_left (fun (n, chunks, ctx) def -> let defs, ctx = compile_def n total ctx def in n + 1, defs :: chunks, ctx) (1, [], ctx) defs + in let cdefs = List.concat (List.rev chunks) in rewrites cdefs @@ -3362,8 +3367,13 @@ let compile_ast ctx c_includes (Defs defs) = 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 total = List.length defs in + let _, chunks, ctx = + List.fold_left (fun (n, chunks, ctx) def -> let defs, ctx = compile_def n total ctx def in n + 1, defs :: chunks, ctx) (1, [], ctx) defs + in let cdefs = List.concat (List.rev chunks) in + let cdefs, ctx = specialize_variants ctx [] cdefs in let cdefs = sort_ctype_defs cdefs in let cdefs = optimize ctx cdefs in @@ -3460,4 +3470,4 @@ let compile_ast ctx c_includes (Defs defs) = ^^ model_main) |> print_endline with - Type_error (l, err) -> c_error ("Unexpected type error when compiling to C:\n" ^ Type_error.string_of_type_error err) + Type_error (_, l, err) -> c_error ("Unexpected type error when compiling to C:\n" ^ Type_error.string_of_type_error err) diff --git a/src/constant_fold.ml b/src/constant_fold.ml index 9e474912..7321a801 100644 --- a/src/constant_fold.ml +++ b/src/constant_fold.ml @@ -161,7 +161,7 @@ let rec rewrite_constant_function_calls' ast = let v = run (Interpreter.Step (lazy "", (lstate, gstate), initial_monad, [])) in let exp = exp_of_value v in try (ok (); Type_check.check_exp (env_of_annot annot) exp (typ_of_annot annot)) with - | Type_error (l, err) -> + | Type_error (env, l, err) -> (* A type error here would be unexpected, so don't ignore it! *) Util.warn ("Type error when folding constants in " ^ string_of_exp (E_aux (e_aux, annot)) diff --git a/src/constraint.ml b/src/constraint.ml index 7ead0cc8..af024ce3 100644 --- a/src/constraint.ml +++ b/src/constraint.ml @@ -53,6 +53,8 @@ open Ast open Ast_util open Util +let opt_smt_verbose = ref false + (* 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 @@ -185,7 +187,9 @@ let call_z3' l vars constraints : smt_result = let problems = [constraints] in let z3_file = smtlib_of_constraints l vars constraints in - (* prerr_endline (Printf.sprintf "SMTLIB2 constraints are: \n%s%!" z3_file); *) + if !opt_smt_verbose then + prerr_endline (Printf.sprintf "SMTLIB2 constraints are: \n%s%!" z3_file) + else (); let rec input_lines chan = function | 0 -> [] @@ -204,12 +208,21 @@ let call_z3' l vars constraints : smt_result = with | Not_found -> begin - let (input_file, tmp_chan) = Filename.open_temp_file "constraint_" ".sat" in + let (input_file, tmp_chan) = + try Filename.open_temp_file "constraint_" ".sat" with + | Sys_error msg -> raise (Reporting.err_general l ("Could not open temp file when calling Z3: " ^ msg)) + in output_string tmp_chan z3_file; close_out tmp_chan; - let z3_chan = Unix.open_process_in ("z3 -t:1000 -T:10 " ^ input_file) in - let z3_output = List.combine problems (input_lines z3_chan (List.length problems)) in - let _ = Unix.close_process_in z3_chan in + let z3_output = + try + let z3_chan = Unix.open_process_in ("z3 -t:1000 -T:10 " ^ input_file) in + let z3_output = List.combine problems (input_lines z3_chan (List.length problems)) in + let _ = Unix.close_process_in z3_chan in + z3_output + with + | exn -> raise (Reporting.err_general l ("Error when calling z3: " ^ Printexc.to_string exn)) + in Sys.remove input_file; try let (problem, _) = List.find (fun (_, result) -> result = "unsat") z3_output in @@ -246,9 +259,16 @@ let rec solve_z3 l vars constraints var = let (input_file, tmp_chan) = Filename.open_temp_file "constraint_" ".sat" in output_string tmp_chan z3_file; close_out tmp_chan; - let z3_chan = Unix.open_process_in ("z3 -t:1000 -T:10 " ^ input_file) in - let z3_output = String.concat " " (input_all z3_chan) in - let _ = Unix.close_process_in z3_chan in + let z3_output = + try + let z3_chan = Unix.open_process_in ("z3 -t:1000 -T:10 " ^ input_file) in + let z3_output = String.concat " " (input_all z3_chan) in + let _ = Unix.close_process_in z3_chan in + z3_output + with + | exn -> + raise (Reporting.err_general l ("Got error when calling z3: " ^ Printexc.to_string exn)) + in Sys.remove input_file; let regexp = {|(define-fun v|} ^ Util.zencode_string (string_of_kid var) ^ {| () Int[ ]+\([0-9]+\))|} in try diff --git a/src/constraint.mli b/src/constraint.mli index 51088245..fa318c35 100644 --- a/src/constraint.mli +++ b/src/constraint.mli @@ -52,6 +52,8 @@ module Big_int = Nat_big_num open Ast open Ast_util +val opt_smt_verbose : bool ref + type smt_result = Unknown | Sat | Unsat val load_digests : unit -> unit diff --git a/src/error_format.ml b/src/error_format.ml new file mode 100644 index 00000000..8e00c2b7 --- /dev/null +++ b/src/error_format.ml @@ -0,0 +1,131 @@ + +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 + +type formatter = { + indent : string; + endline : string -> unit; + loc_color : string -> string + } + +let err_formatter = { + indent = ""; + endline = prerr_endline; + loc_color = Util.red + } + +let buffer_formatter b = { + indent = ""; + endline = (fun str -> Buffer.add_string b (str ^ "\n")); + loc_color = Util.red + } + +let format_endline str ppf = ppf.endline (ppf.indent ^ (Str.global_replace (Str.regexp_string "\n") ("\n" ^ ppf.indent) str)) + +let underline_single color cnum_from cnum_to = + if (cnum_from + 1) >= cnum_to then + Util.(String.make cnum_from ' ' ^ clear (color "^")) + else + Util.(String.make cnum_from ' ' ^ clear (color ("^" ^ String.make (cnum_to - cnum_from - 2) '-' ^ "^"))) + +let format_code_single' fname in_chan lnum cnum_from cnum_to contents ppf = + skip_lines in_chan (lnum - 1); + let line = input_line in_chan in + let line_prefix = string_of_int lnum ^ Util.(clear (cyan " |")) in + let blank_prefix = String.make (String.length (string_of_int lnum)) ' ' ^ Util.(clear (ppf.loc_color " |")) in + format_endline (Printf.sprintf "[%s]:%d:%d-%d" Util.(fname |> cyan |> clear) lnum cnum_from cnum_to) ppf; + format_endline (line_prefix ^ line) ppf; + format_endline (blank_prefix ^ underline_single ppf.loc_color cnum_from cnum_to) ppf; + contents { ppf with indent = blank_prefix ^ " " } + +let underline_double_from color cnum_from eol = + Util.(String.make cnum_from ' ' ^ clear (color ("^" ^ String.make (eol - cnum_from - 1) '-'))) + +let underline_double_to color cnum_to = + Util.(clear (color (String.make (cnum_to - 1) '-' ^ "^"))) + +let format_code_double' fname in_chan lnum_from cnum_from lnum_to cnum_to contents ppf = + skip_lines in_chan (lnum_from - 1); + let line_from = input_line in_chan in + skip_lines in_chan (lnum_to - lnum_from - 1); + let line_to = input_line in_chan in + let line_to_prefix = string_of_int lnum_to ^ Util.(clear (cyan " |")) in + let line_from_padding = String.make (String.length (string_of_int lnum_to) - String.length (string_of_int lnum_from)) ' ' in + let line_from_prefix = string_of_int lnum_from ^ line_from_padding ^ Util.(clear (cyan " |")) in + let blank_prefix = String.make (String.length (string_of_int lnum_to)) ' ' ^ Util.(clear (ppf.loc_color " |")) in + format_endline (Printf.sprintf "[%s]:%d:%d-%d:%d" Util.(fname |> cyan |> clear) lnum_from cnum_from lnum_to cnum_to) ppf; + format_endline (line_from_prefix ^ line_from) ppf; + format_endline (blank_prefix ^ underline_double_from ppf.loc_color cnum_from (String.length line_from)) ppf; + format_endline (line_to_prefix ^ line_to) ppf; + format_endline (blank_prefix ^ underline_double_to ppf.loc_color cnum_to) ppf; + contents { ppf with indent = blank_prefix ^ " " } + +let format_code_single fname lnum cnum_from cnum_to contents ppf = + try + let in_chan = open_in fname in + begin + try format_code_single' fname in_chan lnum cnum_from cnum_to contents ppf; close_in in_chan + with + | _ -> close_in_noerr in_chan; () + end + with + | _ -> () + +let format_code_double fname lnum_from cnum_from lnum_to cnum_to contents ppf = + try + let in_chan = open_in fname in + begin + try format_code_double' fname in_chan lnum_from cnum_from lnum_to cnum_to contents ppf; close_in in_chan + with + | _ -> close_in_noerr in_chan; () + end + with + | _ -> () + +let format_pos p1 p2 contents ppf = + let open Lexing in + if p1.pos_lnum == p2.pos_lnum + then format_code_single p1.pos_fname p1.pos_lnum (p1.pos_cnum - p1.pos_bol) (p2.pos_cnum - p2.pos_bol) contents ppf + else format_code_double p1.pos_fname p1.pos_lnum (p1.pos_cnum - p1.pos_bol) p2.pos_lnum (p2.pos_cnum - p2.pos_bol) contents ppf + +let rec format_loc l contents = + match l with + | Parse_ast.Unknown -> contents + | Parse_ast.Range (p1, p2) -> format_pos p1 p2 contents + | Parse_ast.Unique (_, l) -> format_loc l contents + | Parse_ast.Documented (_, l) -> format_loc l contents + | Parse_ast.Generated l -> + fun ppf -> (format_endline "Code generated nearby:" ppf; format_loc l contents ppf) + +type message = + | Location of Parse_ast.l * message + | Line of string + | List of (string * message) list + | Seq of message list + | With of (formatter -> formatter) * message + +let bullet = Util.(clear (blue "*")) + +let rec format_message msg ppf = + match msg with + | Location (l, msg) -> + format_loc l (format_message msg) ppf + | Line str -> + format_endline str ppf + | Seq messages -> + List.iter (fun msg -> format_message msg ppf) messages + | List list -> + let format_list_item ppf (header, msg) = + format_endline (Util.(clear (blue "*")) ^ " " ^ header) ppf; + format_message msg { ppf with indent = ppf.indent ^ " " } + in + List.iter (format_list_item ppf) list + | With (f, msg) -> format_message msg (f ppf) diff --git a/src/extra_pervasives.ml b/src/extra_pervasives.ml deleted file mode 100644 index 8001c647..00000000 --- a/src/extra_pervasives.ml +++ /dev/null @@ -1,52 +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. *) -(**************************************************************************) - -let unreachable l pos msg = - raise (Reporting.err_unreachable l pos msg) diff --git a/src/finite_map.ml b/src/finite_map.ml deleted file mode 100644 index 444e3790..00000000 --- a/src/finite_map.ml +++ /dev/null @@ -1,216 +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. *) -(**************************************************************************) - - -(** finite map library *) - -module type Fmap = sig - type k - module S : Set.S with type elt = k - type 'a t - val empty : 'a t - val is_empty : 'a t -> bool - val from_list : (k * 'a) list -> 'a t - val to_list : 'a t -> (k * 'a) list - val from_list2 : k list -> 'a list -> 'a t - val insert : 'a t -> (k * 'a) -> 'a t - (* Keys from the right argument replace those from the left *) - val union : 'a t -> 'a t -> 'a t - (* Function merges the stored value when a key is in the right and the left map *) - val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t - val intersect : 'a t -> 'a t -> 'a t - (* Function merges the stored values for shared keys *) - val intersect_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t - val big_union : 'a t list -> 'a t - val big_union_merge : ('a -> 'a -> 'a) -> 'a t list -> 'a t - val difference : 'a t -> 'a t -> 'a t - val merge : (k -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t - val apply : 'a t -> k -> 'a option - val in_dom : k -> 'a t -> bool - val map : (k -> 'a -> 'b) -> 'a t -> 'b t - val domains_overlap : 'a t -> 'b t -> k option - val domains_disjoint : 'a t list -> bool - val iter : (k -> 'a -> unit) -> 'a t -> unit - val fold : ('b -> k -> 'a -> 'b) -> 'b -> 'a t -> 'b - val remove : 'a t -> k -> 'a t - val pp_map : (Format.formatter -> k -> unit) -> - (Format.formatter -> 'a -> unit) -> - Format.formatter -> - 'a t -> - unit - val domain : 'a t -> S.t -end - -module Fmap_map(Key : Set.OrderedType) : Fmap - with type k = Key.t and module S = Set.Make(Key) = struct - - type k = Key.t - module S = Set.Make(Key) - - module M = Map.Make(Key) - module D = Util.Duplicate(S) - - type 'a t = 'a M.t - let empty = M.empty - let is_empty m = M.is_empty m - let from_list l = List.fold_left (fun m (k,v) -> M.add k v m) M.empty l - let from_list2 l1 l2 = List.fold_left2 (fun m k v -> M.add k v m) M.empty l1 l2 - let insert m (k,v) = M.add k v m - let union m1 m2 = - M.merge (fun k v1 v2 -> match v2 with | None -> v1 | Some _ -> v2) m1 m2 - let union_merge f m1 m2 = - M.merge (fun k v1 v2 -> - match v1,v2 with - | None,None -> None - | None,Some v | Some v,None -> Some v - | Some v1, Some v2 -> Some (f v1 v2)) m1 m2 - let merge f m1 m2 = M.merge f m1 m2 - let apply m k = - try - Some(M.find k m) - with - | Not_found -> None - let in_dom k m = M.mem k m - let map f m = M.mapi f m - let rec domains_overlap m1 m2 = - M.fold - (fun k _ res -> - if M.mem k m1 then - Some(k) - else - res) - m2 - None - let iter f m = M.iter f m - let fold f m base = M.fold (fun k v res -> f res k v) base m - let difference m1 m2 = - M.fold (fun k v res -> - if (M.mem k m2) - then res - else M.add k v res) m1 M.empty - let intersect m1 m2 = - M.fold (fun k v res -> - if (M.mem k m2) - then M.add k v res - else res) m1 M.empty - let intersect_merge f m1 m2 = - M.fold (fun k v res -> - match (apply m2 k) with - | None -> res - | Some v2 -> M.add k (f v v2) res) m1 M.empty - let to_list m = M.fold (fun k v res -> (k,v)::res) m [] - let remove m k = M.remove k m - let pp_map pp_key pp_val ppf m = - let l = M.fold (fun k v l -> (k,v)::l) m [] in - Format.fprintf ppf "@[%a@]" - (Pp.lst "@\n" - (fun ppf (k,v) -> - Format.fprintf ppf "@[<2>%a@ |->@ %a@]" - pp_key k - pp_val v)) - l - let big_union l = List.fold_left union empty l - let big_union_merge f l = List.fold_left (union_merge f) empty l - let domains_disjoint maps = - match D.duplicates (List.concat (List.map (fun m -> List.map fst (M.bindings m)) maps)) with - | D.No_dups _ -> true - | D.Has_dups _ -> false - - let domain m = - M.fold (fun k _ s -> S.add k s) m S.empty -end - diff --git a/src/initial_check.ml b/src/initial_check.ml index 78314363..ae65f13d 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -490,13 +490,6 @@ let to_ast_spec ctx (val_:P.val_spec) : (unit val_spec) ctx_out = 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 (P.Name_sect_aux(ns,l)) = - Name_sect_aux( - (match ns with - | P.Name_sect_none -> Name_sect_none - | P.Name_sect_some(s) -> Name_sect_some(s) - ),l) - 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 @@ -523,24 +516,24 @@ let to_ast_typedef ctx (P.TD_aux (aux, l) : P.type_def) : unit type_def ctx_out TD_abbrev (id, typq, typ_arg), add_constructor id typq ctx - | P.TD_record (id, namescm_opt, typq, fields, _) -> + | P.TD_record (id, 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), + TD_record (id, typq, fields, false), add_constructor id typq ctx - | P.TD_variant (id, namescm_opt, typq, arms, _) -> + | P.TD_variant (id, 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), + TD_variant (id, typq, arms, false), add_constructor id typq ctx - | P.TD_enum (id, namescm_opt, enums, _) -> + | P.TD_enum (id, 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), + TD_enum (id, enums, false), { ctx with type_constructors = Bindings.add id [] ctx.type_constructors } | P.TD_bitfield (id, typ, ranges) -> @@ -552,13 +545,6 @@ let to_ast_typedef ctx (P.TD_aux (aux, l) : P.type_def) : unit type_def ctx_out in TD_aux (aux, (l, ())), ctx -let to_ast_kdef ctx (td:P.kind_def) : unit kind_def = - match td with - | P.KD_aux (P.KD_nabbrev (kind, id, name_scm_opt, atyp), l) -> - let id = to_ast_id id in - 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 ctx (P.Rec_aux(r,l): P.rec_opt) : unit rec_opt = Rec_aux((match r with | P.Rec_nonrec -> Rec_nonrec @@ -656,8 +642,8 @@ let to_ast_alias_spec ctx (P.E_aux(e, 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_reg (reffect, weffect, typ, id) -> + DEC_reg (to_ast_effects reffect, to_ast_effects weffect, 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) -> @@ -674,10 +660,10 @@ let to_ast_scattered ctx (P.SD_aux (aux, l)) = 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) -> + | P.SD_variant (id, 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), + SD_variant (id, 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 @@ -710,9 +696,6 @@ let to_ast_def ctx def : unit def ctx_out = 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 @@ -797,6 +780,10 @@ let typ_of_string str = let typ = to_ast_typ initial_ctx typ in typ +let constraint_of_string str = + let atyp = Parser.typ_eof Lexer.token (Lexing.from_string str) in + to_ast_constraint initial_ctx atyp + 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)) @@ -871,7 +858,7 @@ let generate_undefineds vs_ids (Defs defs) = | pats -> mk_pat (P_tup pats) in let undefined_td = function - | TD_enum (id, _, ids, _) when not (IdSet.mem (prepend_id "undefined_" id) vs_ids) -> + | TD_enum (id, ids, _) when not (IdSet.mem (prepend_id "undefined_" id) vs_ids) -> 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) @@ -881,13 +868,13 @@ let generate_undefineds vs_ids (Defs defs) = else mk_exp (E_app (mk_id "internal_pick", [mk_exp (E_list (List.map (fun id -> mk_exp (E_id id)) ids))])))]] - | TD_record (id, _, typq, fields, _) when not (IdSet.mem (prepend_id "undefined_" id) vs_ids) -> + | TD_record (id, typq, fields, _) 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 [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 (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) -> + | 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 = if !opt_fast_undefined && List.length tus > 0 then @@ -947,7 +934,7 @@ let generate_undefineds vs_ids (Defs defs) = Defs (undefined_builtins @ undefined_defs defs) let rec get_registers = function - | DEF_reg_dec (DEC_aux (DEC_reg (typ, id), _)) :: defs -> (typ, id) :: get_registers defs + | DEF_reg_dec (DEC_aux (DEC_reg (_, _, typ, id), _)) :: defs -> (typ, id) :: get_registers defs | _ :: defs -> get_registers defs | [] -> [] @@ -965,7 +952,7 @@ let generate_initialize_registers vs_ids (Defs defs) = let generate_enum_functions vs_ids (Defs defs) = let rec gen_enums = function - | DEF_type (TD_aux (TD_enum (id, _, elems, _), _)) as enum :: defs -> + | DEF_type (TD_aux (TD_enum (id, elems, _), _)) as enum :: defs -> let enum_val_spec name quants typ = mk_val_spec (VS_val_spec (mk_typschm (mk_typquant quants) typ, name, (fun _ -> None), !opt_enum_casts)) in diff --git a/src/initial_check.mli b/src/initial_check.mli index 25187e4c..9d2beab2 100644 --- a/src/initial_check.mli +++ b/src/initial_check.mli @@ -92,3 +92,4 @@ val val_spec_of_string : id -> string -> unit def val exp_of_string : string -> unit exp val typ_of_string : string -> typ +val constraint_of_string : string -> n_constraint diff --git a/src/interactive.ml b/src/interactive.ml new file mode 100644 index 00000000..3c4619a0 --- /dev/null +++ b/src/interactive.ml @@ -0,0 +1,7 @@ + +let opt_interactive = ref false +let opt_suppress_banner = ref false + +let env = ref Type_check.initial_env + +let ast = ref (Ast.Defs []) diff --git a/src/interactive.mli b/src/interactive.mli new file mode 100644 index 00000000..7782f646 --- /dev/null +++ b/src/interactive.mli @@ -0,0 +1,9 @@ +open Ast +open Type_check + +val opt_interactive : bool ref +val opt_suppress_banner : bool ref + +val ast : tannot defs ref + +val env : Env.t ref diff --git a/src/interpreter.ml b/src/interpreter.ml index 194812ca..40ee251d 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -673,7 +673,7 @@ let rec eval_frame' = function let eval_frame frame = try eval_frame' frame with - | Type_check.Type_error (l, err) -> + | Type_check.Type_error (env, l, err) -> raise (Reporting.err_typ l (Type_error.string_of_type_error err)) let rec run_frame frame = diff --git a/src/isail.ml b/src/isail.ml index 18c59e0b..d8cc448a 100644 --- a/src/isail.ml +++ b/src/isail.ml @@ -83,20 +83,22 @@ let rec user_input callback = mode_clear (); begin try callback v with - | Reporting.Fatal_error e -> Reporting.report_error e + | Reporting.Fatal_error e -> Reporting.print_error e end; user_input callback let sail_logo = let banner str = str |> Util.bold |> Util.red |> Util.clear in let logo = - [ {| ___ ___ ___ ___ |}; - {| /\ \ /\ \ /\ \ /\__\|}; - {| /::\ \ /::\ \ _\:\ \ /:/ /|}; - {| /\:\:\__\ /::\:\__\ /\/::\__\ /:/__/ |}; - {| \:\:\/__/ \/\::/ / \::/\/__/ \:\ \ |}; - {| \::/ / /:/ / \:\__\ \:\__\|}; - {| \/__/ \/__/ \/__/ \/__/|} ] + if !Interactive.opt_suppress_banner then [] + else + [ {| ___ ___ ___ ___ |}; + {| /\ \ /\ \ /\ \ /\__\|}; + {| /::\ \ /::\ \ _\:\ \ /:/ /|}; + {| /\:\:\__\ /::\:\__\ /\/::\__\ /:/__/ |}; + {| \:\:\/__/ \/\::/ / \::/\/__/ \:\ \ |}; + {| \::/ / /:/ / \:\__\ \:\__\|}; + {| \/__/ \/__/ \/__/ \/__/|} ] in let help = [ "Type :commands for a list of commands, and :help <command> for help."; @@ -104,9 +106,9 @@ let sail_logo = in List.map banner logo @ [""] @ help @ [""] -let vs_ids = ref (Initial_check.val_spec_ids !interactive_ast) +let vs_ids = ref (Initial_check.val_spec_ids !Interactive.ast) -let interactive_state = ref (initial_state !interactive_ast Value.primops) +let interactive_state = ref (initial_state !Interactive.ast Value.primops) let interactive_bytecode = ref [] @@ -259,7 +261,7 @@ let handle_input' input = | ":n" | ":normal" -> current_mode := Normal | ":t" | ":type" -> - let typq, typ = Type_check.Env.get_val_spec (mk_id arg) !interactive_env in + let typq, typ = Type_check.Env.get_val_spec (mk_id arg) !Interactive.env in pretty_sail stdout (doc_binding (typq, typ)); print_newline (); | ":q" | ":quit" -> @@ -267,12 +269,15 @@ let handle_input' input = exit 0 | ":i" | ":infer" -> let exp = Initial_check.exp_of_string arg in - let exp = Type_check.infer_exp !interactive_env exp in + 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)) + print_endline (string_of_typ (Type_check.canonicalize !Interactive.env typ)) + | ":prove" -> + let nc = Initial_check.constraint_of_string arg in + print_endline (string_of_bool (Type_check.prove __POS__ !Interactive.env nc)) | ":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) @@ -298,7 +303,7 @@ let handle_input' input = | "Order" -> is_order_kopt | _ -> failwith "Invalid kind" in - let ids = Specialize.polymorphic_functions is_kopt !interactive_ast in + let ids = Specialize.polymorphic_functions is_kopt !Interactive.ast in List.iter (fun id -> print_endline (string_of_id id)) (IdSet.elements ids) | ":option" -> begin @@ -309,17 +314,17 @@ let handle_input' input = | Arg.Bad message | Arg.Help message -> print_endline message end; | ":spec" -> - let ast, env = Specialize.specialize !interactive_ast !interactive_env in - interactive_ast := ast; - interactive_env := env; - interactive_state := initial_state !interactive_ast Value.primops + let ast, env = Specialize.specialize !Interactive.ast !Interactive.env in + Interactive.ast := ast; + Interactive.env := env; + interactive_state := initial_state !Interactive.ast Value.primops | ":pretty" -> - print_endline (Pretty_print_sail.to_string (Latex.defs !interactive_ast)) + print_endline (Pretty_print_sail.to_string (Latex.defs !Interactive.ast)) | ":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 ast = Process_file.rewrite_ast_c !Interactive.ast in + let ast, env = Specialize.specialize ast !Interactive.env in let ctx = initial_ctx env in interactive_bytecode := bytecode_ast ctx (List.map flatten_cdef) ast | ":ir" -> @@ -336,7 +341,7 @@ let handle_input' input = 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; + Pretty_print_sail.pp_defs chan !Interactive.ast; close_out chan | ":output" -> let chan = open_out arg in @@ -358,24 +363,24 @@ let handle_input' input = | ":elf" -> Elf_loader.load_elf arg | ":l" | ":load" -> let files = Util.split_on_char ' ' arg in - let (_, ast, env) = load_files !interactive_env files in + let (_, ast, env) = load_files !Interactive.env files in let ast = Process_file.rewrite_ast_interpreter ast in - interactive_ast := append_ast !interactive_ast ast; - interactive_state := initial_state !interactive_ast Value.primops; - interactive_env := env; - vs_ids := Initial_check.val_spec_ids !interactive_ast + Interactive.ast := append_ast !Interactive.ast ast; + interactive_state := initial_state !Interactive.ast Value.primops; + Interactive.env := env; + vs_ids := Initial_check.val_spec_ids !Interactive.ast | ":u" | ":unload" -> - interactive_ast := Ast.Defs []; - interactive_env := Type_check.initial_env; - interactive_state := initial_state !interactive_ast Value.primops; - vs_ids := Initial_check.val_spec_ids !interactive_ast; + Interactive.ast := Ast.Defs []; + Interactive.env := Type_check.initial_env; + interactive_state := initial_state !Interactive.ast Value.primops; + 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 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 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 @@ -386,7 +391,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 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 -> () @@ -441,7 +446,7 @@ let handle_input' input = let handle_input input = try handle_input' input with - | Type_check.Type_error (l, err) -> + | Type_check.Type_error (env, l, err) -> print_endline (Type_error.string_of_type_error err) | Reporting.Fatal_error err -> Reporting.print_error err @@ -488,7 +493,7 @@ let () = LNoise.history_load ~filename:"sail_history" |> ignore; LNoise.history_set ~max_length:100 |> ignore; - if !opt_interactive then + if !Interactive.opt_interactive then begin List.iter print_endline sail_logo; user_input handle_input diff --git a/src/lexer.mll b/src/lexer.mll index 1d48b82b..604931ac 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -146,7 +146,6 @@ 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)); @@ -164,7 +163,6 @@ let kw_table = ("do", (fun _ -> Do)); ("mutual", (fun _ -> Mutual)); ("bitfield", (fun _ -> Bitfield)); - ("where", (fun _ -> Where)); ("barr", (fun x -> Barr)); ("depend", (fun x -> Depend)); diff --git a/src/monomorphise.ml b/src/monomorphise.ml index 4bb1876c..dbe0fafd 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -59,7 +59,6 @@ open Ast open Ast_util module Big_int = Nat_big_num open Type_check -open Extra_pervasives let size_set_limit = 64 @@ -100,36 +99,36 @@ let subst_nexp substs nexp = | Nexp_app (id,args) -> re (Nexp_app (id,List.map s_snexp args)) in s_snexp substs nexp -let rec subst_nc substs (NC_aux (nc,l) as n_constraint) = - let snexp nexp = subst_nexp substs nexp in - let snc nc = subst_nc substs nc in - let re nc = NC_aux (nc,l) in - match nc with - | NC_equal (n1,n2) -> re (NC_equal (snexp n1, snexp n2)) - | NC_bounded_ge (n1,n2) -> re (NC_bounded_ge (snexp n1, snexp n2)) - | NC_bounded_le (n1,n2) -> re (NC_bounded_le (snexp n1, snexp n2)) - | NC_not_equal (n1,n2) -> re (NC_not_equal (snexp n1, snexp n2)) - | NC_set (kid,is) -> - begin - match KBindings.find kid substs with - | 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.err_general l - ("Unable to substitute " ^ string_of_nexp nexp ^ - " into set constraint " ^ string_of_n_constraint n_constraint)) - | exception Not_found -> n_constraint - end - | NC_or (nc1,nc2) -> re (NC_or (snc nc1, snc nc2)) - | NC_and (nc1,nc2) -> re (NC_and (snc nc1, snc nc2)) - | NC_true - | NC_false +let subst_nc, subst_src_typ, subst_src_typ_arg = + let rec subst_nc substs (NC_aux (nc,l) as n_constraint) = + let snexp nexp = subst_nexp substs nexp in + let snc nc = subst_nc substs nc in + let re nc = NC_aux (nc,l) in + match nc with + | NC_equal (n1,n2) -> re (NC_equal (snexp n1, snexp n2)) + | NC_bounded_ge (n1,n2) -> re (NC_bounded_ge (snexp n1, snexp n2)) + | NC_bounded_le (n1,n2) -> re (NC_bounded_le (snexp n1, snexp n2)) + | NC_not_equal (n1,n2) -> re (NC_not_equal (snexp n1, snexp n2)) + | NC_set (kid,is) -> + begin + match KBindings.find kid substs with + | 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.err_general l + ("Unable to substitute " ^ string_of_nexp nexp ^ + " into set constraint " ^ string_of_n_constraint n_constraint)) + | exception Not_found -> n_constraint + end + | NC_or (nc1,nc2) -> re (NC_or (snc nc1, snc nc2)) + | NC_and (nc1,nc2) -> re (NC_and (snc nc1, snc nc2)) + | NC_true + | NC_false -> n_constraint - - - -let subst_src_typ substs t = - let rec s_styp substs ((Typ_aux (t,l)) as ty) = + | NC_var kid -> re (NC_var kid) + | NC_app (f, args) -> + re (NC_app (f, List.map (s_starg substs) args)) + and s_styp substs ((Typ_aux (t,l)) as ty) = let re t = Typ_aux (t,l) in match t with | Typ_id _ @@ -142,13 +141,14 @@ let subst_src_typ 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" + | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" and s_starg substs (A_aux (ta,l) as targ) = match ta with | 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 + | A_bool nc -> A_aux (A_bool (subst_nc substs nc), l) + in subst_nc, s_styp, s_starg let make_vector_lit sz i = let f j = if Big_int.equal (Big_int.modulus (Big_int.shift_right i (sz-j-1)) (Big_int.of_int 2)) Big_int.zero then '0' else '1' in @@ -180,7 +180,7 @@ let rec is_value (E_aux (e,(l,annot))) = let is_constructor id = match destruct_tannot annot with | None -> - (Reporting.print_err false true l "Monomorphisation" + (Reporting.print_err l "Monomorphisation" ("Missing type information for identifier " ^ string_of_id id); false) (* Be conservative if we have no info *) | Some (env,_,_) -> @@ -340,7 +340,7 @@ let rec inst_src_type insts (Typ_aux (ty,l) as typ) = | [] -> insts', t' | _ -> 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" + | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" and inst_src_typ_arg insts (A_aux (ta,l) as tyarg) = match ta with | A_nexp _ @@ -360,7 +360,7 @@ let rec contains_exist (Typ_aux (ty,l)) = | Typ_tup ts -> List.exists contains_exist ts | Typ_app (_,args) -> List.exists contains_exist_arg args | Typ_exist _ -> true - | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" + | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" and contains_exist_arg (A_aux (arg,_)) = match arg with | A_nexp _ @@ -436,7 +436,7 @@ let split_src_type id ty (TypQ_aux (q,ql)) = let tys = List.concat (List.map (fun instty -> List.map (ty_and_inst instty) insts) tys) in let free = List.fold_left (fun vars k -> KidSet.remove k vars) vars kids in (free,tys) - | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" + | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" in (* Only single-variable prenex-form for now *) let size_nvars_ty (Typ_aux (ty,l) as typ) = @@ -545,7 +545,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.print_err false true l "Monomorphisation" + (Reporting.print_err l "Monomorphisation" ("Unable to refine constructor " ^ string_of_id id); None) end @@ -727,8 +727,10 @@ 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.err_general l - ("Undefined value at unsupported type " ^ string_of_typ typ)) + | ([], _, typ) -> nint 32 + | (kids, nc, typ) -> + raise (Reporting.err_general l + ("Undefined value at unsupported type " ^ string_of_typ typ ^ " with " ^ Util.string_of_list ", " string_of_kid kids)) let fabricate_nexp l tannot = match destruct_tannot tannot with @@ -756,7 +758,7 @@ let reduce_cast typ exp l annot = | 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 + if prove __POS__ nc_env nc then exp else raise (Reporting.err_unreachable l __POS__ ("Constant propagation error: literal " ^ Big_int.to_string n ^ @@ -1176,7 +1178,7 @@ let apply_pat_choices choices = let is_env_inconsistent env ksubsts = let env = KBindings.fold (fun k nexp env -> Env.add_constraint (nc_eq (nvar k) nexp) env) ksubsts env in - prove env nc_false + prove __POS__ env nc_false let split_defs all_errors splits defs = let no_errors_happened = ref true in @@ -1190,9 +1192,9 @@ let split_defs all_errors splits defs = in let sc_type_def ((TD_aux (tda,annot)) as td) = match tda with - | TD_variant (id,nscm,quant,tus,flag) -> + | TD_variant (id,quant,tus,flag) -> let (refinements, tus') = List.split (List.map (sc_type_union quant) tus) in - (List.concat refinements, TD_aux (TD_variant (id,nscm,quant,List.concat tus',flag),annot)) + (List.concat refinements, TD_aux (TD_variant (id,quant,List.concat tus',flag),annot)) | _ -> ([],td) in let sc_def d = @@ -1533,7 +1535,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.print_err false true l "Monomorphisation" + | [] -> (Reporting.print_err 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 -> @@ -1580,7 +1582,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.print_err false true l' "Monomorphisation" + (Reporting.print_err l' "Monomorphisation" "Unexpected kind of pattern for enumeration"; GiveUp) in findpat_generic checkpat (string_of_id id) assigns cases | _ -> None) @@ -1603,11 +1605,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.print_err false true lit_l "Monomorphisation" + (Reporting.print_err lit_l "Monomorphisation" "Unexpected kind of literal for var match"; GiveUp) end | P_aux (_,(l',_)) -> - (Reporting.print_err false true l' "Monomorphisation" + (Reporting.print_err 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 -> @@ -1627,11 +1629,11 @@ let split_defs all_errors splits defs = | _ -> DoesNotMatch) (DoesMatch ([],[])) matches in (match final with | GiveUp -> - (Reporting.print_err false true l "Monomorphisation" + (Reporting.print_err l "Monomorphisation" "Unexpected kind of pattern for vector literal"; GiveUp) | _ -> final) | _ -> - (Reporting.print_err false true l "Monomorphisation" + (Reporting.print_err l "Monomorphisation" "Unexpected kind of pattern for vector literal"; GiveUp) in findpat_generic checkpat "vector literal" assigns cases @@ -1649,7 +1651,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.print_err false true l' "Monomorphisation" + (Reporting.print_err l' "Monomorphisation" "Unexpected kind of pattern for literal"; GiveUp) in findpat_generic checkpat "literal" assigns cases | _ -> None @@ -1663,7 +1665,7 @@ let split_defs all_errors splits defs = let substs = bindings_from_list substs, ksubsts in fst (const_prop_exp ref_vars substs Bindings.empty exp) in - + (* Split a variable pattern into every possible value *) let split var pat_l annot = @@ -1686,7 +1688,7 @@ let split_defs all_errors splits defs = else raise (Fatal_error error) in match ty with - | Typ_id (Id_aux (Id "bool",_)) -> + | Typ_id (Id_aux (Id "bool",_)) | Typ_app (Id_aux (Id "atom_bool", _), [_]) -> [P_aux (P_lit (L_aux (L_true,new_l)),(l,annot)),[var, E_aux (E_lit (L_aux (L_true,new_l)),(new_l,annot))],[],[]; P_aux (P_lit (L_aux (L_false,new_l)),(l,annot)),[var, E_aux (E_lit (L_aux (L_false,new_l)),(new_l,annot))],[],[]] @@ -1946,7 +1948,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.print_err false true l "Monomorphisation" + Reporting.print_err l "Monomorphisation" "Splitting a singleton pattern is not possible" in p in @@ -2109,7 +2111,6 @@ let split_defs all_errors splits defs = in let map_def d = match d with - | DEF_kind _ | DEF_type _ | DEF_spec _ | DEF_default _ @@ -2120,7 +2121,7 @@ let split_defs all_errors splits defs = | DEF_internal_mutrec _ -> [d] | DEF_fundef fd -> [DEF_fundef (map_fundef fd)] - | DEF_mapdef (MD_aux (_, (l, _))) -> unreachable l __POS__ "mappings should be gone by now" + | DEF_mapdef (MD_aux (_, (l, _))) -> Reporting.unreachable l __POS__ "mappings should be gone by now" | DEF_val lb -> [DEF_val (map_letbind lb)] | DEF_scattered sd -> List.map (fun x -> DEF_scattered x) (map_scattered_def sd) in @@ -2200,7 +2201,7 @@ let rec sizes_of_typ (Typ_aux (t,l)) = 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" + | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" and sizes_of_typarg (A_aux (ta,_)) = match ta with A_nexp _ @@ -2259,7 +2260,7 @@ let replace_with_the_value bound_nexps (E_aux (_,(l,_)) as exp) = let replace_size size = (* TODO: pick simpler nexp when there's a choice (also in pretty printer) *) let is_equal nexp = - prove env (NC_aux (NC_equal (size,nexp), Parse_ast.Unknown)) + prove __POS__ env (NC_aux (NC_equal (size,nexp), Parse_ast.Unknown)) in if is_nexp_constant size then size else match List.find is_equal bound_nexps with @@ -2345,9 +2346,9 @@ in *) | i -> IntSet.singleton i | exception Not_found -> (* Look for equivalent nexps, but only in consistent type env *) - if prove env (NC_aux (NC_false,Unknown)) then IntSet.empty else + if prove __POS__ env (NC_aux (NC_false,Unknown)) then IntSet.empty else match List.find (fun (nexp,i) -> - prove env (NC_aux (NC_equal (nexp,size),Unknown))) nexp_list with + prove __POS__ env (NC_aux (NC_equal (nexp,size),Unknown))) nexp_list with | _, i -> IntSet.singleton i | exception Not_found -> IntSet.empty end @@ -2848,11 +2849,15 @@ let rec deps_of_nc kid_deps (NC_aux (nc,l)) = | NC_true | NC_false -> dempty + | NC_app (Id_aux (Id "mod", _), [A_aux (A_nexp nexp1, _); A_aux (A_nexp nexp2, _)]) + -> dmerge (deps_of_nexp l kid_deps [] nexp1) (deps_of_nexp l kid_deps [] nexp2) + | NC_var _ | NC_app _ + -> dempty -let deps_of_typ l kid_deps arg_deps typ = +and deps_of_typ l kid_deps arg_deps typ = deps_of_tyvars l kid_deps arg_deps (tyvars_of_typ typ) -let deps_of_typ_arg l fn_id env arg_deps (A_aux (aux, _)) = +and 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 -> @@ -2861,7 +2866,7 @@ let deps_of_typ_arg l fn_id env arg_deps (A_aux (aux, _)) = | 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 @@ -2936,7 +2941,11 @@ let simplify_size_nexp env typ_env (Nexp_aux (ne,l) as nexp) = | Some n -> nconstant n | None -> let is_equal kid = - prove typ_env (NC_aux (NC_equal (Nexp_aux (Nexp_var kid,Unknown), nexp),Unknown)) + (* AA: top_kids should be changed to top_kopts so we don't end + up trying to prove v == nexp for a non-Int v. *) + try + prove __POS__ typ_env (NC_aux (NC_equal (Nexp_aux (Nexp_var kid,Unknown), nexp),Unknown)) + with _ -> false in match ne with | Nexp_var _ @@ -3586,11 +3595,11 @@ let analyse_defs debug env (Defs defs) = else () in let splits = argset_to_list splits in - if Failures.is_empty fails + if Failures.is_empty fails then (true,splits,extras) else begin Failures.iter (fun l msgs -> - Reporting.print_err false false l "Monomorphisation" (String.concat "\n" (StringSet.elements msgs))) + Reporting.print_err l "Monomorphisation" (String.concat "\n" (StringSet.elements msgs))) fails; (false, splits,extras) end @@ -3615,7 +3624,7 @@ let add_extra_splits extras (Defs defs) = let loc = match Analysis.translate_loc l with | Some l -> l | None -> - (Reporting.print_err false false l "Monomorphisation" + (Reporting.print_err l "Monomorphisation" "Internal error: bad location for added case"; ("",0)) in @@ -3935,7 +3944,7 @@ let simplify_size_nexp env quant_kids (Nexp_aux (_,l) as nexp) = | Some n -> Some (nconstant n) | None -> let is_equal kid = - prove env (NC_aux (NC_equal (Nexp_aux (Nexp_var kid,Unknown), nexp),Unknown)) + prove __POS__ env (NC_aux (NC_equal (Nexp_aux (Nexp_var kid,Unknown), nexp),Unknown)) in match List.find is_equal quant_kids with | kid -> Some (Nexp_aux (Nexp_var kid,Generated l)) @@ -4194,11 +4203,11 @@ let replace_nexp_in_typ env typ orig new_nexp = | Typ_app (id, targs) -> 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" + | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" and aux_targ (A_aux (ta,l) as typ_arg) = match ta with | A_nexp nexp -> - if prove env (nc_eq nexp orig) + if prove __POS__ env (nc_eq nexp orig) then true, A_aux (A_nexp new_nexp,l) else false, typ_arg | A_typ typ -> @@ -4227,7 +4236,7 @@ let fresh_nexp_kid nexp = let rewrite_toplevel_nexps (Defs defs) = let find_nexp env nexp_map nexp = - let is_equal (kid,nexp') = prove env (nc_eq nexp nexp') in + let is_equal (kid,nexp') = prove __POS__ env (nc_eq nexp nexp') in List.find is_equal nexp_map in let rec rewrite_typ_in_spec env nexp_map (Typ_aux (t,ann) as typ_full) = diff --git a/src/myocamlbuild.ml b/src/myocamlbuild.ml index f408703f..ae45857d 100644 --- a/src/myocamlbuild.ml +++ b/src/myocamlbuild.ml @@ -79,6 +79,8 @@ let lem_opts = [A "-lib"; P "../gen_lib"; dispatch begin function | After_rules -> + (* Bisect_ppx_plugin.handle_coverage (); *) + (* ocaml_lib "lem_interp/interp"; *) ocaml_lib ~extern:false ~dir:"pprint/src" ~tag_name:"use_pprint" "pprint/src/PPrintLib"; diff --git a/src/nl_flow.ml b/src/nl_flow.ml index e38e5fa5..6196f23b 100644 --- a/src/nl_flow.ml +++ b/src/nl_flow.ml @@ -91,7 +91,7 @@ let add_assert cond (E_aux (aux, (l, ())) as exp) = 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 -> + when (string_of_id f = "unsigned" || string_of_id f = "UInt") && Id.compare id id' = 0 -> begin match pat_id pat with | None -> exp | Some uid -> diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index d075e693..75887b4e 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -393,7 +393,7 @@ let initial_value_for id inits = let ocaml_dec_spec ctx (DEC_aux (reg, _)) = match reg with - | DEC_reg (typ, id) -> + | DEC_reg (_, _, typ, id) -> separate space [string "let"; zencode ctx id; colon; parens (ocaml_typ ctx typ); string "ref"; equals; string "ref"; parens (ocaml_exp ctx (initial_value_for id ctx.register_inits))] @@ -584,20 +584,20 @@ let ocaml_string_of_variant ctx id typq cases = let ocaml_typedef ctx (TD_aux (td_aux, _)) = match td_aux with - | TD_record (id, _, typq, fields, _) -> + | TD_record (id, typq, fields, _) -> ((separate space [string "type"; ocaml_typquant typq; zencode ctx id; equals; lbrace] ^//^ ocaml_fields ctx fields) ^/^ rbrace) ^^ ocaml_def_end ^^ ocaml_string_of_struct ctx id typq fields - | TD_variant (id, _, _, cases, _) when string_of_id id = "exception" -> + | TD_variant (id, _, cases, _) when string_of_id id = "exception" -> ocaml_exceptions ctx cases - | TD_variant (id, _, typq, cases, _) -> + | TD_variant (id, typq, cases, _) -> (separate space [string "type"; ocaml_typquant typq; zencode ctx id; equals] ^//^ ocaml_cases ctx cases) ^^ ocaml_def_end ^^ ocaml_string_of_variant ctx id typq cases - | TD_enum (id, _, ids, _) -> + | TD_enum (id, ids, _) -> (separate space [string "type"; zencode ctx id; equals] ^//^ (bar ^^ space ^^ ocaml_enum ctx ids)) ^^ ocaml_def_end @@ -708,9 +708,9 @@ let ocaml_pp_generators ctx defs orig_types required = match td with | TD_abbrev (_, _, A_aux (A_typ typ, _)) -> add_req_from_typ required typ - | TD_record (_, _, _, fields, _) -> + | TD_record (_, _, fields, _) -> List.fold_left (fun req (typ,_) -> add_req_from_typ req typ) required fields - | TD_variant (_, _, _, variants, _) -> + | TD_variant (_, _, variants, _) -> List.fold_left (fun req (Tu_aux (Tu_ty_id (typ,_),_)) -> add_req_from_typ req typ) required variants | TD_enum _ -> required @@ -724,8 +724,8 @@ let ocaml_pp_generators ctx defs orig_types required = | TD_aux (td,_) -> (match td with | TD_abbrev (_,tqs,A_aux (A_typ _, _)) -> tqs - | TD_record (_,_,tqs,_,_) -> tqs - | TD_variant (_,_,tqs,_,_) -> 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) @@ -847,7 +847,7 @@ let ocaml_pp_generators ctx defs orig_types required = match td with | TD_abbrev (_,tqs,A_aux (A_typ typ, _)) -> tqs, gen_type typ, None, None - | TD_variant (_,_,tqs,variants,_) -> + | TD_variant (_,tqs,variants,_) -> tqs, string "let c = rand_choice [" ^^ group (nest 2 (break 0 ^^ separate_map (string ";" ^^ break 1) rand_variant variants) ^^ @@ -855,7 +855,7 @@ let ocaml_pp_generators ctx defs orig_types required = string "] in c g", Some (separate_map (string ";" ^^ break 1) variant_constructor variants), Some (separate_map (break 1) build_constructor variants) - | TD_enum (_,_,variants,_) -> + | TD_enum (_,variants,_) -> TypQ_aux (TypQ_no_forall, Parse_ast.Unknown), string "rand_choice [" ^^ group (nest 2 (break 0 ^^ separate_map (string ";" ^^ break 1) (zencode_upper ctx) variants) ^^ @@ -863,7 +863,7 @@ 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,_) -> + | TD_record (_,tqs,fields,_) -> tqs, braces (separate_map (string ";" ^^ break 1) rand_field fields), None, None | _ -> raise (Reporting.err_todo l "Generators for bitfields not yet supported") @@ -963,7 +963,7 @@ let ocaml_compile spec defs generator_types = let sail_dir = try Sys.getenv "SAIL_DIR" with | Not_found -> - let share_dir = Share_directory.d in + let share_dir = Manifest.dir in if Sys.file_exists share_dir then share_dir else diff --git a/src/parse_ast.ml b/src/parse_ast.ml index 20a0f48a..2e78b825 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -343,13 +343,6 @@ type_union_aux = (* Type union constructors *) Tu_ty_id of atyp * id | Tu_ty_anon_rec of (atyp * id) list * id - -type -name_scm_opt_aux = (* Optional variable-naming-scheme specification for variables of defined type *) - Name_sect_none - | Name_sect_some of string - - type tannot_opt = Typ_annot_opt_aux of tannot_opt_aux * l @@ -383,12 +376,6 @@ index_range_aux = (* index specification, for bitfields in register types *) and index_range = BF_aux of index_range_aux * l - -type -name_scm_opt = - Name_sect_aux of name_scm_opt_aux * l - - type default_typing_spec_aux = (* Default kinding or typing assumption, and default order for literal vectors and vector shorthands *) DT_order of kind * atyp @@ -447,23 +434,18 @@ fundef_aux = (* Function definition *) type type_def_aux = (* Type definition body *) 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 *) + | TD_record of id * typquant * ((atyp * id)) list * bool (* struct type definition *) + | TD_variant of id * typquant * (type_union) list * bool (* union type definition *) + | TD_enum of id * (id) list * bool (* enumeration type definition *) | TD_bitfield of id * atyp * (id * index_range) list (* register mutable bitfield type definition *) type val_spec_aux = (* Value type specification *) VS_val_spec of typschm * id * (string -> string option) * bool - -type -kind_def_aux = (* Definition body for elements of kind; many are shorthands for type\_defs *) - KD_nabbrev of kind * id * name_scm_opt * atyp (* type abbreviation *) - type dec_spec_aux = (* Register declarations *) - DEC_reg of atyp * id + DEC_reg of atyp * atyp * atyp * id | DEC_config of id * atyp * exp | DEC_alias of id * exp | DEC_typ_alias of atyp * id * exp @@ -474,7 +456,7 @@ scattered_def_aux = (* Function and type union definitions that can be spread a a file. Each one must end in $_$ *) 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_variant of id * 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 @@ -500,12 +482,6 @@ type val_spec = VS_aux of val_spec_aux * l - -type -kind_def = - KD_aux of kind_def_aux * l - - type dec_spec = DEC_aux of dec_spec_aux * l @@ -521,8 +497,7 @@ type fixity_token = (prec * Big_int.num * string) type def = (* Top-level definition *) - DEF_kind of kind_def (* definition of named kind identifiers *) - | DEF_type of type_def (* type definition *) + DEF_type of type_def (* type definition *) | DEF_fundef of fundef (* function definition *) | DEF_mapdef of mapdef (* mapping definition *) | DEF_val of letbind (* value definition *) diff --git a/src/parser.mly b/src/parser.mly index 3ad0931a..7540d1f4 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -134,7 +134,6 @@ let mk_typqn = (TypQ_aux(TypQ_no_forall,Unknown)) let mk_tannotn = Typ_annot_opt_aux(Typ_annot_opt_none,Unknown) let mk_tannot typq typ n m = Typ_annot_opt_aux(Typ_annot_opt_some (typq, typ), loc n m) 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) @@ -178,10 +177,10 @@ 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 And As Assert Bitzero Bitone By Match Clause Dec Default Effect End Op %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 Undefined Union Newtype With Val 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 TerminationMeasure @@ -1170,21 +1169,21 @@ type_def: | 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 } + { mk_td (TD_record ($2, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), $5, false)) $startpos $endpos } | Struct id typaram Eq Lcurly struct_fields Rcurly - { mk_td (TD_record ($2, mk_namesectn, $3, $6, false)) $startpos $endpos } + { mk_td (TD_record ($2, $3, $6, false)) $startpos $endpos } | Enum id Eq enum_bar - { mk_td (TD_enum ($2, mk_namesectn, $4, false)) $startpos $endpos } + { mk_td (TD_enum ($2, $4, false)) $startpos $endpos } | Enum id Eq Lcurly enum Rcurly - { mk_td (TD_enum ($2, mk_namesectn, $5, false)) $startpos $endpos } + { mk_td (TD_enum ($2, $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 } + { mk_td (TD_variant ($2, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), [$4], false)) $startpos $endpos } | Newtype id typaram Eq type_union - { mk_td (TD_variant ($2, mk_namesectn, $3, [$5], false)) $startpos $endpos } + { mk_td (TD_variant ($2, $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 } + { mk_td (TD_variant ($2, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), $5, false)) $startpos $endpos } | Union id typaram Eq Lcurly type_unions Rcurly - { mk_td (TD_variant ($2, mk_namesectn, $3, $6, false)) $startpos $endpos } + { mk_td (TD_variant ($2, $3, $6, false)) $startpos $endpos } | Bitfield id Colon typ Eq Lcurly r_def_body Rcurly { mk_td (TD_bitfield ($2, $4, $7)) $startpos $endpos } @@ -1363,7 +1362,11 @@ val_spec_def: register_def: | Register id Colon typ - { mk_reg_dec (DEC_reg ($4, $2)) $startpos $endpos } + { let rreg = mk_typ (ATyp_set [mk_effect BE_rreg $startpos($1) $endpos($1)]) $startpos($1) $endpos($1) in + let wreg = mk_typ (ATyp_set [mk_effect BE_wreg $startpos($1) $endpos($1)]) $startpos($1) $endpos($1) in + mk_reg_dec (DEC_reg (rreg, wreg, $4, $2)) $startpos $endpos } + | Register effect_set effect_set id Colon typ + { mk_reg_dec (DEC_reg ($2, $3, $6, $4)) $startpos $endpos } | Register Configuration id Colon typ Eq exp { mk_reg_dec (DEC_config ($3, $5, $7)) $startpos $endpos } @@ -1375,9 +1378,9 @@ default_def: scattered_def: | Union id typaram - { mk_sd (SD_variant($2, mk_namesectn, $3)) $startpos $endpos } + { mk_sd (SD_variant($2, $3)) $startpos $endpos } | Union id - { mk_sd (SD_variant($2, mk_namesectn, mk_typqn)) $startpos $endpos } + { mk_sd (SD_variant($2, mk_typqn)) $startpos $endpos } | Function_ id { mk_sd (SD_function(mk_recn, mk_tannotn, mk_eannotn, $2)) $startpos $endpos } | Mapping id @@ -1423,9 +1426,6 @@ def: { DEF_scattered (mk_sd (SD_end $2) $startpos $endpos) } | default_def { DEF_default $1 } - | Constant id Eq typ - { 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 } | Pragma diff --git a/src/pp.ml b/src/pp.ml deleted file mode 100644 index b3eaf1fc..00000000 --- a/src/pp.ml +++ /dev/null @@ -1,80 +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. *) -(**************************************************************************) - -(** pretty printing utilities *) - -open Format - -let pp_str ppf s = - fprintf ppf "%s" s - -let rec lst sep f ppf = function - | [] -> () - | [x] -> - fprintf ppf "%a" - f x - | (h::t) -> - f ppf h; - fprintf ppf sep; - lst sep f ppf t - -let opt f ppf = function - | None -> - fprintf ppf "None" - | Some(x) -> - fprintf ppf "Some(%a)" - f x - -let pp_to_string pp = - let b = Buffer.create 16 in - let f = formatter_of_buffer b in - pp f; - pp_print_flush f (); - Buffer.contents b diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 20db317b..802957c6 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -51,10 +51,10 @@ open Type_check open Ast open Ast_util +open Reporting open Rewriter open PPrint open Pretty_print_common -open Extra_pervasives module StringSet = Set.Make(String) @@ -556,7 +556,7 @@ let replace_typ_size ctxt env (Typ_aux (t,a)) = | Some n -> mk_typ (nconstant n) | None -> let is_equal nexp = - prove env (NC_aux (NC_equal (size,nexp),Parse_ast.Unknown)) + prove __POS__ env (NC_aux (NC_equal (size,nexp),Parse_ast.Unknown)) in match List.find is_equal (NexpSet.elements ctxt.bound_nexps) with | nexp -> mk_typ nexp | exception Not_found -> None @@ -852,7 +852,7 @@ let similar_nexps ctxt env n1 n2 = 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)) && ( + (prove __POS__ 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 @@ -910,7 +910,7 @@ let is_range_from_atom env (Typ_aux (argty,_)) (Typ_aux (fnty,_)) = | 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)) + Type_check.prove __POS__ env (nc_and (nc_eq nexp low) (nc_eq nexp high)) | _ -> false (* Get a more general type for an annotation/expression - i.e., @@ -1781,7 +1781,6 @@ let types_used_with_generic_eq defs = fst (Rewriter.fold_pexp alg pexp) in let typs_req_def = function - | DEF_kind _ | DEF_type _ | DEF_spec _ | DEF_fixity _ @@ -1819,7 +1818,7 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = match td with doc_typquant_items empty_ctxt parens typq; colon; string "Type"]) (doc_typschm empty_ctxt false typschm) ^^ dot - | TD_record(id,nm,typq,fs,_) -> + | TD_record(id,typq,fs,_) -> let fname fid = if prefix_recordtype && string_of_id id <> "regstate" then concat [doc_id id;string "_";doc_id_type fid;] else doc_id_type fid in @@ -1872,7 +1871,7 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = match td with (separate space [string "Record"; id_pp; doc_typquant_items empty_ctxt parens typq]) ((*doc_typquant typq*) (braces (space ^^ align fs_doc ^^ space))) ^^ dot ^^ hardline ^^ eq_pp ^^ updates_pp - | TD_variant(id,nm,typq,ar,_) -> + | TD_variant(id,typq,ar,_) -> (match id with | Id_aux ((Id "read_kind"),_) -> empty | Id_aux ((Id "write_kind"),_) -> empty @@ -1896,7 +1895,7 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = match td with type, so undo that here. *) let resetimplicit = separate space [string "Arguments"; id_pp; colon; string "clear implicits."] in typ_pp ^^ dot ^^ hardline ^^ resetimplicit ^^ hardline ^^ hardline) - | TD_enum(id,nm,enums,_) -> + | TD_enum(id,enums,_) -> (match id with | Id_aux ((Id "read_kind"),_) -> empty | Id_aux ((Id "write_kind"),_) -> empty @@ -2069,8 +2068,8 @@ let merge_kids_atoms pats = match Type_check.destruct_atom_nexp (env_of_annot ann) typ with | Some (Nexp_aux (Nexp_var kid,l)) -> if KidSet.mem kid seen then - let () = - Reporting.print_err false true l "merge_kids_atoms" + let () = + Reporting.print_err 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 @@ -2265,7 +2264,7 @@ let rec doc_fundef (FD_aux(FD_function(r, typa, efa, fcls),fannot)) = let doc_dec (DEC_aux (reg, ((l, _) as annot))) = match reg with - | DEC_reg(typ,id) -> empty + | DEC_reg(_,_,typ,id) -> empty (* let env = env_of_annot annot in let rt = Env.base_typ_of env typ in @@ -2431,7 +2430,6 @@ let rec doc_def unimplemented generic_eq_types def = | DEF_val (LB_aux (LB_val (pat, exp), _)) -> doc_val pat exp | 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 = @@ -2481,7 +2479,7 @@ try 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" + Reporting.print_err 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 @@ -2518,7 +2516,7 @@ try hardline; string "End Content."; hardline]) -with Type_check.Type_error (l,err) -> +with Type_check.Type_error (env,l,err) -> let extra = "\nError during Coq printing\n" ^ if Printexc.backtrace_status () diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index 5c67f93a..1b91bb5d 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -51,10 +51,10 @@ open Type_check open Ast open Ast_util +open Reporting open Rewriter open PPrint open Pretty_print_common -open Extra_pervasives (**************************************************************************** * PPrint-based sail-to-lem pprinter @@ -327,6 +327,9 @@ let doc_typ_lem, doc_atomic_typ_lem = String.concat ", " (List.map string_of_kid bad) ^ " escape into Lem")) end + (* AA: I think the correct thing is likely to filter out + non-integer kinded_id's, then use the above code. *) + | Typ_exist (_,_,Typ_aux(Typ_app(id,[_]),_)) when string_of_id id = "atom_bool" -> string "bool" | 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" @@ -353,7 +356,7 @@ let replace_typ_size ctxt env (Typ_aux (t,a)) = | Some n -> mk_typ (nconstant n) | None -> let is_equal nexp = - prove env (NC_aux (NC_equal (size,nexp),Parse_ast.Unknown)) + prove __POS__ env (NC_aux (NC_equal (size,nexp),Parse_ast.Unknown)) in match List.find is_equal (NexpSet.elements ctxt.bound_nexps) with | nexp -> mk_typ nexp | exception Not_found -> None @@ -1018,7 +1021,7 @@ let doc_typdef_lem (TD_aux(td, (l, annot))) = match td with (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,_) -> + | TD_record(id,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;] else doc_id_lem_type fid in @@ -1070,7 +1073,7 @@ let doc_typdef_lem (TD_aux(td, (l, annot))) = match td with ((*doc_typquant_lem typq*) (anglebars (space ^^ align fs_doc ^^ space))) ^^ hardline (* if !opt_sequential && string_of_id id = "regstate" then empty else separate_map hardline doc_field fs *) - | TD_variant(id,nm,typq,ar,_) -> + | TD_variant(id,typq,ar,_) -> (match id with | Id_aux ((Id "read_kind"),_) -> empty | Id_aux ((Id "write_kind"),_) -> empty @@ -1142,7 +1145,7 @@ let doc_typdef_lem (TD_aux(td, (l, annot))) = match td with fromInterpValuePP ^^ hardline ^^ hardline ^^ fromToInterpValuePP ^^ hardline else empty) - | TD_enum(id,nm,enums,_) -> + | TD_enum(id,enums,_) -> (match id with | Id_aux ((Id "read_kind"),_) -> empty | Id_aux ((Id "write_kind"),_) -> empty @@ -1339,7 +1342,7 @@ let rec doc_fundef_lem (FD_aux(FD_function(r, typa, efa, fcls),fannot) as fd) = let doc_dec_lem (DEC_aux (reg, ((l, _) as annot))) = match reg with - | DEC_reg(typ,id) -> empty + | DEC_reg(_,_,typ,id) -> empty (* if !opt_sequential then empty else let env = env_of_annot annot in @@ -1431,7 +1434,6 @@ let rec doc_def_lem def = group (doc_let_lem empty_ctxt lbind) ^/^ hardline | DEF_scattered sdef -> failwith "doc_def_lem: shoulnd't have DEF_scattered at this point" - | DEF_kind _ -> empty | DEF_mapdef (MD_aux (_, (l, _))) -> unreachable l __POS__ "Lem doesn't support mappings" | DEF_pragma _ -> empty diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index d5758303..5430b284 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -119,6 +119,12 @@ let rec doc_nexp = in nexp0 +let doc_effect (Effect_aux (aux, _)) = + match aux with + | Effect_set [] -> string "pure" + | Effect_set effs -> + braces (separate (comma ^^ space) (List.map (fun be -> string (string_of_base_effect be)) effs)) + 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) = @@ -371,6 +377,8 @@ let rec doc_exp (E_aux (e_aux, _) as exp) = | E_if (if_exp, then_exp, else_exp) when if_block_then then_exp -> (separate space [string "if"; doc_exp if_exp; string "then"] ^//^ doc_exp then_exp) ^/^ (string "else" ^^ space ^^ doc_exp else_exp) + | E_if (if_exp, then_exp, E_aux ((E_lit (L_aux (L_unit, _)) | E_block []), _)) -> + group (separate space [string "if"; doc_exp if_exp; string "then"; doc_exp then_exp]) | E_if (if_exp, then_exp, else_exp) -> group (separate space [string "if"; doc_exp if_exp; string "then"; doc_exp then_exp; string "else"; doc_exp else_exp]) @@ -568,7 +576,10 @@ let doc_mapdef (MD_aux (MD_mapping (id, typa, mapcls), _)) = let doc_dec (DEC_aux (reg,_)) = match reg with - | DEC_reg (typ, id) -> separate space [string "register"; doc_id id; colon; doc_typ typ] + | DEC_reg (Effect_aux (Effect_set [BE_aux (BE_rreg, _)], _), Effect_aux (Effect_set [BE_aux (BE_wreg, _)], _), typ, id) -> + separate space [string "register"; doc_id id; colon; doc_typ typ] + | DEC_reg (reffect, weffect, typ, id) -> + separate space [string "register"; doc_effect reffect; doc_effect weffect; doc_id id; colon; doc_typ typ] | DEC_config (id, typ, exp) -> separate space [string "register configuration"; doc_id id; colon; doc_typ typ; equals; doc_exp exp] | DEC_alias(id,alspec) -> string "ALIAS" | DEC_typ_alias(typ,id,alspec) -> string "ALIAS" @@ -594,16 +605,16 @@ let doc_typdef (TD_aux(td,_)) = match td with | None -> 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, _) -> + | 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] - | TD_record (id, _, TypQ_aux (TypQ_no_forall, _), fields, _) | TD_record (id, _, TypQ_aux (TypQ_tq [], _), fields, _) -> + | 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, _) -> + | TD_record (id, TypQ_aux (TypQ_tq qs, _), fields, _) -> 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, _) -> + | 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, _) -> + | TD_variant (id, TypQ_aux (TypQ_tq qs, _), unions, _) -> 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" @@ -631,9 +642,6 @@ let doc_prec = function | InfixL -> string "infixl" | InfixR -> string "infixr" -let doc_kind_def (KD_aux (KD_nabbrev (_, id, _, nexp), _)) = - separate space [string "integer"; doc_id id; equals; doc_nexp nexp] - let rec doc_scattered (SD_aux (sd_aux, _)) = match sd_aux with | SD_function (_, _, _, id) -> @@ -642,9 +650,9 @@ let rec doc_scattered (SD_aux (sd_aux, _)) = string "function" ^^ space ^^ string "clause" ^^ space ^^ doc_funcl funcl | SD_end id -> string "end" ^^ space ^^ doc_id id - | SD_variant (id, _, TypQ_aux (TypQ_no_forall, _)) -> + | 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, _)) -> + | 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] @@ -653,7 +661,6 @@ let rec doc_def def = group (match def with | DEF_default df -> doc_default df | DEF_spec v_spec -> doc_spec v_spec | DEF_type t_def -> doc_typdef t_def - | DEF_kind k_def -> doc_kind_def k_def | DEF_fundef f_def -> doc_fundef f_def | DEF_mapdef m_def -> doc_mapdef m_def | DEF_val lbind -> string "let" ^^ space ^^ doc_letbind lbind diff --git a/src/process_file.ml b/src/process_file.ml index ca013077..785d7a18 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -126,7 +126,7 @@ let parseid_to_string (Parse_ast.Id_aux (id, _)) = 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) -> + | Parse_ast.TD_variant (union_id, typq, _, flag) -> begin match arms with | [] -> [] | arm :: arms -> @@ -137,7 +137,7 @@ let rec realise_union_anon_rec_types orig_union arms = 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 + let new_rec_def = DEF_type (TD_aux (TD_record (record_id, typq, fields, flag), Generated l)) in (Some new_rec_def, new_arm) :: (realise_union_anon_rec_types orig_union arms) end | _ -> @@ -191,7 +191,7 @@ let rec preprocess opts = function let sail_dir = try Sys.getenv "SAIL_DIR" with | Not_found -> - let share_dir = Share_directory.d in + let share_dir = Manifest.dir in if Sys.file_exists share_dir then share_dir else @@ -210,7 +210,7 @@ let rec preprocess opts = function (* realise any anonymous record arms of variants *) | Parse_ast.DEF_type (Parse_ast.TD_aux - (Parse_ast.TD_variant (id, name_scm_opt, typq, arms, flag) as union, l) + (Parse_ast.TD_variant (id, typq, arms, flag) as union, l) ) :: defs -> let records_and_arms = realise_union_anon_rec_types union arms in let rec filter_records = function [] -> [] @@ -219,7 +219,7 @@ let rec preprocess opts = function in let generated_records = filter_records (List.map fst records_and_arms) in let rewritten_arms = List.map snd records_and_arms in - let rewritten_union = Parse_ast.TD_variant (id, name_scm_opt, typq, rewritten_arms, flag) in + let rewritten_union = Parse_ast.TD_variant (id, typq, rewritten_arms, flag) in generated_records @ (Parse_ast.DEF_type (Parse_ast.TD_aux (rewritten_union, l))) :: preprocess opts defs | (Parse_ast.DEF_default (Parse_ast.DT_aux (Parse_ast.DT_order (_, Parse_ast.ATyp_aux (atyp, _)), _)) as def) :: defs -> @@ -365,7 +365,7 @@ let output libpath out_arg files = output1 libpath out_arg f defs) files -let rewrite_step defs (name, rewriter) = +let rewrite_step n total defs (name, rewriter) = let t = Profile.start () in let defs = rewriter defs in Profile.finish ("rewrite " ^ name) t; @@ -380,11 +380,13 @@ let rewrite_step defs (name, rewriter) = opt_ddump_rewrite_ast := Some (f, i + 1) end | _ -> () in + Util.progress "Rewrite " name n total; defs let rewrite rewriters defs = - try List.fold_left rewrite_step defs rewriters with - | Type_check.Type_error (l, err) -> + let total = List.length rewriters in + try snd (List.fold_left (fun (n, defs) rw -> n + 1, rewrite_step n total defs rw) (1, defs) rewriters) with + | Type_check.Type_error (_, l, err) -> raise (Reporting.err_typ l (Type_error.string_of_type_error err)) let rewrite_ast = rewrite [("initial", Rewriter.rewrite_defs)] diff --git a/src/profile.ml b/src/profile.ml index cb374403..1a8bd30b 100644 --- a/src/profile.ml +++ b/src/profile.ml @@ -83,7 +83,7 @@ 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 "%s %s: %fs" Util.("Profiled" |> 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 | [] -> () diff --git a/src/reporting.ml b/src/reporting.ml index 858e5c41..0bc73ed6 100644 --- a/src/reporting.ml +++ b/src/reporting.ml @@ -95,166 +95,24 @@ (* 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 () +type pos_or_loc = Loc of Parse_ast.l | Pos of Lexing.position + +let print_err_internal p_l m1 m2 = + let open Error_format in + prerr_endline (m1 ^ ":"); + begin match p_l with + | Loc l -> format_message (Location (l, Line m2)) err_formatter + | Pos p -> format_message (Location (Parse_ast.Range (p, p), Line m2)) err_formatter 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 - -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 = - 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)) - -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) -> - 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 = - (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 ?code:(code=true) l = - let _ = Format.flush_str_formatter () in - let _ = format_loc_aux ~code:code 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 open Error_format in + let b = Buffer.create 160 in + format_message (Location (l, Line "")) (buffer_formatter b); + Buffer.contents b -let print_err fatal verb_loc l m1 m2 = - print_err_internal fatal verb_loc (Loc l) m1 m2 +let print_err l m1 m2 = + print_err_internal (Loc l) m1 m2 type error = | Err_general of Parse_ast.l * string @@ -264,20 +122,18 @@ type error = | 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_general (l, m) -> ("Error", 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) + (Printf.sprintf "Internal error: Unreachable code (at \"%s\" line %d)" file line, Loc l, m ^ issues) + | Err_todo (l, m) -> ("Todo" ^ m, Loc l, "") + | Err_syntax (p, m) -> ("Syntax error", Pos p, m) + | Err_syntax_locn (l, m) -> ("Syntax error", Loc l, m) + | Err_lex (p, s) -> ("Lexical error", Pos p, s) + | Err_type (l, m) -> ("Type error", Loc l, m) exception Fatal_error of error @@ -286,12 +142,10 @@ 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 unreachable l pos msg = + raise (err_unreachable l pos msg) 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 + let (m1, pos_l, m2) = dest_err e in + print_err_internal pos_l m1 m2 diff --git a/src/reporting.mli b/src/reporting.mli index 63ed3eee..2d886111 100644 --- a/src/reporting.mli +++ b/src/reporting.mli @@ -69,13 +69,13 @@ val loc_to_string : ?code:bool -> Parse_ast.l -> string 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 +val print_err : Parse_ast.l -> string -> string -> unit (** {2 Errors } *) (** Errors stop execution and print a message; they typically have a location and message. *) -type error = +type error = (** General errors, used for multi purpose. If you are unsure, use this one. *) | Err_general of Parse_ast.l * string @@ -90,8 +90,7 @@ type error = | 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))] *) @@ -106,11 +105,6 @@ 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 unreachable : Parse_ast.l -> (string * int * int * int) -> string -> 'a val print_error : error -> unit diff --git a/src/rewriter.ml b/src/rewriter.ml index 21310b91..81fa7c29 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -336,7 +336,7 @@ let rewrite_lexp rewriters (LEXP_aux(lexp,(l,annot))) = | LEXP_memory (id,exps) -> rewrap (LEXP_memory(id,List.map (rewriters.rewrite_exp rewriters) exps)) | LEXP_vector (lexp,exp) -> rewrap (LEXP_vector (rewriters.rewrite_lexp rewriters lexp,rewriters.rewrite_exp rewriters exp)) - | LEXP_vector_range (lexp,exp1,exp2) -> + | LEXP_vector_range (lexp,exp1,exp2) -> rewrap (LEXP_vector_range (rewriters.rewrite_lexp rewriters lexp, rewriters.rewrite_exp rewriters exp1, rewriters.rewrite_exp rewriters exp2)) @@ -358,7 +358,7 @@ let rewrite_fun rewriters (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls let rewrite_def rewriters d = match d with | DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp), annot)) -> DEF_reg_dec (DEC_aux (DEC_config (id, typ, rewriters.rewrite_exp rewriters exp), annot)) - | DEF_type _ | DEF_mapdef _ | DEF_kind _ | DEF_spec _ | DEF_default _ | DEF_reg_dec _ | DEF_overload _ | DEF_fixity _ -> d + | DEF_type _ | DEF_mapdef _ | DEF_spec _ | DEF_default _ | DEF_reg_dec _ | DEF_overload _ | DEF_fixity _ -> d | 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) @@ -372,6 +372,17 @@ let rewrite_defs_base rewriters (Defs defs) = | d::ds -> (rewriters.rewrite_def rewriters d)::(rewrite ds) in Defs (rewrite defs) +let rewrite_defs_base_progress prefix rewriters (Defs defs) = + let total = List.length defs in + let rec rewrite n = function + | [] -> [] + | d :: ds -> + Util.progress (prefix ^ " ") (string_of_int n ^ "/" ^ string_of_int total) n total; + let d = rewriters.rewrite_def rewriters d in + d :: rewrite (n + 1) ds + in + Defs (rewrite 1 defs) + let rewriters_base = {rewrite_exp = rewrite_exp; rewrite_pat = rewrite_pat; @@ -383,29 +394,6 @@ let rewriters_base = let rewrite_defs (Defs defs) = rewrite_defs_base rewriters_base (Defs defs) -module Envmap = Finite_map.Fmap_map(String) - -(* TODO: This seems to only consider a single assignment (or possibly two, in - separate branches of an if-expression). Hence, it seems the result is always - at most one variable. Is this intended? - It is only used below when pulling out local variables inside if-expressions - into the outer scope, which seems dubious. I comment it out for now. *) -(*let rec introduced_variables (E_aux (exp,(l,annot))) = - match exp with - | E_cast (typ, exp) -> introduced_variables exp - | E_if (c,t,e) -> Envmap.intersect (introduced_variables t) (introduced_variables e) - | E_assign (lexp,exp) -> introduced_vars_le lexp exp - | _ -> Envmap.empty - -and introduced_vars_le (LEXP_aux(lexp,annot)) exp = - match lexp with - | LEXP_id (Id_aux (Id id,_)) | LEXP_cast(_,(Id_aux (Id id,_))) -> - (match annot with - | Base((_,t),Emp_intro,_,_,_,_) -> - Envmap.insert Envmap.empty (id,(t,exp)) - | _ -> Envmap.empty) - | _ -> Envmap.empty*) - type ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg = { p_lit : lit -> 'pat_aux ; p_wild : 'pat_aux diff --git a/src/rewriter.mli b/src/rewriter.mli index 9da94a99..53b892d4 100644 --- a/src/rewriter.mli +++ b/src/rewriter.mli @@ -70,6 +70,9 @@ val rewrite_defs : tannot defs -> tannot defs val rewrite_defs_base : tannot rewriters -> tannot defs -> tannot defs +(* Same as rewrite_defs base but display a progress bar when verbosity >= 1 *) +val rewrite_defs_base_progress : string -> tannot rewriters -> tannot defs -> tannot defs + val rewrite_lexp : tannot rewriters -> tannot lexp -> tannot lexp val rewrite_pat : tannot rewriters -> tannot pat -> tannot pat diff --git a/src/rewrites.ml b/src/rewrites.ml index 8894f2c8..1ca39998 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -54,7 +54,6 @@ open Ast_util open Type_check open Spec_analysis open Rewriter -open Extra_pervasives let (>>) f g = fun x -> g(f(x)) @@ -332,18 +331,18 @@ let rewrite_trivial_sizeof, rewrite_trivial_sizeof_exp = let extract_typ_var l env nexp (id, (_, typ)) = let var = E_aux (E_id id, (l, mk_tannot env typ no_effect)) in match destruct_atom_nexp env typ with - | Some size when prove env (nc_eq size nexp) -> Some var + | Some size when prove __POS__ env (nc_eq size nexp) -> Some var (* AA: This next case is a bit of a hack... is there a more general way to deal with trivial nexps that are offset by constants? This will resolve a 'n - 1 sizeof when 'n is in scope. *) - | Some size when prove env (nc_eq (nsum size (nint 1)) nexp) -> + | Some size when prove __POS__ env (nc_eq (nsum size (nint 1)) nexp) -> let one_exp = infer_exp env (mk_lit_exp (L_num (Big_int.of_int 1))) in Some (E_aux (E_app (mk_id "add_atom", [var; one_exp]), (gen_loc l, mk_tannot env (atom_typ (nsum size (nint 1))) no_effect))) | _ -> begin match destruct_vector env typ with - | Some (len, _, _) when prove env (nc_eq len nexp) -> + | Some (len, _, _) when prove __POS__ env (nc_eq len nexp) -> Some (E_aux (E_app (mk_id "length", [var]), (l, mk_tannot env (atom_typ len) no_effect))) | _ -> None end @@ -351,13 +350,24 @@ let rewrite_trivial_sizeof, rewrite_trivial_sizeof_exp = let rec split_nexp (Nexp_aux (nexp_aux, l) as nexp) = match nexp_aux with | Nexp_sum (n1, n2) -> - mk_exp (E_app (mk_id "add_atom", [split_nexp n1; split_nexp n2])) + mk_exp ~loc:l (E_app (mk_id "add_atom", [split_nexp n1; split_nexp n2])) | Nexp_minus (n1, n2) -> - mk_exp (E_app (mk_id "sub_atom", [split_nexp n1; split_nexp n2])) + mk_exp ~loc:l (E_app (mk_id "sub_atom", [split_nexp n1; split_nexp n2])) | Nexp_times (n1, n2) -> - mk_exp (E_app (mk_id "mult_atom", [split_nexp n1; split_nexp n2])) - | Nexp_neg nexp -> mk_exp (E_app (mk_id "negate_atom", [split_nexp nexp])) - | _ -> mk_exp (E_sizeof nexp) + mk_exp ~loc:l (E_app (mk_id "mult_atom", [split_nexp n1; split_nexp n2])) + | Nexp_neg nexp -> + mk_exp ~loc:l (E_app (mk_id "negate_atom", [split_nexp nexp])) + | Nexp_app (f, [n1; n2]) when string_of_id f = "div" -> + (* We should be more careful about the right division here *) + mk_exp ~loc:l (E_app (mk_id "div", [split_nexp n1; split_nexp n2])) + | _ -> + mk_exp ~loc:l (E_sizeof nexp) + in + let is_int_typ env v _ = function + | (_, Typ_aux (Typ_app (f, [A_aux (A_nexp (Nexp_aux (Nexp_var v', _)), _)]), _)) + when Kid.compare v v' = 0 && string_of_id f = "atom" -> + true + | _ -> false in let rec rewrite_e_aux split_sizeof (E_aux (e_aux, (l, _)) as orig_exp) = let env = env_of orig_exp in @@ -366,9 +376,13 @@ let rewrite_trivial_sizeof, rewrite_trivial_sizeof_exp = E_aux (E_lit (L_aux (L_num c, l)), (l, mk_tannot env (atom_typ nexp) no_effect)) | E_sizeof nexp -> begin + let locals = Env.get_locals env in match nexp_simp (rewrite_nexp_ids (env_of orig_exp) nexp) with | Nexp_aux (Nexp_constant c, _) -> E_aux (E_lit (L_aux (L_num c, l)), (l, mk_tannot env (atom_typ nexp) no_effect)) + | Nexp_aux (Nexp_var v, _) when Bindings.exists (is_int_typ env v) locals -> + let id = fst (Bindings.choose (Bindings.filter (is_int_typ env v) locals)) in + E_aux (E_id id, (l, mk_tannot env (atom_typ nexp) no_effect)) | _ -> let locals = Env.get_locals env in let exps = Bindings.bindings locals @@ -462,7 +476,7 @@ let rewrite_sizeof (Defs defs) = for the given parameters in the original environment *) let inst = try instantiation_of orig_exp with - | Type_error (l, err) -> + | Type_error (_, l, err) -> 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 *) @@ -475,7 +489,7 @@ let rewrite_sizeof (Defs defs) = | 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) -> + | Type_error (_, l, 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 @@ -1325,7 +1339,7 @@ let contains_bitvector_pexp = function let remove_bitvector_pat (P_aux (_, (l, _)) as pat) = - let env = try env_of_pat pat with _ -> Env.empty in + let env = try env_of_pat pat with _ -> raise (Reporting.err_unreachable l __POS__ "Pattern without annotation found") in (* first introduce names for bitvector patterns *) let name_bitvector_roots = @@ -2092,23 +2106,23 @@ let rewrite_split_fun_constr_pats fun_name (Defs defs) = | _ -> function_typ [args_typ] ret_typ eff in - let quant_new_tyvars qis = - 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 K_int) (KidSet.elements new_tyvars) + let quant_new_kopts qis = + let quant_kopts = List.fold_left KOptSet.union KOptSet.empty (List.map kopts_of_quant_item qis) in + let typ_kopts = kopts_of_typ fun_typ in + let new_kopts = KOptSet.diff typ_kopts quant_kopts in + List.map mk_qi_kopt (KOptSet.elements new_kopts) in let typquant = match typquant with | TypQ_aux (TypQ_tq qis, l) -> let qis = List.filter - (fun qi -> KidSet.subset (tyvars_of_quant_item qi) (tyvars_of_typ fun_typ)) + (fun qi -> KOptSet.subset (kopts_of_quant_item qi) (kopts_of_typ fun_typ)) qis - @ quant_new_tyvars qis + @ quant_new_kopts qis in TypQ_aux (TypQ_tq qis, l) | _ -> - TypQ_aux (TypQ_tq (List.map (mk_qi_id K_int) (KidSet.elements (tyvars_of_typ fun_typ))), l) + TypQ_aux (TypQ_tq (List.map mk_qi_kopt (KOptSet.elements (kopts_of_typ fun_typ))), l) in let val_spec = VS_aux (VS_val_spec @@ -2275,25 +2289,32 @@ let rewrite_fix_val_specs (Defs defs) = (* Turn constraints into numeric expressions with sizeof *) let rewrite_constraint = - let rec rewrite_nc (NC_aux (nc_aux, l)) = mk_exp (rewrite_nc_aux nc_aux) - and rewrite_nc_aux = function + let rec rewrite_nc env (NC_aux (nc_aux, l)) = mk_exp (rewrite_nc_aux l env nc_aux) + and rewrite_nc_aux l env = function | NC_bounded_ge (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id ">=", mk_exp (E_sizeof n2)) | NC_bounded_le (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "<=", mk_exp (E_sizeof n2)) | NC_equal (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "==", mk_exp (E_sizeof n2)) | NC_not_equal (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "!=", mk_exp (E_sizeof n2)) - | NC_and (nc1, nc2) -> E_app_infix (rewrite_nc nc1, mk_id "&", rewrite_nc nc2) - | NC_or (nc1, nc2) -> E_app_infix (rewrite_nc nc1, mk_id "|", rewrite_nc nc2) + | NC_and (nc1, nc2) -> E_app_infix (rewrite_nc env nc1, mk_id "&", rewrite_nc env nc2) + | NC_or (nc1, nc2) -> E_app_infix (rewrite_nc env nc1, mk_id "|", rewrite_nc env nc2) | NC_false -> E_lit (mk_lit L_false) | NC_true -> E_lit (mk_lit L_true) | NC_set (kid, []) -> E_lit (mk_lit (L_false)) | NC_set (kid, int :: ints) -> let kid_eq kid int = nc_eq (nvar kid) (nconstant int) in - unaux_exp (rewrite_nc (List.fold_left (fun nc int -> nc_or nc (kid_eq kid int)) (kid_eq kid int) ints)) + unaux_exp (rewrite_nc env (List.fold_left (fun nc int -> nc_or nc (kid_eq kid int)) (kid_eq kid int) ints)) + | NC_app (f, [A_aux (A_bool nc, _)]) when string_of_id f = "not" -> + E_app (mk_id "not_bool", [rewrite_nc env nc]) + | NC_app (f, args) -> + unaux_exp (rewrite_nc env (Env.expand_constraint_synonyms env (mk_nc (NC_app (f, args))))) + | NC_var v -> + (* Would be better to translate change E_sizeof to take a kid, then rewrite to E_sizeof *) + E_id (id_of_kid v) in - let rewrite_e_aux (E_aux (e_aux, _) as exp) = + let rewrite_e_aux (E_aux (e_aux, (l, _)) as exp) = match e_aux with | E_constraint nc -> - check_exp (env_of exp) (rewrite_nc nc) bool_typ + locate (fun _ -> gen_loc l) (check_exp (env_of exp) (rewrite_nc (env_of exp) nc) (atom_bool_typ nc)) | _ -> exp in @@ -2308,17 +2329,17 @@ let rewrite_type_def_typs rw_typ rw_typquant (TD_aux (td, annot)) = match td with | 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) -> - TD_aux (TD_variant (id, nso, rw_typquant typq, List.map (rewrite_type_union_typs rw_typ) tus, flag), annot) - | TD_enum (id, nso, ids, flag) -> TD_aux (TD_enum (id, nso, ids, flag), annot) + | TD_record (id, typq, typ_ids, flag) -> + TD_aux (TD_record (id, rw_typquant typq, List.map (fun (typ, id) -> (rw_typ typ, id)) typ_ids, flag), annot) + | TD_variant (id, typq, tus, flag) -> + TD_aux (TD_variant (id, rw_typquant typq, List.map (rewrite_type_union_typs rw_typ) tus, flag), annot) + | TD_enum (id, ids, flag) -> TD_aux (TD_enum (id, ids, flag), annot) | TD_bitfield _ -> assert false (* Processed before re-writing *) (* FIXME: other reg_dec types *) let rewrite_dec_spec_typs rw_typ (DEC_aux (ds, annot)) = match ds with - | DEC_reg (typ, id) -> DEC_aux (DEC_reg (rw_typ typ, id), annot) + | DEC_reg (reffect, weffect, typ, id) -> DEC_aux (DEC_reg (reffect, weffect, rw_typ typ, id), annot) | DEC_config (id, typ, exp) -> DEC_aux (DEC_config (id, rw_typ typ, exp), annot) | _ -> assert false @@ -2365,6 +2386,8 @@ and simple_typ_aux = function Typ_id (mk_id "int") | Typ_app (id, [_; _]) when Id.compare id (mk_id "range") = 0 -> Typ_id (mk_id "int") + | Typ_app (id, [_]) when Id.compare id (mk_id "atom_bool") = 0 -> + Typ_id (mk_id "bool") | Typ_app (id, args) -> Typ_app (id, List.concat (List.map simple_typ_arg args)) | Typ_fn (arg_typs, ret_typ, effs) -> Typ_fn (List.map simple_typ arg_typs, simple_typ ret_typ, effs) | Typ_tup typs -> Typ_tup (List.map simple_typ typs) @@ -2472,7 +2495,7 @@ let rewrite_vector_concat_assignments defs = mk_exp (E_assign (lexp, tup)))) in begin try check_exp env e_aux unit_typ with - | Type_error (l, err) -> + | Type_error (_, l, err) -> raise (Reporting.err_typ l (Type_error.string_of_type_error err)) end else E_aux (e_aux, annot) @@ -2501,7 +2524,7 @@ let rewrite_tuple_assignments defs = let let_exp = mk_exp (E_let (letbind, block)) in begin try check_exp env let_exp unit_typ with - | Type_error (l, err) -> + | Type_error (_, l, err) -> raise (Reporting.err_typ l (Type_error.string_of_type_error err)) end | _ -> E_aux (e_aux, annot) @@ -3014,10 +3037,16 @@ 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 hack_typ (Typ_aux (aux, _) as typ) = + match aux with + | Typ_app (Id_aux (Id "atom_bool", _), [_]) -> bool_typ + | Typ_app (Id_aux (Id "atom", _), [_]) -> int_typ + | _ -> typ + in let option_typ = app_typ (mk_id "option") [A_aux (A_typ (match binding_typs with | [] -> unit_typ - | [typ] -> typ - | typs -> tuple_typ typs + | [typ] -> hack_typ typ + | typs -> tuple_typ (List.map hack_typ typs) ), unk)] in let bindings = if bindings = [] then @@ -3046,11 +3075,22 @@ let construct_toplevel_string_append_func env f_id pat = else bindings in + (* AA: Pulling the types out of a pattern with binding_typs_of_pat + is broken here because they might contain type variables that + were bound locally to the pattern, so we can't lift them out to + the top-level. As a hacky fix we can generalise types where this + is likely to happen. *) + let hack_typ (Typ_aux (aux, _) as typ) = + match aux with + | Typ_app (Id_aux (Id "atom_bool", _), [_]) -> bool_typ + | Typ_app (Id_aux (Id "atom", _), [_]) -> int_typ + | _ -> typ + in let option_typ = app_typ (mk_id "option") [A_aux (A_typ (match binding_typs with | [] -> unit_typ - | [typ] -> typ - | typs -> tuple_typ typs - ), unk)] + | [typ] -> hack_typ typ + | typs -> tuple_typ (List.map hack_typ typs) + ), unk)] in let fun_typ = (mk_typ (Typ_fn ([string_typ], option_typ, no_effect))) in let new_val_spec = VS_aux (VS_val_spec (mk_typschm (TypQ_aux (TypQ_no_forall, unk)) fun_typ, f_id, (fun _ -> None), false), unkt) in @@ -3107,7 +3147,7 @@ let construct_toplevel_string_append_func env f_id pat = let mapping_inner_typ = match Env.get_val_spec (mk_id mapping_prefix_func) env with | (_, 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?" + | _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "mapping prefix func without correct function type?") in let s_id = fresh_stringappend_id () in @@ -3133,7 +3173,7 @@ let construct_toplevel_string_append_func env f_id pat = let some_pat = annot_pat (P_app (mk_id "Some", [tup_arg_pat; annot_pat (P_id len_id) unk env nat_typ])) - unk env opt_typ in + unk env opt_typ in let some_pat, some_pat_env, _ = bind_pat env (strip_pat some_pat) opt_typ in (* need to add the Some(...) env to tup_arg_pats for pat_to_exp below as it calls the typechecker *) @@ -3283,7 +3323,7 @@ let rec rewrite_defs_pat_string_append = let mapping_inner_typ = match Env.get_val_spec (mk_id mapping_prefix_func) env with | (_, 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?" + | _ -> typ_error env Parse_ast.Unknown "mapping prefix func without correct function type?" in let s_id = fresh_stringappend_id () in @@ -3518,7 +3558,7 @@ let rewrite_defs_mapping_patterns = let false_exp = annot_exp (E_lit (L_aux (L_false, unk))) unk env bool_typ in let new_other_guards = annot_exp (E_if (new_guard, - (annot_exp (E_let (new_letbind, fold_typed_guards env guards)) unk env bool_typ), + (annot_exp (E_let (new_letbind, annot_exp (E_cast (bool_typ, fold_typed_guards env guards)) unk env bool_typ)) unk env bool_typ), false_exp)) unk env bool_typ in annot_pat (P_typ (mapping_in_typ, annot_pat (P_id s_id) unk env mapping_in_typ)) unk env mapping_in_typ, [new_guard; new_other_guards], new_let @@ -4285,12 +4325,12 @@ let rewrite_defs_realise_mappings (Defs defs) = (* 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?" + | _ -> raise (Reporting.err_unreachable l __POS__ "mapping with no clauses?") in let (typq, bidir_typ) = Env.get_val_spec id env in let (typ1, typ2, l) = match bidir_typ with | Typ_aux (Typ_bidir (typ1, typ2), l) -> typ1, typ2, l - | _ -> Type_check.typ_error l "non-bidir type of mapping?" + | _ -> raise (Reporting.err_unreachable l __POS__ "non-bidir type of mapping?") in let forwards_typ = Typ_aux (Typ_fn ([typ1], typ2, no_effect), l) in let forwards_matches_typ = Typ_aux (Typ_fn ([typ1], bool_typ, no_effect), l) in @@ -4618,7 +4658,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.print_err false false + let () = Reporting.print_err (loc_of p) "Match checking" "Redundant wildcard clause" in acc, [] | h::t -> aux (process rps h) (h::acc) t @@ -4658,7 +4698,7 @@ let rewrite_case (e,ann) = let _ = if !opt_coq_warn_nonexhaustive - then Reporting.print_err false false + then Reporting.print_err (fst ann) "Non-exhaustive matching" ("Example: " ^ string_of_rp example) in let l = Parse_ast.Generated Parse_ast.Unknown in @@ -4678,7 +4718,7 @@ let rewrite_case (e,ann) = | (example::_) -> let _ = if !opt_coq_warn_nonexhaustive - then Reporting.print_err false false + then Reporting.print_err (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 @@ -4708,7 +4748,7 @@ let rewrite_fun rewriters (FD_aux (FD_function (r,t,e,fcls),f_ann)) = | (example::_) -> let _ = if !opt_coq_warn_nonexhaustive - then Reporting.print_err false false + then Reporting.print_err (fst f_ann) "Non-exhaustive matching" ("Example: " ^ string_of_rp example) in let l = Parse_ast.Generated Parse_ast.Unknown in @@ -4719,7 +4759,6 @@ let rewrite_fun rewriters (FD_aux (FD_function (r,t,e,fcls),f_ann)) = let default = FCL_aux (FCL_Funcl (id,Pat_aux (Pat_exp (p,b),(l,empty_tannot))),fcl_ann) in FD_aux (FD_function (r,t,e,fcls'@[default]),f_ann) - let rewrite = let alg = { id_exp_alg with e_aux = rewrite_case } in @@ -5123,7 +5162,6 @@ let rewrite_defs_c = [ ("simple_assignments", rewrite_simple_assignments); ("remove_vector_concat", rewrite_defs_remove_vector_concat); ("remove_bitvector_pats", rewrite_defs_remove_bitvector_pats); - ("guarded_pats", rewrite_defs_guarded_pats); ("exp_lift_assign", rewrite_defs_exp_lift_assign); ("constraint", rewrite_constraint); ("trivial_sizeof", rewrite_trivial_sizeof); @@ -5160,7 +5198,7 @@ let rewrite_check_annot = else ()); exp with - Type_error (l, err) -> raise (Reporting.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 59190d15..8d095451 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -54,7 +54,6 @@ module Big_int = Nat_big_num let lib = ref ([] : string list) let opt_file_out : string option ref = ref None -let opt_interactive = ref false let opt_interactive_script : string option ref = ref None let opt_print_version = ref false let opt_print_initial_env = ref false @@ -79,10 +78,10 @@ let options = Arg.align ([ Arg.String (fun f -> opt_file_out := Some f), "<prefix> select output filename prefix"); ( "-i", - Arg.Tuple [Arg.Set opt_interactive; Arg.Set Initial_check.opt_undefined_gen], + Arg.Tuple [Arg.Set Interactive.opt_interactive; Arg.Set Initial_check.opt_undefined_gen], " start interactive interpreter"); ( "-is", - Arg.Tuple [Arg.Set opt_interactive; Arg.Set Initial_check.opt_undefined_gen; + Arg.Tuple [Arg.Set Interactive.opt_interactive; Arg.Set Initial_check.opt_undefined_gen; Arg.String (fun s -> opt_interactive_script := Some s)], "<filename> start interactive interpreter and execute commands in script"); ( "-iout", @@ -225,8 +224,8 @@ let options = Arg.align ([ Arg.Set Rewrites.opt_dmono_continue, " continue despite monomorphisation errors"); ( "-verbose", - Arg.Set opt_print_verbose, - " (debug) pretty-print the input to standard output"); + Arg.Int (fun verbosity -> Util.opt_verbosity := verbosity), + " produce verbose output"); ( "-ddump_tc_ast", Arg.Set opt_ddump_tc_ast, " (debug) dump the typechecked ast to stdout"); @@ -239,6 +238,9 @@ let options = Arg.align ([ ( "-dtc_verbose", Arg.Int (fun verbosity -> Type_check.opt_tc_debug := verbosity), "<verbosity> (debug) verbose typechecker output: 0 is silent"); + ( "-dsmt_verbose", + Arg.Set Constraint.opt_smt_verbose, + " (debug) print SMTLIB constraints sent to Z3"); ( "-dno_cast", Arg.Set opt_dno_cast, " (debug) typecheck without any implicit casting"); @@ -259,10 +261,22 @@ let options = Arg.align ([ " print version"); ] ) +let version = + let open Manifest in + let default = Printf.sprintf "Sail %s @ %s" branch commit in + (* version is parsed from the output of git describe *) + match String.split_on_char '-' version with + | [vnum; _; _] -> + (try + let vnum = float_of_string vnum +. 2.0 in + Printf.sprintf "Sail %.1f (%s @ %s)" vnum branch commit + with + | Failure _ -> default) + | _ -> default + let usage_msg = - ("Sail 2.0\n" - ^ "usage: sail <options> <file1.sail> ... <fileN.sail>\n" - ) + version + ^ "\nusage: sail <options> <file1.sail> ... <fileN.sail>\n" let _ = Arg.parse options @@ -270,9 +284,6 @@ let _ = opt_file_arguments := (!opt_file_arguments) @ [s]) usage_msg -let interactive_ast = ref (Ast.Defs []) -let interactive_env = ref Type_check.initial_env - let load_files type_envs files = if !opt_memo_z3 then Constraint.load_digests () else (); @@ -301,9 +312,22 @@ let load_files type_envs files = (out_name, ast, type_envs) +let print_version () = + let open Manifest in + let default = Printf.sprintf "Sail %s @ %s" branch commit in + (* version is the output of git describe *) + match String.split_on_char '-' version with + | [vnum; _; _] -> + (try + let vnum = float_of_string vnum +. 2.0 in + Printf.printf "Sail %.1f (%s @ %s)\n" vnum branch commit + with + | Failure _ -> print_endline default) + | _ -> print_endline default + let main() = if !opt_print_version - then Printf.printf "Sail 2.0\n" + then print_version () else let out_name, ast, type_envs = load_files Type_check.initial_env !opt_file_arguments in Util.opt_warnings := false; (* Don't show warnings during re-writing for now *) @@ -331,11 +355,10 @@ let main() = | _ -> Some (Ocaml_backend.orig_types_for_ocaml_generator ast, !opt_ocaml_generators) in - (*let _ = Printf.eprintf "Type checked, next to pretty print" in*) begin - (if !(opt_interactive) + (if !(Interactive.opt_interactive) then - (interactive_ast := Process_file.rewrite_ast_interpreter ast; interactive_env := type_envs) + (Interactive.ast := Process_file.rewrite_ast_interpreter ast; Interactive.env := type_envs) else ()); (if !(opt_sanity) then @@ -398,7 +421,10 @@ let main() = let _ = try begin - try ignore(main ()) - with Failure(s) -> raise (Reporting.err_general Parse_ast.Unknown ("Failure "^s)) + try ignore (main ()) + with Failure s -> raise (Reporting.err_general Parse_ast.Unknown ("Failure " ^ s)) end - with Reporting.Fatal_error e -> Reporting.report_error e + with Reporting.Fatal_error e -> + Reporting.print_error e; + Interactive.opt_suppress_banner := true; + if !Interactive.opt_interactive then () else exit 1 diff --git a/src/scattered.ml b/src/scattered.ml index be304dc8..de286e3f 100644 --- a/src/scattered.ml +++ b/src/scattered.ml @@ -126,9 +126,9 @@ let rec descatter' funcls mapcls = function (* 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 -> + | DEF_scattered (SD_aux (SD_variant (id, 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))) + DEF_type (TD_aux (TD_variant (id, 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... *) diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index 398f20b5..634b34b6 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -51,7 +51,6 @@ open Ast open Util open Ast_util -open Extra_pervasives module Nameset = Set.Make(String) @@ -95,7 +94,7 @@ let rec free_type_names_t consider_var (Typ_aux (t, l)) = match t with | 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 (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" + | Typ_internal_unknown -> Reporting.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 | Some t -> free_type_names_t consider_var t @@ -130,7 +129,7 @@ let rec fv_of_typ consider_var bound used (Typ_aux (t,l)) : Nameset.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" + | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" 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 @@ -307,9 +306,6 @@ let typ_variants consider_var bound tunions = tunions (bound,mt) -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 @@ -317,14 +313,14 @@ let fv_of_abbrev consider_var bound used typq typ_arg = let fv_of_type_def consider_var (TD_aux(t,_)) = match t with | 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,_) -> + | 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 binds, List.fold_right (fun (t,_) n -> fv_of_typ consider_var bounds n t) tids mt - | TD_variant(id,_,typq,tunions,_) -> + | TD_variant(id,typq,tunions,_) -> let bindings = Nameset.add (string_of_id id) (if consider_var then typq_bindings typq else mt) in typ_variants consider_var bindings tunions - | TD_enum(id,_,ids,_) -> + | TD_enum(id,ids,_) -> Nameset.of_list (List.map string_of_id (id::ids)),mt | TD_bitfield(id,typ,_) -> init_env (string_of_id id), Nameset.empty (* fv_of_typ consider_var mt typ *) @@ -438,7 +434,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_variant (id,_,_) -> + | SD_variant (id,_) -> let name = string_of_id id in let uses = if consider_scatter_as_one @@ -475,7 +471,7 @@ let fv_of_rd consider_var (DEC_aux (d, annot)) = let open Type_check in let env = env_of_annot annot in match d with - | DEC_reg(t, id) -> + | 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') @@ -489,7 +485,6 @@ let fv_of_rd consider_var (DEC_aux (d, annot)) = 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 | DEF_type tdef -> fv_of_type_def consider_var tdef | DEF_fundef fdef -> fv_of_fun consider_var fdef | DEF_mapdef mdef -> mt,mt (* fv_of_map consider_var mdef *) diff --git a/src/specialize.ml b/src/specialize.ml index 1ba57bd0..e7f686d8 100644 --- a/src/specialize.ml +++ b/src/specialize.ml @@ -51,7 +51,6 @@ open Ast open Ast_util open Rewriter -open Extra_pervasives let is_typ_ord_uvar = function | A_aux (A_typ _, _) -> true @@ -68,7 +67,7 @@ let rec nexp_simp_typ (Typ_aux (typ_aux, l)) = | Typ_fn (arg_typs, ret_typ, effect) -> Typ_fn (List.map nexp_simp_typ arg_typs, nexp_simp_typ ret_typ, effect) | Typ_bidir (t1, t2) -> Typ_bidir (nexp_simp_typ t1, nexp_simp_typ t2) - | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" + | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" in Typ_aux (typ_aux, l) and nexp_simp_typ_arg (A_aux (typ_arg_aux, l)) = @@ -172,7 +171,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 -> + | 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 (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) @@ -253,12 +252,13 @@ let rec typ_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) = | 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) - | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" + | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" and typ_arg_frees ?exs:(exs=KidSet.empty) (A_aux (typ_arg_aux, l)) = match typ_arg_aux with | A_nexp n -> KidSet.empty | A_typ typ -> typ_frees ~exs:exs typ | A_order ord -> KidSet.empty + | A_bool _ -> KidSet.empty let rec typ_int_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) = match typ_aux with @@ -270,12 +270,13 @@ let rec typ_int_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) = | 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) - | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown" + | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" and typ_arg_int_frees ?exs:(exs=KidSet.empty) (A_aux (typ_arg_aux, l)) = match typ_arg_aux with | A_nexp n -> KidSet.diff (tyvars_of_nexp n) exs | A_typ typ -> typ_int_frees ~exs:exs typ | A_order ord -> KidSet.empty + | A_bool _ -> KidSet.empty let specialize_id_valspec instantiations id ast = match split_defs (is_valspec id) ast with diff --git a/src/state.ml b/src/state.ml index c9a47b06..fb065440 100644 --- a/src/state.ml +++ b/src/state.ml @@ -69,7 +69,7 @@ let find_registers defs = List.fold_left (fun acc def -> match def with - | DEF_reg_dec (DEC_aux(DEC_reg (typ, id), (_, tannot))) -> + | DEF_reg_dec (DEC_aux(DEC_reg (_, _, typ, id), (_, tannot))) -> let env = match destruct_tannot tannot with | Some (env, _, _) -> env | _ -> Env.empty @@ -136,10 +136,10 @@ let generate_initial_regstate defs = List.fold_left2 typ_subst_quant_item typ (quant_items tq) args in let add_typ_init_val vals = function - | TD_enum (id, _, id1 :: _, _) -> + | TD_enum (id, id1 :: _, _) -> (* Choose the first value of an enumeration type as default *) Bindings.add id (fun _ -> string_of_id id1) vals - | TD_variant (id, _, tq, (Tu_aux (Tu_ty_id (typ1, id1), _)) :: _, _) -> + | TD_variant (id, tq, (Tu_aux (Tu_ty_id (typ1, id1), _)) :: _, _) -> (* Choose the first variant of a union type as default *) let init_val args = let typ1 = typ_subst_typquant tq args typ1 in @@ -149,7 +149,7 @@ let generate_initial_regstate defs = | 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, _) -> + | TD_record (id, tq, fields, _) -> let init_val args = let init_field (typ, id) = let typ = typ_subst_typquant tq args typ in diff --git a/src/type_check.ml b/src/type_check.ml index ee80296f..9ece1e25 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -52,7 +52,6 @@ open Ast open Util open Ast_util open Lazy -open Extra_pervasives module Big_int = Nat_big_num @@ -96,13 +95,42 @@ 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;; - -let typ_error l m = raise (Type_error (l, Err_other m)) - -let typ_raise l err = raise (Type_error (l, err)) + | Err_because of type_error * Parse_ast.l * type_error + +type env = + { top_val_specs : (typquant * typ) Bindings.t; + defined_val_specs : IdSet.t; + locals : (mut * typ) Bindings.t; + union_ids : (typquant * typ) Bindings.t; + registers : (effect * effect * typ) Bindings.t; + variants : (typquant * type_union list) Bindings.t; + mappings : (typquant * typ * typ) Bindings.t; + typ_vars : (Ast.l * kind_aux) KBindings.t; + shadow_vars : int KBindings.t; + typ_synonyms : (env -> typ_arg list -> typ_arg) Bindings.t; + num_defs : nexp Bindings.t; + overloads : (id list) Bindings.t; + flow : (typ -> typ) Bindings.t; + enums : IdSet.t Bindings.t; + records : (typquant * (typ * id) list) Bindings.t; + accessors : (typquant * typ) Bindings.t; + externs : (string -> string option) Bindings.t; + casts : id list; + allow_casts : bool; + allow_bindings : bool; + constraints : n_constraint list; + default_order : order option; + ret_typ : typ option; + poly_undefineds : bool; + prove : env -> n_constraint -> bool; + allow_unknowns : bool; + } + +exception Type_error of env * l * type_error;; + +let typ_error env l m = raise (Type_error (env, l, Err_other m)) + +let typ_raise env l err = raise (Type_error (env, l, err)) let deinfix = function | Id_aux (Id v, l) -> Id_aux (DeIid v, l) @@ -139,6 +167,11 @@ let is_atom (Typ_aux (typ_aux, _)) = | Typ_app (f, [_]) when string_of_id f = "atom" -> true | _ -> false +let is_atom_bool (Typ_aux (typ_aux, _)) = + match typ_aux with + | Typ_app (f, [_]) when string_of_id f = "atom_bool" -> true + | _ -> false + let rec strip_id = function | Id_aux (Id x, _) -> Id_aux (Id x, Parse_ast.Unknown) | Id_aux (DeIid x, _) -> Id_aux (DeIid x, Parse_ast.Unknown) @@ -215,19 +248,33 @@ and strip_kinded_id_aux = function and strip_kind = function | K_aux (k_aux, _) -> K_aux (k_aux, Parse_ast.Unknown) +let rec name_pat (P_aux (aux, _)) = + match aux with + | P_id id | P_as (_, id) -> Some ("_" ^ string_of_id id) + | P_typ (_, pat) | P_var (pat, _) -> name_pat pat + | _ -> None + let ex_counter = ref 0 -let fresh_existential ?name:(n="") k = - let fresh = Kid_aux (Var ("'ex" ^ string_of_int !ex_counter ^ "#" ^ n), Parse_ast.Unknown) in +let fresh_existential k = + let fresh = Kid_aux (Var ("'ex" ^ string_of_int !ex_counter ^ "#"), Parse_ast.Unknown) in incr ex_counter; mk_kopt k fresh -let destruct_exist_plain typ = +let named_existential k = function + | Some n -> mk_kopt k (mk_kid n) + | None -> fresh_existential k + +let destruct_exist_plain ?name:(name=None) typ = match typ with + | Typ_aux (Typ_exist ([kopt], nc, typ), _) -> + let kid, fresh = kopt_kid kopt, named_existential (unaux_kind (kopt_kind kopt)) name in + let nc = constraint_subst kid (arg_kopt fresh) nc in + let typ = typ_subst kid (arg_kopt fresh) typ in + Some ([fresh], nc, typ) | Typ_aux (Typ_exist (kopts, nc, typ), _) -> + let add_num i = match name with Some n -> Some (n ^ string_of_int i) | None -> None in 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 + List.mapi (fun i kopt -> (kopt_kid kopt, named_existential (unaux_kind (kopt_kind kopt)) (add_num i))) 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 @@ -242,27 +289,36 @@ let destruct_exist_plain typ = - int => ['n], true, 'n (where x is fresh) - atom('n) => [], true, 'n **) -let destruct_numeric typ = - match destruct_exist_plain typ, typ with +let destruct_numeric ?name:(name=None) typ = + match destruct_exist_plain ~name:name 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" -> 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 = kopt_kid (fresh_existential K_int) in + let kid = kopt_kid (named_existential K_int name) 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 = kopt_kid (fresh_existential K_int) in + let kid = kopt_kid (named_existential K_int name) 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 = kopt_kid (fresh_existential K_int) in + let kid = kopt_kid (named_existential K_int name) in Some ([kid], nc_true, nvar kid) | _, _ -> None -let destruct_exist typ = - match destruct_numeric typ with +let destruct_boolean ?name:(name=None) = function + | Typ_aux (Typ_id (Id_aux (Id "bool", _)), _) -> + let kid = kopt_kid (fresh_existential K_bool) in + Some (kid, nc_var kid) + | _ -> None + +let destruct_exist ?name:(name=None) typ = + match destruct_numeric ~name:name typ with | Some (kids, nc, nexp) -> Some (List.map (mk_kopt K_int) kids, nc, atom_typ nexp) - | None -> destruct_exist_plain typ + | None -> + match destruct_boolean ~name:name typ with + | Some (kid, nc) -> Some ([mk_kopt K_bool kid], nc_true, atom_bool_typ nc) + | None -> destruct_exist_plain ~name:name typ let adding = Util.("Adding " |> darkgray |> clear) @@ -271,7 +327,7 @@ let adding = Util.("Adding " |> darkgray |> clear) (**************************************************************************) module Env : sig - type t + type t = env val add_val_spec : id -> typquant * typ -> t -> t val update_val_spec : id -> typquant * typ -> t -> t val define_val_spec : id -> t -> t @@ -361,33 +417,7 @@ module Env : sig val builtin_typs : typquant Bindings.t end = struct - type t = - { top_val_specs : (typquant * typ) Bindings.t; - defined_val_specs : IdSet.t; - locals : (mut * typ) Bindings.t; - union_ids : (typquant * typ) Bindings.t; - registers : (effect * effect * typ) Bindings.t; - 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_arg) Bindings.t; - num_defs : nexp Bindings.t; - overloads : (id list) Bindings.t; - flow : (typ -> typ) Bindings.t; - enums : IdSet.t Bindings.t; - records : (typquant * (typ * id) list) Bindings.t; - accessors : (typquant * typ) Bindings.t; - externs : (string -> string option) Bindings.t; - casts : id list; - allow_casts : bool; - allow_bindings : bool; - constraints : n_constraint list; - default_order : order option; - ret_typ : typ option; - poly_undefineds : bool; - prove : t -> n_constraint -> bool; - allow_unknowns : bool; - } + type t = env let empty = { top_val_specs = Bindings.empty; @@ -398,6 +428,7 @@ end = struct variants = Bindings.empty; mappings = Bindings.empty; typ_vars = KBindings.empty; + shadow_vars = KBindings.empty; typ_synonyms = Bindings.empty; num_defs = Bindings.empty; overloads = Bindings.empty; @@ -424,11 +455,11 @@ end = struct let get_typ_var kid env = try snd (KBindings.find kid env.typ_vars) with - | Not_found -> typ_error (kid_loc kid) ("No type variable " ^ string_of_kid kid) + | Not_found -> typ_error env (kid_loc kid) ("No type variable " ^ string_of_kid kid) let get_typ_var_loc kid env = try fst (KBindings.find kid env.typ_vars) with - | Not_found -> typ_error (kid_loc kid) ("No type variable " ^ string_of_kid kid) + | Not_found -> typ_error env (kid_loc kid) ("No type variable " ^ string_of_kid kid) let get_typ_vars env = KBindings.map snd env.typ_vars let get_typ_var_locs env = KBindings.map fst env.typ_vars @@ -489,9 +520,9 @@ end = struct else if Bindings.mem id env.enums then mk_typquant [] else if Bindings.mem id env.typ_synonyms then - typ_error (id_loc id) ("Cannot infer kind of type synonym " ^ string_of_id id) + typ_error env (id_loc id) ("Cannot infer kind of type synonym " ^ string_of_id id) else - typ_error (id_loc id) ("Cannot infer kind of " ^ string_of_id id) + typ_error env (id_loc id) ("Cannot infer kind of " ^ string_of_id id) let check_args_typquant id env args typq = let kopts, ncs = quant_split typq in @@ -506,13 +537,13 @@ end = struct | 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) + | _, A_aux (_, l) :: _ -> typ_error env l ("Error when processing type quantifer arguments " ^ string_of_typquant typq) + | _, _ -> typ_error env Parse_ast.Unknown ("Error when processing type quantifer arguments " ^ string_of_typquant typq) in let ncs = subst_args kopts args in if List.for_all (env.prove env) ncs 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) + else typ_error env (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)); @@ -523,7 +554,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 - | arg -> typ_error l ("Expected Bool when expanding synonym " ^ string_of_id id ^ " got " ^ string_of_typ_arg arg) + | arg -> typ_error env 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 @@ -538,7 +569,7 @@ end = struct (try begin match Bindings.find id env.typ_synonyms env args with | A_aux (A_typ typ, _) -> expand_synonyms env typ - | _ -> typ_error l ("Expected Type when expanding synonym " ^ string_of_id id) + | _ -> typ_error env 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)) @@ -546,7 +577,7 @@ end = struct (try begin match Bindings.find id env.typ_synonyms env [] with | A_aux (A_typ typ, _) -> expand_synonyms env typ - | _ -> typ_error l ("Expected Type when expanding synonym " ^ string_of_id id) + | _ -> typ_error env l ("Expected Type when expanding synonym " ^ string_of_id id) end with | Not_found -> Typ_aux (Typ_id id, l)) @@ -614,32 +645,32 @@ end = struct | Typ_id id when bound_typ_id env id -> let typq = infer_kind env id in if quant_kopts typq != [] - then typ_error l ("Type constructor " ^ string_of_id id ^ " expected " ^ string_of_typquant typq) + then typ_error env l ("Type constructor " ^ string_of_id id ^ " expected " ^ string_of_typquant typq) else () - | Typ_id id -> typ_error l ("Undefined type " ^ string_of_id id) + | Typ_id id -> typ_error env l ("Undefined type " ^ string_of_id id) | Typ_var kid -> begin match KBindings.find kid env.typ_vars with | (_, K_type) -> () - | (_, k) -> typ_error l ("Kind identifier " ^ string_of_kid kid ^ " in type " ^ string_of_typ typ + | (_, k) -> typ_error env l ("Kind identifier " ^ string_of_kid kid ^ " in type " ^ string_of_typ typ ^ " 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) + typ_error env l ("Unbound kind identifier " ^ string_of_kid kid ^ " in type " ^ string_of_typ typ) end | Typ_fn (arg_typs, ret_typ, effs) -> List.iter (wf_typ ~exs:exs env) arg_typs; wf_typ ~exs:exs env ret_typ | Typ_bidir (typ1, typ2) when strip_typ typ1 = strip_typ typ2 -> - typ_error l "Bidirectional types cannot be the same on both sides" + typ_error env l "Bidirectional types cannot be the same on both sides" | Typ_bidir (typ1, typ2) -> wf_typ ~exs:exs env typ1; wf_typ ~exs:exs env typ2 | Typ_tup typs -> List.iter (wf_typ ~exs:exs env) typs | Typ_app (id, args) when bound_typ_id env id -> List.iter (wf_typ_arg ~exs:exs env) args; 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_app (id, _) -> typ_error env l ("Undefined type " ^ string_of_id id) + | Typ_exist ([], _, _) -> typ_error env l ("Existential must have some type variables") | 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" + | Typ_exist (_, _, _) -> typ_error env l ("Nested existentials are not allowed") + | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" and wf_typ_arg ?exs:(exs=KidSet.empty) env (A_aux (typ_arg_aux, _)) = match typ_arg_aux with | A_nexp nexp -> wf_nexp ~exs:exs env nexp @@ -652,12 +683,11 @@ end = struct | Nexp_id _ -> () | Nexp_var kid when KidSet.mem kid exs -> () | Nexp_var kid -> - begin - match get_typ_var kid env with - | K_int -> () - | kind -> typ_error l ("Constraint is badly formed, " - ^ string_of_kid kid ^ " has kind " - ^ string_of_kind_aux kind ^ " but should have kind Int") + begin match get_typ_var kid env with + | K_int -> () + | kind -> typ_error env l ("Constraint is badly formed, " + ^ string_of_kid kid ^ " has kind " + ^ string_of_kind_aux kind ^ " but should have kind Int") end | Nexp_constant _ -> () | Nexp_app (id, nexps) -> @@ -670,12 +700,11 @@ end = struct and wf_order env (Ord_aux (ord_aux, l) as ord) = match ord_aux with | Ord_var kid -> - begin - match get_typ_var kid env with - | K_order -> () - | kind -> typ_error l ("Order is badly formed, " - ^ string_of_kid kid ^ " has kind " - ^ string_of_kind_aux kind ^ " but should have kind Order") + begin match get_typ_var kid env with + | K_order -> () + | kind -> typ_error env l ("Order is badly formed, " + ^ string_of_kid kid ^ " has kind " + ^ 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) = @@ -689,7 +718,7 @@ end = struct | NC_set (kid, _) -> begin match get_typ_var kid env with | K_int -> () - | kind -> typ_error l ("Set constraint is badly formed, " + | kind -> typ_error env l ("Set constraint is badly formed, " ^ string_of_kid kid ^ " has kind " ^ string_of_kind_aux kind ^ " but should have kind Int") end @@ -700,8 +729,7 @@ end = struct | 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 " + | kind -> typ_error env l (string_of_kid kid ^ " has kind " ^ string_of_kind_aux kind ^ " but should have kind Bool") end | NC_true | NC_false -> () @@ -727,7 +755,7 @@ end = struct try Bindings.find id env.top_val_specs with - | Not_found -> typ_error (id_loc id) ("No val spec found for " ^ string_of_id id) + | Not_found -> typ_error env (id_loc id) ("No val spec found for " ^ string_of_id id) let get_val_spec id env = try @@ -737,7 +765,7 @@ end = struct typ_debug (lazy ("get_val_spec: freshened to " ^ string_of_bind bind')); bind' with - | Not_found -> typ_error (id_loc id) ("No val spec found for " ^ string_of_id id) + | Not_found -> typ_error env (id_loc id) ("No val spec found for " ^ string_of_id id) let add_union_id id bind env = typ_print (lazy (adding ^ "union identifier " ^ string_of_id id ^ " : " ^ string_of_bind bind)); @@ -748,7 +776,7 @@ end = struct 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) + | Not_found -> typ_error env (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 @@ -776,7 +804,7 @@ end = struct 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" + | _ -> typ_error env (id_loc id) "val definition must have a mapping or function type" end and add_val_spec id (bind_typq, bind_typ) env = @@ -789,7 +817,7 @@ end = struct let existing_cmp = (strip_typq existing_typq, strip_typ existing_typ) in let bind_cmp = (strip_typq bind_typq, strip_typ bind_typ) in if existing_cmp <> bind_cmp then - 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)) + typ_error env (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 *) @@ -823,7 +851,7 @@ end = struct let define_val_spec id env = if IdSet.mem id env.defined_val_specs - then typ_error (id_loc id) ("Function " ^ string_of_id id ^ " has already been declared") + then typ_error env (id_loc id) ("Function " ^ string_of_id id ^ " has already been declared") else { env with defined_val_specs = IdSet.add id env.defined_val_specs } let is_union_constructor id env = @@ -848,7 +876,7 @@ end = struct let add_enum id ids env = if bound_typ_id env id - then typ_error (id_loc id) ("Cannot create enum " ^ string_of_id id ^ ", type name is already bound") + then typ_error env (id_loc id) ("Cannot create enum " ^ string_of_id id ^ ", type name is already bound") else begin typ_print (lazy (adding ^ "enum " ^ string_of_id id)); @@ -858,7 +886,7 @@ end = struct let get_enum id env = try IdSet.elements (Bindings.find id env.enums) with - | Not_found -> typ_error (id_loc id) ("Enumeration " ^ string_of_id id ^ " does not exist") + | Not_found -> typ_error env (id_loc id) ("Enumeration " ^ string_of_id id ^ " does not exist") let is_record id env = Bindings.mem id env.records @@ -866,7 +894,7 @@ end = struct let add_record id typq fields env = if bound_typ_id env id - then typ_error (id_loc id) ("Cannot create record " ^ string_of_id id ^ ", type name is already bound") + then typ_error env (id_loc id) ("Cannot create record " ^ string_of_id id ^ ", type name is already bound") else begin typ_print (lazy (adding ^ "record " ^ string_of_id id)); @@ -897,14 +925,14 @@ end = struct let freshen_bind bind = List.fold_left (fun bind (kid, _) -> freshen_kid env kid bind) bind (KBindings.bindings env.typ_vars) in try freshen_bind (Bindings.find (field_name rec_id id) env.accessors) with - | Not_found -> typ_error (id_loc id) ("No accessor found for " ^ string_of_id (field_name rec_id id)) + | Not_found -> typ_error env (id_loc id) ("No accessor found for " ^ string_of_id (field_name rec_id id)) let get_accessor rec_id id env = match get_accessor_fn rec_id id env with (* All accessors should have a single argument (the record itself) *) | (typq, Typ_aux (Typ_fn ([rec_typ], field_typ, effect), _)) -> (typq, rec_typ, field_typ, effect) - | _ -> typ_error (id_loc id) ("Accessor with non-function type found for " ^ string_of_id (field_name rec_id id)) + | _ -> typ_error env (id_loc id) ("Accessor with non-function type found for " ^ string_of_id (field_name rec_id id)) let is_mutable id env = try @@ -921,10 +949,10 @@ end = struct let add_local id mtyp env = begin - if not env.allow_bindings then typ_error (id_loc id) "Bindings are not allowed in this context" else (); + if not env.allow_bindings then typ_error env (id_loc id) "Bindings are not allowed in this context" else (); wf_typ env (snd mtyp); if Bindings.mem id env.top_val_specs then - typ_error (id_loc id) ("Local variable " ^ string_of_id id ^ " is already bound as a function name") + typ_error env (id_loc id) ("Local variable " ^ string_of_id id ^ " is already bound as a function name") else (); typ_print (lazy (adding ^ "local binding " ^ string_of_id id ^ " : " ^ string_of_mtyp mtyp)); { env with locals = Bindings.add id mtyp env.locals } @@ -941,12 +969,12 @@ end = struct 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") + | None -> typ_error env (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") + | None -> typ_error env (id_loc id) ("union " ^ string_of_id id ^ " not found") let get_flow id env = try Bindings.find id env.flow with | Not_found -> fun typ -> typ @@ -964,7 +992,7 @@ end = struct let get_register id env = try Bindings.find id env.registers with - | Not_found -> typ_error (id_loc id) ("No register binding found for " ^ string_of_id id) + | Not_found -> typ_error env (id_loc id) ("No register binding found for " ^ string_of_id id) let is_extern id env backend = try not (Bindings.find id env.externs backend = None) with @@ -978,16 +1006,16 @@ end = struct try match Bindings.find id env.externs backend with | Some ext -> ext - | None -> typ_error (id_loc id) ("No extern binding found for " ^ string_of_id id) + | None -> typ_error env (id_loc id) ("No extern binding found for " ^ string_of_id id) with - | Not_found -> typ_error (id_loc id) ("No extern binding found for " ^ string_of_id id) + | Not_found -> typ_error env (id_loc id) ("No extern binding found for " ^ string_of_id id) let get_casts env = env.casts let add_register id reff weff typ env = wf_typ env typ; if Bindings.mem id env.registers - then typ_error (id_loc id) ("Register " ^ string_of_id id ^ " is already bound") + then typ_error env (id_loc id) ("Register " ^ string_of_id id ^ " is already bound") else begin typ_print (lazy (adding ^ "register binding " ^ string_of_id id ^ " :: " ^ string_of_typ typ)); @@ -1014,18 +1042,26 @@ end = struct with | Not_found -> Unbound - 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_kinded_id kopt ^ " is already bound") - else - begin - 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 } + let add_typ_var l (KOpt_aux (KOpt_kind (K_aux (k, _), v), _)) env = + if KBindings.mem v env.typ_vars then begin + let n = match KBindings.find_opt v env.shadow_vars with Some n -> n | None -> 0 in + let s_l, s_k = KBindings.find v env.typ_vars in + let s_v = Kid_aux (Var (string_of_kid v ^ "#" ^ string_of_int n), l) in + typ_print (lazy (Printf.sprintf "%stype variable (shadowing %s) %s : %s" adding (string_of_kid s_v) (string_of_kid v) (string_of_kind_aux k))); + { env with + constraints = List.map (constraint_subst v (arg_kopt (mk_kopt s_k s_v))) env.constraints; + typ_vars = KBindings.add v (l, k) (KBindings.add s_v (s_l, s_k) env.typ_vars); + shadow_vars = KBindings.add v (n + 1) env.shadow_vars + } + end + else begin + typ_print (lazy (adding ^ "type variable " ^ string_of_kid v ^ " : " ^ string_of_kind_aux k)); + { env with typ_vars = KBindings.add v (l, k) env.typ_vars } end let add_num_def id nexp env = if Bindings.mem id env.num_defs - then typ_error (id_loc id) ("Num identifier " ^ string_of_id id ^ " is already bound") + then typ_error env (id_loc id) ("Num identifier " ^ string_of_id id ^ " is already bound") else begin typ_print (lazy (adding ^ "Num identifier " ^ string_of_id id ^ " : " ^ string_of_nexp nexp)); @@ -1034,13 +1070,13 @@ end = struct let get_num_def id env = try Bindings.find id env.num_defs with - | Not_found -> typ_raise (id_loc id) (Err_no_num_ident id) + | Not_found -> typ_raise env (id_loc id) (Err_no_num_ident id) let get_constraints env = env.constraints let add_constraint constr env = wf_constraint env constr; - let (NC_aux (nc_aux, l) as constr) = expand_constraint_synonyms env constr in + let (NC_aux (nc_aux, l) as constr) = constraint_simp (expand_constraint_synonyms env constr) in match nc_aux with | NC_true -> env | _ -> @@ -1064,7 +1100,7 @@ end = struct let add_typ_synonym id synonym env = if Bindings.mem id env.typ_synonyms - then typ_error (id_loc id) ("Type synonym " ^ string_of_id id ^ " already exists") + then typ_error env (id_loc id) ("Type synonym " ^ string_of_id id ^ " already exists") else begin typ_print (lazy (adding ^ "type synonym " ^ string_of_id id)); @@ -1075,13 +1111,13 @@ end = struct let get_default_order env = match env.default_order with - | None -> typ_error Parse_ast.Unknown ("No default order has been set") + | None -> typ_error env Parse_ast.Unknown ("No default order has been set") | Some ord -> ord let set_default_order o env = match env.default_order with | None -> { env with default_order = Some (Ord_aux (o, Parse_ast.Unknown)) } - | Some _ -> typ_error Parse_ast.Unknown ("Cannot change default order once already set") + | Some _ -> typ_error env Parse_ast.Unknown ("Cannot change default order once already set") let set_default_order_inc = set_default_order Ord_inc let set_default_order_dec = set_default_order Ord_dec @@ -1157,12 +1193,12 @@ let bind_numeric l typ env = match destruct_numeric (Env.expand_synonyms env typ) with | Some (kids, nc, nexp) -> 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") + | None -> typ_error env l ("Expected " ^ string_of_typ typ ^ " to be numeric") (** Pull an (potentially)-existentially qualified type into the global typing environment **) -let bind_existential l typ env = - match destruct_exist (Env.expand_synonyms env typ) with +let bind_existential l name typ env = + match destruct_exist ~name:name (Env.expand_synonyms env typ) with | Some (kids, nc, typ) -> typ, add_existential l kids nc env | None -> typ, env @@ -1195,7 +1231,7 @@ let rec is_typ_monomorphic (Typ_aux (typ, l)) = | Typ_fn (arg_typs, ret_typ, _) -> List.for_all is_typ_monomorphic arg_typs && is_typ_monomorphic ret_typ | 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" + | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" and is_typ_arg_monomorphic (A_aux (arg, _)) = match arg with | A_nexp _ -> true @@ -1207,10 +1243,55 @@ and is_typ_arg_monomorphic (A_aux (arg, _)) = (* 2. Subtyping and constraint solving *) (**************************************************************************) +type ('a, 'b) filter = + | Keep of 'a + | Remove of 'b + +let rec filter_keep = function + | Keep x :: xs -> x :: filter_keep xs + | Remove _ :: xs -> filter_keep xs + | [] -> [] + +let rec filter_remove = function + | Keep _ :: xs -> filter_remove xs + | Remove x :: xs -> x :: filter_remove xs + | [] -> [] + +let filter_split f g xs = + let xs = List.map f xs in + filter_keep xs, g (filter_remove xs) + let rec simp_typ (Typ_aux (typ_aux, l)) = Typ_aux (simp_typ_aux typ_aux, l) and simp_typ_aux = function | Typ_exist (kids1, nc1, Typ_aux (Typ_exist (kids2, nc2, typ), _)) -> - Typ_exist (kids1 @ kids2, nc_and nc1 nc2, typ) + simp_typ_aux (Typ_exist (kids1 @ kids2, nc_and nc1 nc2, typ)) + + (* This removes redundant boolean variables in existentials, such + that {('p: Bool) ('q:Bool) ('r: Bool), nc('r). bool('p & 'q & 'r)} + would become {('s:Bool) ('r: Bool), nc('r). bool('s & 'r)}, + wherein all the redundant boolean variables have been combined + into a single one. Making this simplification allows us to avoid + having to pass large numbers of pointless variables to Z3 if we + ever bind this existential. *) + | Typ_exist (vars, nc, Typ_aux (Typ_app (Id_aux (Id "atom_bool", _), [A_aux (A_bool b, _)]), _)) -> + let kids = KidSet.of_list (List.map kopt_kid vars) in + let constrained = tyvars_of_constraint nc in + let conjs = constraint_conj b in + let is_redundant = function + | NC_aux (NC_var v, _) when KidSet.mem v kids && not (KidSet.mem v constrained) -> Remove v + | nc -> Keep nc + in + let conjs, redundant = filter_split is_redundant KidSet.of_list conjs in + begin match conjs with + | [] -> Typ_id (mk_id "bool") + | conj :: conjs when KidSet.is_empty redundant -> + Typ_exist (vars, nc, atom_bool_typ (List.fold_left nc_and conj conjs)) + | conjs -> + let vars = List.filter (fun v -> not (KidSet.mem (kopt_kid v) redundant)) vars in + let var = fresh_existential K_bool in + Typ_exist (var :: vars, nc, atom_bool_typ (List.fold_left nc_and (nc_var (kopt_kid var)) conjs)) + end + | typ_aux -> typ_aux (* Here's how the constraint generation works for subtyping @@ -1243,7 +1324,7 @@ 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_aux (_, l) as 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 @@ -1255,19 +1336,16 @@ let solve env (Nexp_aux (_, l) as nexp) = 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 = +let debug_pos (file, line, _, _) = + "(" ^ file ^ "/" ^ string_of_int line ^ ") " + +let prove pos 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 - | _, _ -> false - in + let (NC_aux (nc_aux, _) as nc) = constraint_simp (Env.expand_constraint_synonyms env nc) in + if !Constraint.opt_smt_verbose then + prerr_endline (Util.("Prove " |> red |> clear) ^ debug_pos pos ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_n_constraint nc) + else (); match nc_aux with - | NC_equal (nexp1, nexp2) when compare_const Big_int.equal (nexp_simp nexp1) (nexp_simp nexp2) -> true - | NC_bounded_le (nexp1, nexp2) when compare_const Big_int.less_equal (nexp_simp nexp1) (nexp_simp nexp2) -> true - | NC_bounded_ge (nexp1, nexp2) when compare_const Big_int.greater_equal (nexp_simp nexp1) (nexp_simp nexp2) -> true | NC_true -> true | _ -> prove_z3 env nc @@ -1287,11 +1365,6 @@ let rec nexp_frees ?exs:(exs=KidSet.empty) (Nexp_aux (nexp, l)) = | Nexp_exp n -> nexp_frees ~exs:exs n | Nexp_neg n -> nexp_frees ~exs:exs n -let order_frees (Ord_aux (ord_aux, l)) = - match ord_aux with - | Ord_var kid -> KidSet.singleton kid - | _ -> KidSet.empty - let rec typ_nexps (Typ_aux (typ_aux, l)) = match typ_aux with | Typ_internal_unknown -> [] @@ -1310,24 +1383,6 @@ and typ_arg_nexps (A_aux (typ_arg_aux, l)) = | 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 - | Typ_internal_unknown -> KidSet.empty - | Typ_id v -> KidSet.empty - | Typ_var kid when KidSet.mem kid exs -> KidSet.empty - | 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 (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)) = - match typ_arg_aux with - | 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 | Nexp_id v1, Nexp_id v2 -> Id.compare v1 v2 = 0 @@ -1449,13 +1504,28 @@ 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 + | A_bool nc1, A_bool nc2 -> unify_constraint l env 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) = +and unify_constraint l env 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) + | NC_var v, NC_var v' when Kid.compare v v' = 0 -> KBindings.empty + | NC_and (nc1a, nc2a), NC_and (nc1b, nc2b) | NC_or (nc1a, nc2a), NC_or (nc1b, nc2b) -> + merge_uvars l (unify_constraint l env goals nc1a nc1b) (unify_constraint l env goals nc2a nc2b) + | NC_app (f1, args1), NC_app (f2, args2) when Id.compare f1 f2 = 0 && List.length args1 = List.length args2 -> + List.fold_left (merge_uvars l) KBindings.empty (List.map2 (unify_typ_arg l env goals) args1 args2) + | NC_equal (n1a, n2a), NC_equal (n1b, n2b) -> + merge_uvars l (unify_nexp l env goals n1a n1b) (unify_nexp l env goals n2a n2b) + | NC_not_equal (n1a, n2a), NC_equal (n1b, n2b) -> + merge_uvars l (unify_nexp l env goals n1a n1b) (unify_nexp l env goals n2a n2b) + | NC_bounded_ge (n1a, n2a), NC_equal (n1b, n2b) -> + merge_uvars l (unify_nexp l env goals n1a n1b) (unify_nexp l env goals n2a n2b) + | NC_bounded_le (n1a, n2a), NC_equal (n1b, n2b) -> + merge_uvars l (unify_nexp l env goals n1a n1b) (unify_nexp l env goals n2a n2b) + | NC_true, NC_true -> KBindings.empty + | NC_false, NC_false -> KBindings.empty | _, _ -> 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) = @@ -1472,7 +1542,7 @@ and unify_nexp l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (nexp_au if KidSet.is_empty (KidSet.inter (nexp_frees nexp1) goals) then begin - if prove env (NC_aux (NC_equal (nexp1, nexp2), Parse_ast.Unknown)) + if prove __POS__ env (NC_aux (NC_equal (nexp1, nexp2), Parse_ast.Unknown)) then KBindings.empty else unify_error l ("Nexp " ^ string_of_nexp nexp1 ^ " and " ^ string_of_nexp nexp2 ^ " are not equal") end @@ -1499,13 +1569,13 @@ 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) -> - (* f we have SMT operations div and mod, then we can use the + (* If 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 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 + let valid n c = prove __POS__ env (nc_eq (napp (mk_id "mod") [n; c]) (nint 0)) && prove __POS__ 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 @@ -1513,7 +1583,7 @@ and unify_nexp l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (nexp_au 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)) -> + | Nexp_times (n2a, n2b) when prove __POS__ env (NC_aux (NC_equal (n1a, n2a), Parse_ast.Unknown)) -> unify_nexp l env goals n1b n2b | Nexp_constant c2 -> begin @@ -1527,7 +1597,7 @@ and unify_nexp l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (nexp_au else if KidSet.is_empty (nexp_frees n1b) then begin match nexp_aux2 with - | Nexp_times (n2a, n2b) when prove env (NC_aux (NC_equal (n1b, n2b), Parse_ast.Unknown)) -> + | Nexp_times (n2a, n2b) when prove __POS__ env (NC_aux (NC_equal (n1b, n2b), Parse_ast.Unknown)) -> unify_nexp l env goals n1a n2a | _ -> unify_error l ("Cannot unify Int expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) end @@ -1539,7 +1609,7 @@ let unify l env goals typ1 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 if not (KidSet.is_empty (KidSet.inter goals (tyvars_of_typ typ2))) then - typ_error l ("Occurs check failed: " ^ string_of_typ typ2 ^ " contains " + typ_error env 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 @@ -1582,6 +1652,12 @@ let destruct_atom_kid env typ = when string_of_id f = "range" && Kid.compare kid1 kid2 = 0 -> Some kid1 | _ -> None +let destruct_atom_bool env typ = + match Env.expand_synonyms env typ with + | Typ_aux (Typ_app (f, [A_aux (A_bool nc, _)]), _) when string_of_id f = "atom_bool" -> + Some nc + | _ -> None + (* 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 @@ -1611,8 +1687,8 @@ let rec kid_order kind_map (Typ_aux (aux, l) as typ) = 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)) ([], 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" + | Typ_fn _ | Typ_bidir _ | Typ_exist _ -> typ_error Env.empty l ("Existential or function type cannot appear within existential type: " ^ string_of_typ typ) + | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" and kid_order_arg kind_map (A_aux (aux, l) as arg) = match aux with | A_typ typ -> kid_order kind_map typ @@ -1621,10 +1697,21 @@ and kid_order_arg kind_map (A_aux (aux, l) as arg) = | 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 -> + | NC_var kid | NC_set (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" + | NC_var _ | NC_set _ -> ([], kind_map) + | NC_true | NC_false -> ([], kind_map) + | NC_equal (n1, n2) | NC_not_equal (n1, n2) | NC_bounded_le (n1, n2) | NC_bounded_ge (n1, n2) -> + let ord1, kind_map = kid_order_nexp kind_map n1 in + let ord2, kind_map = kid_order_nexp kind_map n2 in + (ord1 @ ord2, kind_map) + | NC_app (_, args) -> + List.fold_left (fun (ord, kind_map) arg -> let ord', kind_map = kid_order_arg kind_map arg in (ord @ ord', kind_map)) + ([], kind_map) args + | NC_and (nc1, nc2) | NC_or (nc1, nc2) -> + let ord1, kind_map = kid_order_constraint kind_map nc1 in + let ord2, kind_map = kid_order_constraint kind_map nc2 in + (ord1 @ ord2, kind_map) let rec alpha_equivalent env typ1 typ2 = let counter = ref 0 in @@ -1726,34 +1813,16 @@ let rec subtyp l env typ1 typ2 = (* Special cases for two numeric (atom) types *) | Some (kids1, nc1, nexp1), Some ([], _, nexp2) -> 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)) + if prove __POS__ env (nc_eq nexp1 nexp2) then () else typ_raise env 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 (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 (); + if not (kids2 = []) then typ_error env 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)) + if prove __POS__ env nc2 then () + else typ_raise env l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env)) | _, _ -> - 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) -> - typ_debug (lazy "Subtype check with unification"); - let typ1 = canonicalize env typ1 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 - | 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_internal_unknown when Env.allow_unknowns env -> () @@ -1771,16 +1840,34 @@ let rec subtyp l env typ1 typ2 = | 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)) + | _, _ -> + 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) -> + typ_debug (lazy "Subtype check with unification"); + let typ1 = canonicalize env typ1 in + let env = add_typ_vars l kopts env in + let kids' = KidSet.elements (KidSet.diff (KidSet.of_list (List.map kopt_kid kopts)) (tyvars_of_typ typ2)) in + if not (kids' = []) then typ_error env 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 + | Unification_error (_, m) -> typ_error env 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 __POS__ env nc then () + else typ_raise env l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env)) + | None, None -> typ_raise env 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_nexp n1, A_nexp n2 when prove __POS__ 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 when nc_identical nc1 nc2 -> () - | _, _ -> typ_error l "Mismatched argument types in subtype check" + | A_bool nc1, A_bool nc2 when prove __POS__ env (nc_and (nc_or (nc_not nc1) nc2) (nc_or (nc_not nc2) nc1)) -> () + | _, _ -> typ_error env l "Mismatched argument types in subtype check" let typ_equality l env typ1 typ2 = subtyp l env typ1 typ2; subtyp l env typ2 typ1 @@ -1796,16 +1883,41 @@ let subtype_check env typ1 typ2 = (* The type checker produces a fully annoted AST - tannot is the type of these type annotations. The extra typ option is the expected type, that is, the type that the AST node was checked against, if there was one. *) -type tannot = ((Env.t * typ * effect) * typ option) option +type tannot' = { + env : Env.t; + typ : typ; + effect : effect; + expected : typ option; + instantiation : typ_arg KBindings.t option + } + +type tannot = tannot' option + +let mk_tannot env typ effect : tannot = + Some { + env = env; + typ = Env.expand_synonyms env typ; + effect = effect; + expected = None; + instantiation = None + } -let mk_tannot env typ effect : tannot = Some ((env, typ, effect), None) +let mk_expected_tannot env typ effect expected : tannot = + Some { + env = env; + typ = Env.expand_synonyms env typ; + effect = effect; + expected = expected; + instantiation = None + } let empty_tannot = None + let is_empty_tannot = function | None -> true | Some _ -> false -let destruct_tannot tannot = Util.option_map fst tannot +let destruct_tannot tannot = Util.option_map (fun t -> (t.env, t.typ, t.effect)) tannot let string_of_tannot tannot = match destruct_tannot tannot with @@ -1814,11 +1926,11 @@ let string_of_tannot tannot = | None -> "None" let replace_typ typ = function - | Some ((env, _, eff), _) -> Some ((env, typ, eff), None) + | Some t -> Some { t with typ = typ } | None -> None let replace_env env = function - | Some ((_, typ, eff), _) -> Some ((env, typ, eff), None) + | Some t -> Some { t with env = env } | None -> None let infer_lit env (L_aux (lit_aux, l) as lit) = @@ -1827,8 +1939,8 @@ let infer_lit env (L_aux (lit_aux, l) as lit) = | L_zero -> bit_typ | L_one -> bit_typ | L_num n -> atom_typ (nconstant n) - | L_true -> bool_typ - | L_false -> bool_typ + | L_true -> atom_bool_typ nc_true + | L_false -> atom_bool_typ nc_false | L_string _ -> string_typ | L_real _ -> real_typ | L_bin str -> @@ -1836,16 +1948,16 @@ let infer_lit env (L_aux (lit_aux, l) as lit) = match Env.get_default_order env with | Ord_aux (Ord_inc, _) | Ord_aux (Ord_dec, _) -> dvector_typ env (nint (String.length str)) (mk_typ (Typ_id (mk_id "bit"))) - | Ord_aux (Ord_var _, _) -> typ_error l default_order_error_string + | Ord_aux (Ord_var _, _) -> typ_error env l default_order_error_string end | L_hex str -> begin match Env.get_default_order env with | Ord_aux (Ord_inc, _) | Ord_aux (Ord_dec, _) -> dvector_typ env (nint (String.length str * 4)) (mk_typ (Typ_id (mk_id "bit"))) - | Ord_aux (Ord_var _, _) -> typ_error l default_order_error_string + | Ord_aux (Ord_var _, _) -> typ_error env l default_order_error_string end - | L_undef -> typ_error l "Cannot infer the type of undefined" + | L_undef -> typ_error env l "Cannot infer the type of undefined" let is_nat_kid kid = function | KOpt_aux (KOpt_kind (K_aux (K_int, _), kid'), _) -> Kid.compare kid kid' = 0 @@ -1895,23 +2007,19 @@ let destruct_vec_typ l env typ = 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) + | typ -> typ_error env l ("Expected vector type, got " ^ string_of_typ typ) in destruct_vec_typ' l (Env.expand_synonyms env typ) let env_of_annot (l, tannot) = match tannot with - | Some ((env, _, _),_) -> env + | Some t -> t.env | 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.err_unreachable l __POS__ "no type annotation") - -let env_of_annot (l, tannot) = match tannot with - | Some ((env, _, _), _) -> env + | Some t -> t.typ | None -> raise (Reporting.err_unreachable l __POS__ "no type annotation") let typ_of (E_aux (_, (l, tannot))) = typ_of_annot (l, tannot) @@ -1939,7 +2047,7 @@ let lexp_typ_of (LEXP_aux (_, (l, tannot))) = typ_of_annot (l, tannot) 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 + | Some t -> t.expected | None -> raise (Reporting.err_unreachable l __POS__ "no type annotation") (* Flow typing *) @@ -1956,7 +2064,7 @@ let to_simple_numeric l kids nc (Nexp_aux (aux, _) as n) = | _, [] -> Equal n | _ -> - typ_error l "Numeric type is non-simple" + typ_error Env.empty l "Numeric type is non-simple" let union_simple_numeric ex1 ex2 = match ex1, ex2 with @@ -2055,7 +2163,7 @@ let rec add_constraints constrs env = let solve_quant env = function | QI_aux (QI_id _, _) -> false - | QI_aux (QI_const nc, _) -> prove env nc + | QI_aux (QI_const nc, _) -> prove __POS__ env nc (* When doing implicit type coercion, for performance reasons we want to filter out the possible casts to only those that could @@ -2077,6 +2185,8 @@ let rec match_typ env typ1 typ2 = | Typ_id v, Typ_app (f, _) when string_of_id v = "int" && string_of_id f = "atom" -> true | Typ_id v, Typ_app (f, _) when string_of_id v = "nat" && string_of_id f = "range" -> true | Typ_id v, Typ_app (f, _) when string_of_id v = "int" && string_of_id f = "range" -> true + | Typ_id v, Typ_app (f, _) when string_of_id v = "bool" && string_of_id f = "atom_bool" -> true + | Typ_app (f, _), Typ_id v when string_of_id v = "bool" && string_of_id f = "atom_bool" -> true | Typ_app (f1, _), Typ_app (f2, _) when string_of_id f1 = "range" && string_of_id f2 = "atom" -> true | Typ_app (f1, _), Typ_app (f2, _) when string_of_id f1 = "atom" && string_of_id f2 = "range" -> true | Typ_app (f1, _), Typ_app (f2, _) when Id.compare f1 f2 = 0 -> true @@ -2107,7 +2217,7 @@ let crule r env exp typ = Env.wf_typ env (typ_of checked_exp); decr depth; checked_exp with - | Type_error (l, err) -> decr depth; typ_raise l err + | Type_error (env, l, err) -> decr depth; typ_raise env l err let irule r env exp = incr depth; @@ -2118,7 +2228,7 @@ let irule r env exp = decr depth; inferred_exp with - | Type_error (l, err) -> decr depth; typ_raise l err + | Type_error (env, l, err) -> decr depth; typ_raise env l err (* This function adds useful assertion messages to asserts missing them *) @@ -2144,47 +2254,15 @@ let fresh_var = mk_id ("v#" ^ string_of_int n) let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ_aux, _) as typ) : tannot exp = - let annot_exp_effect exp typ' eff = E_aux (exp, (l, Some ((env, Env.expand_synonyms env typ', eff),Some typ))) in + let annot_exp_effect exp typ' eff = E_aux (exp, (l, mk_expected_tannot env typ' eff (Some typ))) in let add_effect exp eff = match exp with - | (E_aux (exp, (l, Some ((env, typ, _), otyp)))) -> E_aux (exp, (l, Some ((env, typ, eff),otyp))) + | E_aux (exp, (l, Some tannot)) -> E_aux (exp, (l, Some { tannot with effect = eff })) | _ -> failwith "Tried to add effect to unannoted expression" in let annot_exp exp typ = annot_exp_effect exp typ no_effect in match (exp_aux, typ_aux) with | E_block exps, _ -> - begin - 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 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) -> - let texp, env = bind_assignment env lexp bind in - texp :: check_block l env exps typ - | ((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 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")); - Env.add_constraint nc env - | None -> env - 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_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 - texp :: check_block l env exps typ - in - annot_exp (E_block (check_block l env exps typ)) typ - end + annot_exp (E_block (check_block l env exps (Some typ))) typ | E_case (exp, cases), _ -> Pattern_completeness.check l (Env.pattern_completeness_ctx env) cases; let inferred_exp = irule infer_exp env exp in @@ -2200,7 +2278,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ let checked_xs = crule check_exp env xs typ in let checked_x = crule check_exp env x elem_typ in annot_exp (E_cons (checked_x, checked_xs)) typ - | None -> typ_error l ("Cons " ^ string_of_exp exp ^ " must have list type, got " ^ string_of_typ typ) + | None -> typ_error env l ("Cons " ^ string_of_exp exp ^ " must have list type, got " ^ string_of_typ typ) end | E_list xs, _ -> begin @@ -2208,7 +2286,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ | Some elem_typ -> let checked_xs = List.map (fun x -> crule check_exp env x elem_typ) xs in 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) + | None -> typ_error env l ("List " ^ string_of_exp exp ^ " must have list type, got " ^ string_of_typ typ) end | E_record_update (exp, fexps), _ -> (* TODO: this could also infer exp - also fix code duplication with E_record below *) @@ -2216,11 +2294,11 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ 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 -> rectyp_id - | _ -> typ_error l ("The type " ^ string_of_typ typ ^ " is not a record") + | _ -> typ_error env l ("The type " ^ string_of_typ typ ^ " is not a record") 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 (tyvars_of_typ rectyp_q) rectyp_q typ 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 env 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)) @@ -2231,11 +2309,11 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ 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 -> rectyp_id - | _ -> typ_error l ("The type " ^ string_of_typ typ ^ " is not a record") + | _ -> typ_error env l ("The type " ^ string_of_typ typ ^ " is not a record") 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 (tyvars_of_typ rectyp_q) rectyp_q typ 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 env 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)) @@ -2256,16 +2334,25 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ end | E_app_infix (x, op, y), _ -> check_exp env (E_aux (E_app (deinfix op, [x; y]), (l, ()))) typ - | E_app (f, [E_aux (E_constraint nc, _)]), _ when Id.compare f (mk_id "_prove") = 0 -> + | E_app (f, [E_aux (E_constraint nc, _)]), _ when string_of_id f = "_prove" -> Env.wf_constraint env nc; - if prove env nc + if prove __POS__ 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_constraint nc, _)]), _ when Id.compare f (mk_id "_not_prove") = 0 -> + else typ_error env l ("Cannot prove " ^ string_of_n_constraint nc) + | E_app (f, [E_aux (E_constraint nc, _)]), _ when string_of_id f = "_not_prove" -> Env.wf_constraint env nc; - if prove env nc - then typ_error l ("Can prove " ^ string_of_n_constraint nc) + if prove __POS__ env nc + then typ_error env l ("Can prove " ^ string_of_n_constraint nc) else annot_exp (E_lit (L_aux (L_unit, Parse_ast.Unknown))) unit_typ + | E_app (f, [E_aux (E_cast (typ, exp), _)]), _ when string_of_id f = "_check" -> + Env.wf_typ env typ; + let _ = crule check_exp env exp typ in + annot_exp (E_lit (L_aux (L_unit, Parse_ast.Unknown))) unit_typ + | E_app (f, [E_aux (E_cast (typ, exp), _)]), _ when string_of_id f = "_not_check" -> + Env.wf_typ env typ; + if (try (ignore (crule check_exp env exp typ); false) with Type_error _ -> true) + then annot_exp (E_lit (L_aux (L_unit, Parse_ast.Unknown))) unit_typ + else typ_error env l (Printf.sprintf "Expected _not_check(%s : %s) to fail" (string_of_exp exp) (string_of_typ 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 -> @@ -2276,22 +2363,22 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ let backwards_id = mk_id (string_of_id mapping ^ "_backwards") in typ_print (lazy("Trying forwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")")); begin try crule check_exp env (E_aux (E_app (forwards_id, xs), (l, ()))) typ with - | Type_error (_, err1) -> + | Type_error (_, _, err1) -> (* typ_print (lazy ("Error in forwards direction: " ^ string_of_type_error err1)); *) typ_print (lazy ("Trying backwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")")); begin try crule check_exp env (E_aux (E_app (backwards_id, xs), (l, ()))) typ with - | Type_error (_, err2) -> + | Type_error (_, _, err2) -> (* typ_print (lazy ("Error in backwards direction: " ^ string_of_type_error err2)); *) - typ_raise l (Err_no_overloading (mapping, [(forwards_id, err1); (backwards_id, err2)])) + typ_raise env l (Err_no_overloading (mapping, [(forwards_id, err1); (backwards_id, err2)])) end end | E_app (f, xs), _ when List.length (Env.get_overloads f env) > 0 -> let rec try_overload = function - | (errs, []) -> typ_raise l (Err_no_overloading (f, errs)) + | (errs, []) -> typ_raise env l (Err_no_overloading (f, errs)) | (errs, (f :: fs)) -> begin typ_print (lazy ("Overload: " ^ string_of_id f ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")")); try crule check_exp env (E_aux (E_app (f, xs), (l, ()))) typ with - | Type_error (_, err) -> + | Type_error (_, _, err) -> typ_debug (lazy "Error"); try_overload (errs @ [(f, err)], fs) end @@ -2300,7 +2387,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ | E_return exp, _ -> let checked_exp = match Env.get_ret_typ env with | Some ret_typ -> crule check_exp env exp ret_typ - | None -> typ_error l "Cannot use return outside a function" + | None -> typ_error env l "Cannot use return outside a function" in annot_exp (E_return checked_exp) typ | E_tuple exps, Typ_tup typs when List.length exps = List.length typs -> @@ -2365,16 +2452,50 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ | E_vector vec, _ -> let (len, ord, vtyp) = destruct_vec_typ l env typ in let checked_items = List.map (fun i -> crule check_exp env i vtyp) vec in - if prove env (nc_eq (nint (List.length vec)) (nexp_simp len)) then annot_exp (E_vector checked_items) typ - else typ_error l "List length didn't match" (* FIXME: improve error message *) + if prove __POS__ env (nc_eq (nint (List.length vec)) (nexp_simp len)) then annot_exp (E_vector checked_items) typ + else typ_error env l "List length didn't match" (* FIXME: improve error message *) | E_lit (L_aux (L_undef, _) as lit), _ -> if is_typ_monomorphic typ || Env.polymorphic_undefineds env then annot_exp_effect (E_lit lit) typ (mk_effect [BE_undef]) - else typ_error l ("Type " ^ string_of_typ typ ^ " failed undefined monomorphism restriction") + else typ_error env l ("Type " ^ string_of_typ typ ^ " failed undefined monomorphism restriction") | _, _ -> let inferred_exp = irule infer_exp env exp in type_coercion env inferred_exp typ +and check_block l env exps ret_typ = + let final env exp = match ret_typ with + | Some typ -> crule check_exp env exp typ + | None -> irule infer_exp env exp + in + let annot_exp_effect exp typ eff exp_typ = E_aux (exp, (l, mk_expected_tannot env typ eff exp_typ)) in + let annot_exp exp typ exp_typ = annot_exp_effect exp typ no_effect exp_typ in + match Nl_flow.analyze exps with + | [] -> (match ret_typ with Some typ -> typ_equality l env typ unit_typ; [] | None -> []) + | [exp] -> [final env exp] + | (E_aux (E_assign (lexp, bind), _) :: exps) -> + let texp, env = bind_assignment env lexp bind in + texp :: check_block l env exps ret_typ + | ((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 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")); + Env.add_constraint nc env + | None -> env + 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 ret_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_not (assert_constraint env false cond')) env in + texp :: check_block l env exps ret_typ + | (exp :: exps) -> + let texp = crule check_exp env exp (mk_typ (Typ_id (mk_id "unit"))) in + texp :: check_block l env exps ret_typ + and check_case env pat_typ pexp typ = let pat,guard,case,((l,_) as annot) = destruct_pexp pexp in match bind_pat env pat pat_typ with @@ -2439,20 +2560,20 @@ and check_mpexp other_env env mpexp typ = or throws a type error if the coercion cannot be performed. *) and type_coercion env (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 annot_exp exp typ' = E_aux (exp, (l, mk_expected_tannot env typ' no_effect (Some typ))) in let switch_exp_typ exp = match exp with - | (E_aux (exp, (l, Some ((env, typ', eff), _)))) -> E_aux (exp, (l, Some ((env, typ', eff), Some typ))) + | E_aux (exp, (l, Some tannot)) -> E_aux (exp, (l, Some { tannot with expected = Some typ })) | _ -> failwith "Cannot switch type for unannotated function" in let rec try_casts trigger errs = function - | [] -> typ_raise l (Err_no_casts (strip_exp annotated_exp, typ_of annotated_exp, typ, trigger, errs)) + | [] -> typ_raise env l (Err_no_casts (strip_exp annotated_exp, typ_of annotated_exp, typ, trigger, errs)) | (cast :: casts) -> begin typ_print (lazy ("Casting with " ^ string_of_id cast ^ " expression " ^ string_of_exp annotated_exp ^ " to " ^ string_of_typ typ)); try let checked_cast = crule check_exp (Env.no_casts env) (strip (E_app (cast, [annotated_exp]))) typ in annot_exp (E_cast (typ, checked_cast)) typ with - | Type_error (_, err) -> try_casts trigger (err :: errs) casts + | Type_error (_, _, err) -> try_casts trigger (err :: errs) casts end in begin @@ -2460,10 +2581,10 @@ and type_coercion env (E_aux (_, (l, _)) as annotated_exp) 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 -> + | 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_raise l err + | Type_error (env, l, err) -> typ_raise env l err end (* type_coercion_unify env exp typ attempts to coerce exp to a type @@ -2473,9 +2594,9 @@ and type_coercion env (E_aux (_, (l, _)) as annotated_exp) typ = throws a unification error *) 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 annot_exp exp typ' = E_aux (exp, (l, mk_expected_tannot env typ' no_effect (Some typ))) in let switch_typ exp typ = match exp with - | (E_aux (exp, (l, Some (env, _, eff)))) -> E_aux (exp, (l, Some (env, typ, eff))) + | E_aux (exp, (l, Some tannot)) -> E_aux (exp, (l, Some { tannot with typ = typ })) | _ -> failwith "Cannot switch type for unannotated expression" in let rec try_casts = function @@ -2484,17 +2605,17 @@ and type_coercion_unify env goals (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, env = bind_existential l (typ_of inferred_cast) env in + let ityp, env = bind_existential l None (typ_of inferred_cast) env in inferred_cast, unify l env goals typ ityp, env with - | Type_error (_, err) -> try_casts casts + | Type_error (_, _, err) -> try_casts casts | Unification_error (_, err) -> try_casts casts end in begin try 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 + let atyp, env = bind_existential l None (typ_of annotated_exp) env in annotated_exp, unify l env goals typ atyp, env with | Unification_error (_, m) when Env.allow_casts env -> @@ -2504,16 +2625,16 @@ and type_coercion_unify env goals (E_aux (_, (l, _)) as annotated_exp) typ = and bind_pat_no_guard env (P_aux (_,(l,_)) as pat) typ = match bind_pat env pat typ with - | _, _, _::_ -> typ_error l "Literal patterns not supported here" + | _, _, _::_ -> typ_error env l "Literal patterns not supported here" | tpat, env, [] -> tpat, env 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 + let (Typ_aux (typ_aux, _) as typ), env = bind_existential l (name_pat pat) typ env in 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 annot_pat pat typ' = P_aux (pat, (l, mk_expected_tannot 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))) - | _ -> typ_error l "Cannot switch type for unannotated pattern" + | P_aux (pat_aux, (l, Some tannot)) -> P_aux (pat_aux, (l, Some { tannot with typ = typ })) + | _ -> typ_error env l "Cannot switch type for unannotated pattern" in let bind_tuple_pat (tpats, env, guards) pat typ = let tpat, env, guards' = bind_pat env pat typ in tpat :: tpats, env, guards' @ guards @@ -2531,7 +2652,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) match Env.lookup_id v env with | Local _ | Unbound -> annot_pat (P_id v) typ, Env.add_local v (Immutable, typ) env, [] | Register _ -> - typ_error l ("Cannot shadow register in pattern " ^ string_of_pat pat) + typ_error env l ("Cannot shadow register in pattern " ^ string_of_pat pat) | Enum enum -> subtyp l env enum typ; annot_pat (P_id v) typ, env, [] end | P_var (pat, typ_pat) -> @@ -2553,7 +2674,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) 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 - | _ -> typ_error l "Cannot match cons pattern against non-list type" + | _ -> typ_error env l "Cannot match cons pattern against non-list type" end | P_string_append pats -> begin @@ -2568,7 +2689,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) in let pats, env, guards = process_pats env pats in annot_pat (P_string_append pats) typ, env, guards - | _ -> typ_error l "Cannot match string-append pattern against non-string type" + | _ -> typ_error env l "Cannot match string-append pattern against non-string type" end | P_list pats -> begin @@ -2583,14 +2704,14 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) in let pats, env, guards = process_pats env pats in annot_pat (P_list pats) typ, env, guards - | _ -> typ_error l ("Cannot match list pattern " ^ string_of_pat pat ^ " against non-list type " ^ string_of_typ typ) + | _ -> typ_error env l ("Cannot match list pattern " ^ string_of_pat pat ^ " against non-list type " ^ string_of_typ typ) end | P_tup [] -> begin match Env.expand_synonyms env typ with | Typ_aux (Typ_id typ_id, _) when string_of_id typ_id = "unit" -> annot_pat (P_tup []) typ, env, [] - | _ -> typ_error l "Cannot match unit pattern against non-unit type" + | _ -> typ_error env l "Cannot match unit pattern against non-unit type" end | P_tup pats -> begin @@ -2598,11 +2719,11 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) | Typ_aux (Typ_tup typs, _) -> let tpats, env, guards = try List.fold_left2 bind_tuple_pat ([], env, []) pats typs with - | Invalid_argument _ -> typ_error l "Tuple pattern and tuple type have different length" + | Invalid_argument _ -> typ_error env l "Tuple pattern and tuple type have different length" in annot_pat (P_tup (List.rev tpats)) typ, env, guards | _ -> - typ_error l (Printf.sprintf "Cannot bind tuple pattern %s against non tuple type %s" + typ_error env l (Printf.sprintf "Cannot bind tuple pattern %s against non tuple type %s" (string_of_pat pat) (string_of_typ typ)) end | P_app (f, pats) when Env.is_union_constructor f env -> @@ -2623,18 +2744,18 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) let arg_typ' = subst_unifiers unifiers arg_typ in let quants' = List.fold_left instantiate_quants quants (KBindings.bindings unifiers) 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)) + typ_raise env 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 = try List.fold_left2 bind_tuple_pat ([], env, []) pats (untuple arg_typ') with - | Invalid_argument _ -> typ_error l "Union constructor pattern arguments have incorrect length" + | Invalid_argument _ -> typ_error env l "Union constructor pattern arguments have incorrect length" in annot_pat (P_app (f, List.rev tpats)) typ, env, guards with - | Unification_error (l, m) -> typ_error l ("Unification error when pattern matching against union constructor: " ^ m) + | Unification_error (l, m) -> typ_error env l ("Unification error when pattern matching against union constructor: " ^ m) end - | _ -> typ_error l ("Mal-formed constructor " ^ string_of_id f ^ " with type " ^ string_of_typ ctor_typ) + | _ -> typ_error env l ("Mal-formed constructor " ^ string_of_id f ^ " with type " ^ string_of_typ ctor_typ) end | P_app (f, pats) when Env.is_mapping f env -> @@ -2656,13 +2777,13 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) 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) - then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in pattern " ^ string_of_pat pat) + then typ_error env l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in pattern " ^ string_of_pat pat) else (); let ret_typ' = subst_unifiers unifiers typ2 in let tpats, env, guards = try List.fold_left2 bind_tuple_pat ([], env, []) pats (untuple arg_typ') with - | Invalid_argument _ -> typ_error l "Mapping pattern arguments have incorrect length" + | Invalid_argument _ -> typ_error env l "Mapping pattern arguments have incorrect length" in annot_pat (P_app (f, List.rev tpats)) typ, env, guards with @@ -2674,22 +2795,22 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) 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) - then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in pattern " ^ string_of_pat pat) + then typ_error env l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in pattern " ^ string_of_pat pat) else (); let ret_typ' = subst_unifiers unifiers typ1 in let tpats, env, guards = try List.fold_left2 bind_tuple_pat ([], env, []) pats (untuple arg_typ') with - | Invalid_argument _ -> typ_error l "Mapping pattern arguments have incorrect length" + | Invalid_argument _ -> typ_error env l "Mapping pattern arguments have incorrect length" in annot_pat (P_app (f, List.rev tpats)) typ, env, guards with - | Unification_error (l, m) -> typ_error l ("Unification error when pattern matching against mapping constructor: " ^ m) + | Unification_error (l, m) -> typ_error env l ("Unification error when pattern matching against mapping constructor: " ^ m) end - | _ -> typ_error l ("Mal-formed mapping " ^ string_of_id f) + | _ -> typ_error env l ("Mal-formed mapping " ^ string_of_id f) end | P_app (f, _) when (not (Env.is_union_constructor f env) && not (Env.is_mapping f env)) -> - typ_error l (string_of_id f ^ " is not a union constructor or mapping in pattern " ^ string_of_pat pat) + typ_error env 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)) (typ_of_pat typed_pat), Env.add_local id (Immutable, typ_of_pat typed_pat) env, guards @@ -2697,6 +2818,12 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) | 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, [] + | P_lit (L_aux (L_true, _) as lit) when is_atom_bool typ -> + let nc = match destruct_atom_bool env typ with Some nc -> nc | None -> assert false in + annot_pat (P_lit lit) (atom_bool_typ nc_true), Env.add_constraint nc env, [] + | P_lit (L_aux (L_false, _) as lit) when is_atom_bool typ -> + let nc = match destruct_atom_bool env typ with Some nc -> nc | None -> assert false in + annot_pat (P_lit lit) (atom_bool_typ nc_false), Env.add_constraint (nc_not nc) env, [] | _ -> let (inferred_pat, env, guards) = infer_pat env pat in match subtyp l env typ (typ_of_pat inferred_pat) with @@ -2711,15 +2838,15 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) | _ -> raise typ_exn and infer_pat env (P_aux (pat_aux, (l, ())) as pat) = - let annot_pat pat typ = P_aux (pat, (l, Some ((env, typ, no_effect), None))) in + let annot_pat pat typ = P_aux (pat, (l, mk_tannot env typ no_effect)) in match pat_aux with | P_id v -> begin match Env.lookup_id v env with | Local (Immutable, _) | Unbound -> - typ_error l ("Cannot infer identifier in pattern " ^ string_of_pat pat ^ " - try adding a type annotation") + typ_error env l ("Cannot infer identifier in pattern " ^ string_of_pat pat ^ " - try adding a type annotation") | Local (Mutable, _) | Register _ -> - typ_error l ("Cannot shadow mutable local or register in switch statement pattern " ^ string_of_pat pat) + typ_error env l ("Cannot shadow mutable local or register in switch statement pattern " ^ string_of_pat pat) | Enum enum -> annot_pat (P_id v) enum, env, [] end | P_app (f, mpats) when Env.is_union_constructor f env -> @@ -2728,7 +2855,7 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as pat) = match Env.expand_synonyms env ctor_typ with | Typ_aux (Typ_fn (arg_typ, ret_typ, _), _) -> bind_pat env pat ret_typ - | _ -> typ_error l ("Mal-formed constructor " ^ string_of_id f) + | _ -> typ_error env l ("Mal-formed constructor " ^ string_of_id f) end | P_app (f, mpats) when Env.is_mapping f env -> begin @@ -2742,7 +2869,7 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as pat) = | Type_error _ -> bind_pat env pat typ1 end - | _ -> typ_error l ("Malformed mapping type " ^ string_of_id f) + | _ -> typ_error env l ("Malformed mapping type " ^ string_of_id f) end | P_typ (typ_annot, pat) -> Env.wf_typ env typ_annot; @@ -2790,7 +2917,7 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as pat) = 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) + | _ -> typ_error env l ("Couldn't infer type of pattern " ^ string_of_pat pat) and bind_typ_pat env (TP_aux (typ_pat_aux, l) as typ_pat) (Typ_aux (typ_aux, _) as typ) = match typ_pat_aux, typ_aux with @@ -2801,25 +2928,25 @@ and bind_typ_pat env (TP_aux (typ_pat_aux, l) as typ_pat) (Typ_aux (typ_aux, _) | [nexp] -> 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") + typ_error env l ("No numeric expressions in " ^ string_of_typ typ ^ " to bind " ^ string_of_kid kid ^ " to") | nexps -> - typ_error l ("Type " ^ string_of_typ typ ^ " has multiple numeric expressions. Cannot bind " ^ string_of_kid kid) + typ_error env l ("Type " ^ string_of_typ typ ^ " has multiple numeric expressions. Cannot bind " ^ string_of_kid kid) end | 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) + | _, _ -> typ_error env 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) (A_aux (typ_arg_aux, _) as typ_arg) = 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 (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) + | _, A_order _ -> typ_error env l "Cannot bind type pattern against order" + | _, _ -> typ_error env 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) = - let annot_assign lexp exp = E_aux (E_assign (lexp, exp), (l, Some ((env, mk_typ (Typ_id (mk_id "unit")), no_effect), None))) in - let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, Some ((env, typ, eff), None))) in + let annot_assign lexp exp = E_aux (E_assign (lexp, exp), (l, mk_tannot env (mk_typ (Typ_id (mk_id "unit"))) no_effect)) in + let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, mk_tannot env typ eff)) in let annot_lexp lexp typ = annot_lexp_effect lexp typ no_effect in let has_typ v env = match Env.lookup_id v env with @@ -2834,14 +2961,14 @@ and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as begin match Env.lookup_id v env with | Register (_, _, typ) -> typ, LEXP_id v, true | Local (Mutable, typ) -> typ, LEXP_id v, false - | _ -> typ_error l "l-expression field is not a register or a local mutable type" + | _ -> typ_error env l "l-expression field is not a register or a local mutable type" end | LEXP_vector (LEXP_aux (LEXP_id v, _), exp) -> begin (* Check: is this ok if the vector is immutable? *) let is_immutable, vtyp, is_register = match Env.lookup_id v env with - | Unbound -> typ_error l "Cannot assign to element of unbound vector" - | Enum _ -> typ_error l "Cannot vector assign to enumeration element" + | Unbound -> typ_error env l "Cannot assign to element of unbound vector" + | Enum _ -> typ_error env l "Cannot vector assign to enumeration element" | Local (Immutable, vtyp) -> true, vtyp, false | Local (Mutable, vtyp) -> false, vtyp, false | Register (_, _, vtyp) -> false, vtyp, true @@ -2853,7 +2980,7 @@ and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as in typ_of access, LEXP_vector (annot_lexp (LEXP_id v) vtyp, inferred_exp), is_register end - | _ -> typ_error l "Field l-expression must be either a vector or an identifier" + | _ -> typ_error env l "Field l-expression must be either a vector or an identifier" in let regtyp, inferred_flexp, is_register = infer_flexp flexp in typ_debug (lazy ("REGTYP: " ^ string_of_typ regtyp ^ " / " ^ string_of_typ (Env.expand_synonyms env regtyp))); @@ -2861,11 +2988,11 @@ 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 (tyvars_of_typ rectyp_q) rectyp_q regtyp 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 env 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 - | _ -> typ_error l "Field l-expression has invalid type" + | _ -> typ_error env l "Field l-expression has invalid type" end | LEXP_memory (f, xs) -> check_exp env (E_aux (E_app (f, xs @ [exp]), (l, ()))) unit_typ, env @@ -2891,22 +3018,22 @@ 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 (l, err) -> + | 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)) + with Type_error (env, l', err') -> typ_raise env l' (Err_because (err', l, 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 + let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, mk_tannot env typ eff)) in let annot_lexp lexp typ = annot_lexp_effect lexp typ no_effect in match lexp_aux with | LEXP_cast (typ_annot, v) -> begin match Env.lookup_id ~raw:true v env with | Local (Immutable, _) | Enum _ -> - typ_error l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v) + typ_error env l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v) | Local (Mutable, vtyp) -> subtyp l env typ typ_annot; subtyp l env typ_annot vtyp; @@ -2925,12 +3052,12 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = | 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 ^ ")") + typ_error env l (string_of_typ typ ^ " must be a register type in " ^ string_of_exp exp ^ ")") end | LEXP_id v -> begin match Env.lookup_id ~raw:true v env with | Local (Immutable, _) | Enum _ -> - typ_error l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v) + typ_error env l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v) | Local (Mutable, vtyp) -> subtyp l env typ vtyp; annot_lexp (LEXP_id v) typ, Env.remove_flow v env | Register (_, weff, vtyp) -> subtyp l env typ vtyp; annot_lexp_effect (LEXP_id v) typ weff, env | Unbound -> annot_lexp (LEXP_id v) typ, Env.add_local v (Mutable, typ) env @@ -2946,10 +3073,10 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = in let tlexps, env = try List.fold_right2 bind_tuple_lexp lexps typs ([], env) with - | Invalid_argument _ -> typ_error l "Tuple l-expression and tuple type have different length" + | Invalid_argument _ -> typ_error env l "Tuple l-expression and tuple type have different length" in annot_lexp (LEXP_tup tlexps) typ, env - | _ -> typ_error l ("Cannot bind tuple l-expression against non tuple type " ^ string_of_typ typ) + | _ -> typ_error env l ("Cannot bind tuple l-expression against non tuple type " ^ string_of_typ typ) end | _ -> let inferred_lexp = infer_lexp env lexp in @@ -2957,7 +3084,7 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = inferred_lexp, env and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) = - let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, Some ((env, typ, eff), None))) in + let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, mk_tannot env typ eff)) in let annot_lexp lexp typ = annot_lexp_effect lexp typ no_effect in match lexp_aux with | LEXP_id v -> @@ -2966,9 +3093,9 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) = (* Probably need to remove flows here *) | Register (_, weff, typ) -> annot_lexp_effect (LEXP_id v) typ weff | Local (Immutable, _) | Enum _ -> - typ_error l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v) + typ_error env l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v) | Unbound -> - typ_error l ("Cannot create a new identifier in this l-expression " ^ string_of_lexp lexp) + typ_error env l ("Cannot create a new identifier in this l-expression " ^ string_of_lexp lexp) end | LEXP_vector_range (v_lexp, exp1, exp2) -> begin @@ -2982,15 +3109,15 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) = let nexp1, env = bind_numeric l (typ_of inferred_exp1) env in let nexp2, env = bind_numeric l (typ_of inferred_exp2) env in begin match ord with - | Ord_aux (Ord_inc, _) when !opt_no_lexp_bounds_check || prove env (nc_lteq nexp1 nexp2) -> + | Ord_aux (Ord_inc, _) when !opt_no_lexp_bounds_check || prove __POS__ env (nc_lteq nexp1 nexp2) -> let len = nexp_simp (nsum (nminus nexp2 nexp1) (nint 1)) in annot_lexp (LEXP_vector_range (inferred_v_lexp, inferred_exp1, inferred_exp2)) (vector_typ len ord elem_typ) - | Ord_aux (Ord_dec, _) when !opt_no_lexp_bounds_check || prove env (nc_gteq nexp1 nexp2) -> + | Ord_aux (Ord_dec, _) when !opt_no_lexp_bounds_check || prove __POS__ env (nc_gteq nexp1 nexp2) -> let len = nexp_simp (nsum (nminus nexp1 nexp2) (nint 1)) in annot_lexp (LEXP_vector_range (inferred_v_lexp, inferred_exp1, inferred_exp2)) (vector_typ len ord elem_typ) - | _ -> typ_error l ("Could not infer length of vector slice assignment " ^ string_of_lexp lexp) + | _ -> typ_error env l ("Could not infer length of vector slice assignment " ^ string_of_lexp lexp) end - | _ -> typ_error l "Cannot assign slice of non vector type" + | _ -> typ_error env l "Cannot assign slice of non vector type" end | LEXP_vector (v_lexp, exp) -> begin @@ -3001,13 +3128,13 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) = 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 - if !opt_no_lexp_bounds_check || prove env (nc_and (nc_lteq (nint 0) nexp) (nc_lteq nexp (nexp_simp (nminus len (nint 1))))) then + if !opt_no_lexp_bounds_check || prove __POS__ env (nc_and (nc_lteq (nint 0) nexp) (nc_lteq nexp (nexp_simp (nminus len (nint 1))))) then annot_lexp (LEXP_vector (inferred_v_lexp, inferred_exp)) elem_typ else - typ_error l ("Vector assignment not provably in bounds " ^ string_of_lexp lexp) - | _ -> typ_error l "Cannot assign vector element of non vector type" + typ_error env l ("Vector assignment not provably in bounds " ^ string_of_lexp lexp) + | _ -> typ_error env l "Cannot assign vector element of non vector type" end - | LEXP_vector_concat [] -> typ_error l "Cannot have empty vector concatenation l-expression" + | LEXP_vector_concat [] -> typ_error env l "Cannot have empty vector concatenation l-expression" | LEXP_vector_concat (v_lexp :: v_lexps) -> begin let sum_lengths first_ord first_elem_typ acc (Typ_aux (v_typ_aux, _) as v_typ) = @@ -3016,7 +3143,7 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) = 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 - | _ -> typ_error l "Vector concatentation l-expression must only contain vector types of the same order" + | _ -> typ_error env l "Vector concatentation l-expression must only contain vector types of the same order" in let inferred_v_lexp = infer_lexp env v_lexp in let inferred_v_lexps = List.map (infer_lexp env) v_lexps in @@ -3027,26 +3154,30 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) = 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) - | _ -> typ_error l ("Vector concatentation l-expression must only contain vector types, found " ^ string_of_typ v_typ) + | _ -> typ_error env l ("Vector concatentation l-expression must only contain vector types, found " ^ string_of_typ v_typ) end | LEXP_field (LEXP_aux (LEXP_id v, _), fid) -> (* FIXME: will only work for ASL *) let rec_id, weff = match Env.lookup_id v env with | Register (_, weff, Typ_aux (Typ_id rec_id, _)) -> rec_id, weff - | _ -> typ_error l (string_of_lexp lexp ^ " must be a record register here") + | _ -> typ_error env l (string_of_lexp lexp ^ " must be a record register here") 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 | 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) + | _ -> typ_error env 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 + let annot_exp_effect exp typ eff = E_aux (exp, (l, mk_tannot env typ eff)) in let annot_exp exp typ = annot_exp_effect exp typ no_effect in match exp_aux with + | E_block exps -> + let rec last_typ = function [exp] -> typ_of exp | _ :: exps -> last_typ exps | [] -> unit_typ in + let inferred_block = check_block l env exps None in + annot_exp (E_block inferred_block) (last_typ inferred_block) | E_nondet exps -> annot_exp (E_nondet (List.map (fun exp -> crule check_exp env exp unit_typ) exps)) unit_typ | E_id v -> @@ -3054,13 +3185,14 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = match Env.lookup_id v env with | Local (_, typ) | Enum typ -> annot_exp (E_id v) typ | Register (reff, _, typ) -> annot_exp_effect (E_id v) typ reff - | Unbound -> typ_error l ("Identifier " ^ string_of_id v ^ " is unbound") + | Unbound -> typ_error env 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 (A_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 + annot_exp (E_constraint nc) (atom_bool_typ nc) | E_field (exp, field) -> begin let inferred_exp = irule infer_exp env exp in @@ -3068,7 +3200,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = (* Accessing a field of a record *) | Typ_aux (Typ_id rectyp, _) as typ when Env.is_record rectyp env -> begin - let inferred_acc, _ = infer_funapp' l (Env.no_casts env) field (Env.get_accessor_fn rectyp field env) [strip_exp inferred_exp] None in + let inferred_acc = infer_funapp' l (Env.no_casts env) field (Env.get_accessor_fn rectyp field env) [strip_exp inferred_exp] None in match inferred_acc with | E_aux (E_app (field, [inferred_exp]) ,_) -> annot_exp (E_field (inferred_exp, field)) (typ_of inferred_acc) | _ -> assert false (* Unreachable *) @@ -3076,12 +3208,12 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = (* Not sure if we need to do anything different with args here. *) | Typ_aux (Typ_app (rectyp, args), _) as typ when Env.is_record rectyp env -> begin - let inferred_acc, _ = infer_funapp' l (Env.no_casts env) field (Env.get_accessor_fn rectyp field env) [strip_exp inferred_exp] None in + let inferred_acc = infer_funapp' l (Env.no_casts env) field (Env.get_accessor_fn rectyp field env) [strip_exp inferred_exp] None in match inferred_acc with | E_aux (E_app (field, [inferred_exp]) ,_) -> annot_exp (E_field (inferred_exp, field)) (typ_of inferred_acc) | _ -> assert false (* Unreachable *) end - | _ -> typ_error l ("Field expression " ^ string_of_exp exp ^ " :: " ^ string_of_typ (typ_of inferred_exp) ^ " is not valid") + | _ -> typ_error env l ("Field expression " ^ string_of_exp exp ^ " :: " ^ string_of_typ (typ_of inferred_exp) ^ " is not valid") end | E_tuple exps -> let inferred_exps = List.map (irule infer_exp env) exps in @@ -3094,11 +3226,11 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = 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 -> rectyp_id - | _ -> typ_error l ("The type " ^ string_of_typ typ ^ " is not a record") + | _ -> typ_error env l ("The type " ^ string_of_typ typ ^ " is not a record") 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 (tyvars_of_typ rectyp_q) rectyp_q typ 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 env 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)) @@ -3117,22 +3249,22 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = let backwards_id = mk_id (string_of_id mapping ^ "_backwards") in typ_print (lazy ("Trying forwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")")); begin try irule infer_exp env (E_aux (E_app (forwards_id, xs), (l, ()))) with - | Type_error (_, err1) -> + | Type_error (_, _, err1) -> (* typ_print (lazy ("Error in forwards direction: " ^ string_of_type_error err1)); *) typ_print (lazy ("Trying backwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")")); begin try irule infer_exp env (E_aux (E_app (backwards_id, xs), (l, ()))) with - | Type_error (_, err2) -> + | Type_error (env, _, err2) -> (* typ_print (lazy ("Error in backwards direction: " ^ string_of_type_error err2)); *) - typ_raise l (Err_no_overloading (mapping, [(forwards_id, err1); (backwards_id, err2)])) + typ_raise env l (Err_no_overloading (mapping, [(forwards_id, err1); (backwards_id, err2)])) end end | E_app (f, xs) when List.length (Env.get_overloads f env) > 0 -> let rec try_overload = function - | (errs, []) -> typ_raise l (Err_no_overloading (f, errs)) + | (errs, []) -> typ_raise env l (Err_no_overloading (f, errs)) | (errs, (f :: fs)) -> begin typ_print (lazy ("Overload: " ^ string_of_id f ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")")); try irule infer_exp env (E_aux (E_app (f, xs), (l, ()))) with - | Type_error (_, err) -> + | Type_error (_, _, err) -> typ_debug (lazy "Error"); try_overload (errs @ [(f, err)], fs) end @@ -3148,7 +3280,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = let f, t, is_dec = match ord with | Ord_aux (Ord_inc, _) -> f, t, false | Ord_aux (Ord_dec, _) -> t, f, true (* reverse direction to typechecking downto as upto loop *) - | Ord_aux (Ord_var _, _) -> typ_error l "Cannot check a loop with variable direction!" (* This should never happen *) + | Ord_aux (Ord_var _, _) -> typ_error env l "Cannot check a loop with variable direction!" (* This should never happen *) in let inferred_f = irule infer_exp env f in let inferred_t = irule infer_exp env t in @@ -3164,7 +3296,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = if not is_dec (* undo reverse direction in annotated ast for downto loop *) then annot_exp (E_for (v, inferred_f, inferred_t, checked_step, ord, checked_body)) unit_typ else annot_exp (E_for (v, inferred_t, inferred_f, checked_step, ord, checked_body)) unit_typ - | _, _ -> typ_error l "Ranges in foreach overlap" + | _, _ -> typ_error env l "Ranges in foreach overlap" end | E_if (cond, then_branch, else_branch) -> let cond' = crule check_exp env cond (mk_typ (Typ_id (mk_id "bool"))) in @@ -3179,11 +3311,17 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = 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) + | None -> typ_error env 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') + begin match typ_of then_branch' with + | Typ_aux (Typ_app (f, [_]), _) when string_of_id f = "atom_bool" -> + let else_branch' = crule check_exp (add_opt_constraint (option_map nc_not (assert_constraint env false cond')) env) else_branch bool_typ in + annot_exp (E_if (cond', then_branch', else_branch')) bool_typ + | _ -> + 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 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, ()))) @@ -3191,7 +3329,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = | E_vector_append (v1, E_aux (E_vector [], _)) -> infer_exp env v1 | E_vector_append (v1, v2) -> infer_exp env (E_aux (E_app (mk_id "append", [v1; v2]), (l, ()))) | E_vector_subrange (v, n, m) -> infer_exp env (E_aux (E_app (mk_id "vector_subrange", [v; n; m]), (l, ()))) - | E_vector [] -> typ_error l "Cannot infer type of empty vector" + | E_vector [] -> typ_error env l "Cannot infer type of empty vector" | E_vector ((item :: items) as vec) -> let inferred_item = irule infer_exp env item in let checked_items = List.map (fun i -> crule check_exp env i (typ_of inferred_item)) items in @@ -3243,25 +3381,31 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = | E_ref id when Env.is_register id env -> let _, _, typ = Env.get_register id env in annot_exp (E_ref id) (register_typ typ) - | _ -> typ_error l ("Cannot infer type of: " ^ string_of_exp exp) + | _ -> typ_error env l ("Cannot infer type of: " ^ string_of_exp exp) -and infer_funapp l env f xs ret_ctx_typ = fst (infer_funapp' l env f (Env.get_val_spec f env) xs ret_ctx_typ) +and infer_funapp l env f xs ret_ctx_typ = infer_funapp' l env f (Env.get_val_spec f env) xs ret_ctx_typ -and instantiation_of (E_aux (exp_aux, (l, _)) as exp) = - let env = env_of exp in - match exp_aux with - | E_app (f, xs) -> snd (infer_funapp' l (Env.no_casts env) f (Env.get_val_spec f env) (List.map strip_exp xs) (Some (typ_of exp))) +and instantiation_of (E_aux (exp_aux, (l, tannot)) as exp) = + match tannot with + | Some t -> + begin match t.instantiation with + | Some inst -> inst + | None -> + raise (Reporting.err_unreachable l __POS__ "Passed non type-checked function to instantiation_of") + end | _ -> invalid_arg ("instantiation_of expected application, got " ^ string_of_exp exp) and instantiation_of_without_type (E_aux (exp_aux, (l, _)) as exp) = let env = env_of exp in match exp_aux with - | 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) + | E_app (f, xs) -> instantiation_of (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 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 annot_exp exp typ eff inst = + E_aux (exp, (l, Some { env = env; typ = typ; effect = eff; expected = expected_ret_typ; instantiation = Some inst })) + 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 @@ -3280,7 +3424,7 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ = 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 - | _ -> typ_error l (string_of_typ f_typ ^ " is not a function type") + | _ -> typ_error env l (string_of_typ f_typ ^ " is not a function type") in let unifiers = instantiate_simple_equations !quants in @@ -3294,7 +3438,7 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ = 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)) + typ_error env 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) = @@ -3332,7 +3476,7 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ = 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 + | Unification_error (l, m) -> typ_error env l m in record_unifiers unifiers; let unifiers = KBindings.bindings unifiers in @@ -3356,7 +3500,7 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ = 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)) + typ_raise env l (Err_unresolved_quants (f, !quants, Env.get_locals env, Env.get_constraints env)) else (); let ty_vars = KBindings.bindings (Env.get_typ_vars env) |> List.map (fun (v, k) -> mk_kopt k v) in @@ -3369,23 +3513,22 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ = let universals = KBindings.bindings universals |> List.map fst |> KidSet.of_list in let typ_ret = - if KidSet.is_empty (KidSet.of_list (List.map kopt_kid 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 (tyvars_of_typ !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 + let exp = annot_exp (E_app (f, xs)) typ_ret eff !all_unifiers in typ_debug (lazy ("Returning: " ^ string_of_exp exp)); - - exp, !all_unifiers + exp 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 - typ_print (lazy ("Binding " ^ string_of_mpat mpat ^ " to " ^ string_of_typ typ)); - let annot_mpat mpat typ' = MP_aux (mpat, (l, Some ((env, typ', no_effect), Some typ))) in + let (Typ_aux (typ_aux, _) as typ), env = bind_existential l None typ env in + typ_print (lazy (Util.("Binding " |> yellow |> clear) ^ string_of_mpat mpat ^ " to " ^ string_of_typ typ)); + let annot_mpat mpat typ' = MP_aux (mpat, (l, mk_expected_tannot env typ' no_effect (Some typ))) in let switch_typ mpat typ = match mpat with - | MP_aux (pat_aux, (l, Some ((env, _, eff), exp_typ))) -> MP_aux (pat_aux, (l, Some ((env, typ, eff), exp_typ))) - | _ -> typ_error l "Cannot switch type for unannotated mapping-pattern" + | MP_aux (pat_aux, (l, Some tannot)) -> MP_aux (pat_aux, (l, Some { tannot with typ = typ })) + | _ -> typ_error env l "Cannot switch type for unannotated mapping-pattern" in let bind_tuple_mpat (tpats, env, guards) mpat typ = let tpat, env, guards' = bind_mpat allow_unknown other_env env mpat typ in tpat :: tpats, env, guards' @ guards @@ -3403,7 +3546,7 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) ( match Env.lookup_id v env with | Local (Immutable, _) | Unbound -> annot_mpat (MP_id v) typ, Env.add_local v (Immutable, typ) env, [] | Local (Mutable, _) | Register _ -> - typ_error l ("Cannot shadow mutable local or register in switch statement mapping-pattern " ^ string_of_mpat mpat) + typ_error env l ("Cannot shadow mutable local or register in switch statement mapping-pattern " ^ string_of_mpat mpat) | Enum enum -> subtyp l env enum typ; annot_mpat (MP_id v) typ, env, [] end | MP_cons (hd_mpat, tl_mpat) -> @@ -3413,7 +3556,7 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) ( 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 - | _ -> typ_error l "Cannot match cons mapping-pattern against non-list type" + | _ -> typ_error env l "Cannot match cons mapping-pattern against non-list type" end | MP_string_append mpats -> begin @@ -3428,7 +3571,7 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) ( in let pats, env, guards = process_mpats env mpats in annot_mpat (MP_string_append pats) typ, env, guards - | _ -> typ_error l "Cannot match string-append pattern against non-string type" + | _ -> typ_error env l "Cannot match string-append pattern against non-string type" end | MP_list mpats -> begin @@ -3443,14 +3586,14 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) ( in let mpats, env, guards = process_mpats env mpats in annot_mpat (MP_list mpats) typ, env, guards - | _ -> typ_error l ("Cannot match list mapping-pattern " ^ string_of_mpat mpat ^ " against non-list type " ^ string_of_typ typ) + | _ -> typ_error env l ("Cannot match list mapping-pattern " ^ string_of_mpat mpat ^ " against non-list type " ^ string_of_typ typ) end | MP_tup [] -> begin match Env.expand_synonyms env typ with | Typ_aux (Typ_id typ_id, _) when string_of_id typ_id = "unit" -> annot_mpat (MP_tup []) typ, env, [] - | _ -> typ_error l "Cannot match unit mapping-pattern against non-unit type" + | _ -> typ_error env l "Cannot match unit mapping-pattern against non-unit type" end | MP_tup mpats -> begin @@ -3458,10 +3601,10 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) ( | Typ_aux (Typ_tup typs, _) -> let tpats, env, guards = try List.fold_left2 bind_tuple_mpat ([], env, []) mpats typs with - | Invalid_argument _ -> typ_error l "Tuple mapping-pattern and tuple type have different length" + | Invalid_argument _ -> typ_error env l "Tuple mapping-pattern and tuple type have different length" in annot_mpat (MP_tup (List.rev tpats)) typ, env, guards - | _ -> typ_error l "Cannot bind tuple mapping-pattern against non tuple type" + | _ -> typ_error env l "Cannot bind tuple mapping-pattern against non tuple type" end | MP_app (f, mpats) when Env.is_union_constructor f env -> begin @@ -3480,18 +3623,18 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) ( 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 mapping-pattern " ^ string_of_mpat mpat) + then typ_error env l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in mapping-pattern " ^ string_of_mpat mpat) else (); let ret_typ' = subst_unifiers unifiers ret_typ in let tpats, env, guards = try List.fold_left2 bind_tuple_mpat ([], env, []) mpats (untuple arg_typ') with - | Invalid_argument _ -> typ_error l "Union constructor mapping-pattern arguments have incorrect length" + | Invalid_argument _ -> typ_error env l "Union constructor mapping-pattern arguments have incorrect length" in annot_mpat (MP_app (f, List.rev tpats)) typ, env, guards with - | Unification_error (l, m) -> typ_error l ("Unification error when mapping-pattern matching against union constructor: " ^ m) + | Unification_error (l, m) -> typ_error env l ("Unification error when mapping-pattern matching against union constructor: " ^ m) end - | _ -> typ_error l ("Mal-formed constructor " ^ string_of_id f ^ " with type " ^ string_of_typ ctor_typ) + | _ -> typ_error env l ("Mal-formed constructor " ^ string_of_id f ^ " with type " ^ string_of_typ ctor_typ) end | MP_app (other, mpats) when Env.is_mapping other env -> begin @@ -3510,12 +3653,12 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) ( 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) - then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in mapping-pattern " ^ string_of_mpat mpat) + then typ_error env l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in mapping-pattern " ^ string_of_mpat mpat) else (); let ret_typ' = subst_unifiers unifiers typ2 in let tpats, env, guards = try List.fold_left2 bind_tuple_mpat ([], env, []) mpats (untuple arg_typ') with - | Invalid_argument _ -> typ_error l "Mapping pattern arguments have incorrect length" + | Invalid_argument _ -> typ_error env l "Mapping pattern arguments have incorrect length" in annot_mpat (MP_app (other, List.rev tpats)) typ, env, guards with @@ -3527,22 +3670,22 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) ( 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) - then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in mapping-pattern " ^ string_of_mpat mpat) + then typ_error env l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in mapping-pattern " ^ string_of_mpat mpat) else (); let ret_typ' = subst_unifiers unifiers typ1 in let tpats, env, guards = try List.fold_left2 bind_tuple_mpat ([], env, []) mpats (untuple arg_typ') with - | Invalid_argument _ -> typ_error l "Mapping pattern arguments have incorrect length" + | Invalid_argument _ -> typ_error env l "Mapping pattern arguments have incorrect length" in annot_mpat (MP_app (other, List.rev tpats)) typ, env, guards with - | Unification_error (l, m) -> typ_error l ("Unification error when pattern matching against mapping constructor: " ^ m) + | Unification_error (l, m) -> typ_error env l ("Unification error when pattern matching against mapping constructor: " ^ m) end | Typ_aux (typ, _) -> - typ_error l ("unifying mapping type, expanded synonyms to non-mapping type??") + typ_error env l ("unifying mapping type, expanded synonyms to non-mapping type??") end | MP_app (f, _) when not (Env.is_union_constructor f env || Env.is_mapping f env) -> - typ_error l (string_of_id f ^ " is not a union constructor or mapping in mapping-pattern " ^ string_of_mpat mpat) + typ_error env l (string_of_id f ^ " is not a union constructor or mapping in mapping-pattern " ^ string_of_mpat mpat) | MP_as (mpat, id) -> let (typed_mpat, env, guards) = bind_mpat allow_unknown other_env env mpat typ in (annot_mpat (MP_as (typed_mpat, id)) (typ_of_mpat typed_mpat), @@ -3552,6 +3695,13 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) ( | MP_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_mpat (MP_lit lit) (atom_typ (nconstant n)), Env.add_constraint (nc_eq nexp (nconstant n)) env, [] + (* Similarly, for boolean literals *) + | MP_lit (L_aux (L_true, _) as lit) when is_atom_bool typ -> + let nc = match destruct_atom_bool env typ with Some n -> n | None -> assert false in + annot_mpat (MP_lit lit) (atom_bool_typ nc_true), Env.add_constraint nc env, [] + | MP_lit (L_aux (L_false, _) as lit) when is_atom_bool typ -> + let nc = match destruct_atom_bool env typ with Some n -> n | None -> assert false in + annot_mpat (MP_lit lit) (atom_bool_typ nc_false), Env.add_constraint (nc_not nc) env, [] | _ -> let (inferred_mpat, env, guards) = infer_mpat allow_unknown other_env env mpat in match subtyp l env typ (typ_of_mpat inferred_mpat) with @@ -3565,7 +3715,7 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) ( typed_mpat, env, guard::guards | _ -> raise typ_exn and infer_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) = - let annot_mpat mpat typ = MP_aux (mpat, (l, Some ((env, typ, no_effect), None))) in + let annot_mpat mpat typ = MP_aux (mpat, (l, mk_tannot env typ no_effect)) in match mpat_aux with | MP_id v -> begin @@ -3575,11 +3725,11 @@ and infer_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) | Local (Immutable, typ) -> bind_mpat allow_unknown other_env env (mk_mpat (MP_typ (mk_mpat (MP_id v), typ))) typ | Unbound -> if allow_unknown then annot_mpat (MP_id v) unknown_typ, env, [] else - typ_error l ("Cannot infer identifier in mapping-pattern " ^ string_of_mpat mpat ^ " - try adding a type annotation") + typ_error env l ("Cannot infer identifier in mapping-pattern " ^ string_of_mpat mpat ^ " - try adding a type annotation") | _ -> assert false end | Local (Mutable, _) | Register _ -> - typ_error l ("Cannot shadow mutable local or register in mapping-pattern " ^ string_of_mpat mpat) + typ_error env l ("Cannot shadow mutable local or register in mapping-pattern " ^ string_of_mpat mpat) | Enum enum -> annot_mpat (MP_id v) enum, env, [] end | MP_app (f, mpats) when Env.is_union_constructor f env -> @@ -3588,7 +3738,7 @@ and infer_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) match Env.expand_synonyms env ctor_typ with | Typ_aux (Typ_fn (arg_typ, ret_typ, _), _) -> bind_mpat allow_unknown other_env env mpat ret_typ - | _ -> typ_error l ("Mal-formed constructor " ^ string_of_id f) + | _ -> typ_error env l ("Mal-formed constructor " ^ string_of_id f) end | MP_app (f, mpats) when Env.is_mapping f env -> begin @@ -3602,7 +3752,7 @@ and infer_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) | Type_error _ -> bind_mpat allow_unknown other_env env mpat typ1 end - | _ -> typ_error l ("Malformed mapping type " ^ string_of_id f) + | _ -> typ_error env l ("Malformed mapping type " ^ string_of_id f) end | MP_lit lit -> annot_mpat (MP_lit lit) (infer_lit env lit), env, [] @@ -3655,20 +3805,20 @@ and infer_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) guards) | _ -> - typ_error l ("Couldn't infer type of mapping-pattern " ^ string_of_mpat mpat) + typ_error env l ("Couldn't infer type of mapping-pattern " ^ string_of_mpat mpat) (**************************************************************************) (* 5. Effect system *) (**************************************************************************) let effect_of_annot = function -| Some ((_, _, eff), _) -> eff +| Some t -> t.effect | None -> no_effect let effect_of (E_aux (exp, (l, annot))) = effect_of_annot annot let add_effect_annot annot eff = match annot with - | Some ((env, typ, eff'), exp_typ) -> Some ((env, typ, union_effects eff eff'), exp_typ) + | Some tannot -> Some { tannot with effect = union_effects eff tannot.effect } | None -> None let add_effect (E_aux (exp, (l, annot))) eff = @@ -3829,8 +3979,8 @@ and propagate_exp_effect_aux = function | E_internal_return exp -> let p_exp = propagate_exp_effect exp in E_internal_return p_exp, effect_of p_exp - | exp_aux -> typ_error Parse_ast.Unknown ("Unimplemented: Cannot propagate effect in expression " - ^ string_of_exp (E_aux (exp_aux, (Parse_ast.Unknown, None)))) + | exp_aux -> typ_error Env.empty Parse_ast.Unknown ("Unimplemented: Cannot propagate effect in expression " + ^ string_of_exp (E_aux (exp_aux, (Parse_ast.Unknown, None)))) and propagate_fexp_effect (FE_aux (FE_Fexp (id, exp), (l, _))) = let p_exp = propagate_exp_effect exp in @@ -3843,9 +3993,9 @@ and propagate_pexp_effect = function let p_exp = propagate_exp_effect exp in let p_eff = union_effects (effect_of_pat p_pat) (effect_of p_exp) in match annot with - | Some ((typq, typ, eff), exp_typ) -> - Pat_aux (Pat_exp (p_pat, p_exp), (l, Some ((typq, typ, union_effects eff p_eff), exp_typ))), - union_effects eff p_eff + | Some tannot -> + Pat_aux (Pat_exp (p_pat, p_exp), (l, Some { tannot with effect = union_effects tannot.effect p_eff })), + union_effects tannot.effect p_eff | None -> Pat_aux (Pat_exp (p_pat, p_exp), (l, None)), p_eff end | Pat_aux (Pat_when (pat, guard, exp), (l, annot)) -> @@ -3857,9 +4007,9 @@ and propagate_pexp_effect = function (union_effects (effect_of p_guard) (effect_of p_exp)) in match annot with - | Some ((typq, typ, eff), exp_typ) -> - Pat_aux (Pat_when (p_pat, p_guard, p_exp), (l, Some ((typq, typ, union_effects eff p_eff), exp_typ))), - union_effects eff p_eff + | Some tannot -> + Pat_aux (Pat_when (p_pat, p_guard, p_exp), (l, Some { tannot with effect = union_effects tannot.effect p_eff })), + union_effects tannot.effect p_eff | None -> Pat_aux (Pat_when (p_pat, p_guard, p_exp), (l, None)), p_eff end @@ -3869,9 +4019,9 @@ and propagate_mpexp_effect = function let p_mpat = propagate_mpat_effect mpat in let p_eff = effect_of_mpat p_mpat in match annot with - | Some ((typq, typ, eff), exp_typ) -> - MPat_aux (MPat_pat p_mpat, (l, Some ((typq, typ, union_effects eff p_eff), exp_typ))), - union_effects eff p_eff + | Some tannot -> + MPat_aux (MPat_pat p_mpat, (l, Some { tannot with effect = union_effects tannot.effect p_eff })), + union_effects tannot.effect p_eff | None -> MPat_aux (MPat_pat p_mpat, (l, None)), p_eff end | MPat_aux (MPat_when (mpat, guard), (l, annot)) -> @@ -3881,9 +4031,9 @@ and propagate_mpexp_effect = function let p_eff = union_effects (effect_of_mpat p_mpat) (effect_of p_guard) in match annot with - | Some ((typq, typ, eff), exp_typ) -> - MPat_aux (MPat_when (p_mpat, p_guard), (l, Some ((typq, typ, union_effects eff p_eff), exp_typ))), - union_effects eff p_eff + | Some tannot -> + MPat_aux (MPat_when (p_mpat, p_guard), (l, Some { tannot with effect = union_effects tannot.effect p_eff })), + union_effects tannot.effect p_eff | None -> MPat_aux (MPat_when (p_mpat, p_guard), (l, None)), p_eff end @@ -3932,7 +4082,7 @@ and propagate_pat_effect_aux = function | P_vector pats -> let p_pats = List.map propagate_pat_effect pats in P_vector p_pats, collect_effects_pat p_pats - | _ -> typ_error Parse_ast.Unknown "Unimplemented: Cannot propagate effect in pat" + | _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented: Cannot propagate effect in pat") and propagate_mpat_effect (MP_aux (mpat, annot)) = let p_mpat, eff = propagate_mpat_effect_aux mpat in @@ -3968,12 +4118,12 @@ and propagate_mpat_effect_aux = function | MP_as (mpat, id) -> let p_mpat = propagate_mpat_effect mpat in MP_as (p_mpat, id), effect_of_mpat mpat - | _ -> typ_error Parse_ast.Unknown "Unimplemented: Cannot propagate effect in mpat" + | _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented: Cannot propagate effect in mpat") and propagate_letbind_effect (LB_aux (lb, (l, annot))) = let p_lb, eff = propagate_letbind_effect_aux lb in match annot with - | Some ((typq, typ, eff), exp_typ) -> LB_aux (p_lb, (l, Some ((typq, typ, eff), exp_typ))), eff + | Some tannot -> LB_aux (p_lb, (l, Some { tannot with effect = eff })), eff | None -> LB_aux (p_lb, (l, None)), eff and propagate_letbind_effect_aux = function | LB_val (pat, exp) -> @@ -4028,14 +4178,14 @@ let check_letdef orig_env (LB_aux (letbind, (l, _))) = if (BESet.is_empty (effect_set (effect_of checked_bind)) || !opt_no_effects) then [DEF_val (LB_aux (LB_val (tpat, checked_bind), (l, None)))], env - else typ_error l ("Top-level definition with effects " ^ string_of_effect (effect_of checked_bind)) + else typ_error env l ("Top-level definition with effects " ^ string_of_effect (effect_of checked_bind)) | LB_val (pat, bind) -> let inferred_bind = propagate_exp_effect (irule infer_exp orig_env (strip_exp bind)) in let tpat, env = bind_pat_no_guard orig_env (strip_pat pat) (typ_of inferred_bind) in if (BESet.is_empty (effect_set (effect_of inferred_bind)) || !opt_no_effects) then [DEF_val (LB_aux (LB_val (tpat, inferred_bind), (l, None)))], env - else typ_error l ("Top-level definition with effects " ^ string_of_effect (effect_of inferred_bind)) + else typ_error env l ("Top-level definition with effects " ^ string_of_effect (effect_of inferred_bind)) end let check_funcl env (FCL_aux (FCL_Funcl (id, pexp), (l, _))) typ = @@ -4064,9 +4214,9 @@ let check_funcl env (FCL_aux (FCL_Funcl (id, pexp), (l, _))) typ = | _ -> propagate_pexp_effect (check_case env (Typ_aux (Typ_tup typ_args, l)) (strip_pexp pexp) typ_ret) in - FCL_aux (FCL_Funcl (id, typed_pexp), (l, Some ((env, typ, prop_eff), Some typ))) + FCL_aux (FCL_Funcl (id, typed_pexp), (l, mk_expected_tannot env typ prop_eff (Some typ))) end - | _ -> typ_error l ("Function clause must have function type: " ^ string_of_typ typ ^ " is not a function type") + | _ -> typ_error env l ("Function clause must have function type: " ^ string_of_typ typ ^ " is not a function type") let check_mapcl : 'a. Env.t -> 'a mapcl -> typ -> tannot mapcl = @@ -4083,7 +4233,7 @@ let check_mapcl : 'a. Env.t -> 'a mapcl -> typ -> tannot mapcl = let typed_mpexp1, prop_eff1 = propagate_mpexp_effect (check_mpexp right_id_env env (strip_mpexp mpexp1) typ1) in let typed_mpexp2, prop_eff2 = propagate_mpexp_effect (check_mpexp left_id_env env (strip_mpexp mpexp2) typ2) in - MCL_aux (MCL_bidir (typed_mpexp1, typed_mpexp2), (l, Some ((env, typ, union_effects prop_eff1 prop_eff2), Some typ))) + MCL_aux (MCL_bidir (typed_mpexp1, typed_mpexp2), (l, mk_expected_tannot env typ (union_effects prop_eff1 prop_eff2) (Some typ))) end | MCL_forwards (mpexp, exp) -> begin let mpat, _, _ = destruct_mpexp mpexp in @@ -4091,7 +4241,7 @@ let check_mapcl : 'a. Env.t -> 'a mapcl -> typ -> tannot mapcl = let typed_mpexp, prop_eff1 = propagate_mpexp_effect (check_mpexp Env.empty env (strip_mpexp mpexp) typ1) in let typed_exp = propagate_exp_effect (check_exp mpat_env (strip_exp exp) typ2) in let prop_effs = union_effects prop_eff1 (effect_of typed_exp) in - MCL_aux (MCL_forwards (typed_mpexp, typed_exp), (l, Some ((env, typ, prop_effs), Some typ))) + MCL_aux (MCL_forwards (typed_mpexp, typed_exp), (l, mk_expected_tannot env typ prop_effs (Some typ))) end | MCL_backwards (mpexp, exp) -> begin let mpat, _, _ = destruct_mpexp mpexp in @@ -4099,20 +4249,19 @@ let check_mapcl : 'a. Env.t -> 'a mapcl -> typ -> tannot mapcl = let typed_mpexp, prop_eff1 = propagate_mpexp_effect (check_mpexp Env.empty env (strip_mpexp mpexp) typ2) in let typed_exp = propagate_exp_effect (check_exp mpat_env (strip_exp exp) typ1) in let prop_effs = union_effects prop_eff1 (effect_of typed_exp) in - MCL_aux (MCL_backwards (typed_mpexp, typed_exp), (l, Some ((env, typ, prop_effs), Some typ))) + MCL_aux (MCL_backwards (typed_mpexp, typed_exp), (l, mk_expected_tannot 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 env 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 - | Some ((_, _, eff), _) -> eff + | Some t -> t.effect | None -> no_effect (* Maybe could be assert false. This should never happen *) - let mapcl_effect (MCL_aux (_, (l, annot))) = match annot with - | Some ((_, _, eff), _) -> eff + | Some t -> t.effect | None -> no_effect (* Maybe could be assert false. This should never happen *) let infer_funtyp l env tannotopt funcls = @@ -4124,7 +4273,7 @@ let infer_funtyp l env tannotopt funcls = | P_lit lit -> infer_lit env lit | P_typ (typ, _) -> typ | P_tup pats -> mk_typ (Typ_tup (List.map typ_from_pat pats)) - | _ -> typ_error l ("Cannot infer type from pattern " ^ string_of_pat pat) + | _ -> typ_error env l ("Cannot infer type from pattern " ^ string_of_pat pat) in match funcls with | [FCL_aux (FCL_Funcl (_, Pat_aux (pexp,_)), _)] -> @@ -4139,9 +4288,9 @@ let infer_funtyp l env tannotopt funcls = in let fn_typ = mk_typ (Typ_fn (arg_typs, ret_typ, Effect_aux (Effect_set [], Parse_ast.Unknown))) in (quant, fn_typ) - | _ -> typ_error l "Cannot infer function type for function with multiple clauses" + | _ -> typ_error env l "Cannot infer function type for function with multiple clauses" end - | Typ_annot_opt_aux (Typ_annot_opt_none, _) -> typ_error l "Cannot infer function type for unannotated function" + | Typ_annot_opt_aux (Typ_annot_opt_none, _) -> typ_error env l "Cannot infer function type for unannotated function" let mk_val_spec env typq typ id = let eff = @@ -4149,14 +4298,14 @@ let mk_val_spec env typq typ id = | Typ_aux (Typ_fn (_,_,eff),_) -> eff | _ -> no_effect in - DEF_spec (VS_aux (VS_val_spec (TypSchm_aux (TypSchm_ts (typq, typ), Parse_ast.Unknown), id, (fun _ -> None), false), (Parse_ast.Unknown, Some ((env,typ,eff),None)))) + DEF_spec (VS_aux (VS_val_spec (TypSchm_aux (TypSchm_ts (typq, typ), Parse_ast.Unknown), id, (fun _ -> None), false), (Parse_ast.Unknown, mk_tannot env typ eff))) let check_tannotopt env typq ret_typ = function | Typ_annot_opt_aux (Typ_annot_opt_none, _) -> () | Typ_annot_opt_aux (Typ_annot_opt_some (annot_typq, annot_ret_typ), l) -> if typ_identical env ret_typ annot_ret_typ then () - else typ_error l (string_of_bind (typq, ret_typ) ^ " and " ^ string_of_bind (annot_typq, annot_ret_typ) ^ " do not match between function and val spec") + else typ_error env l (string_of_bind (typq, ret_typ) ^ " and " ^ string_of_bind (annot_typq, annot_ret_typ) ^ " do not match between function and val spec") let check_termination_measure env arg_typs pat exp = let typ = match arg_typs with [x] -> x | _ -> Typ_aux (Typ_tup arg_typs,Unknown) in @@ -4168,7 +4317,7 @@ let check_termination_measure_decl env (id, pat, exp) = let quant, typ = Env.get_val_spec id env in let arg_typs, l = match typ with | Typ_aux (Typ_fn (arg_typs, _ ,_),l) -> arg_typs,l - | _ -> typ_error (id_loc id) "Function val spec is not a function type" + | _ -> typ_error env (id_loc id) "Function val spec is not a function type" in let env = add_typquant l quant env in let tpat, texp = check_termination_measure env arg_typs pat exp in @@ -4180,23 +4329,23 @@ let check_fundef env (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls) (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 typ_error l ("Function declaration expects all definitions to have the same name, " + else typ_error env 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 -> typ_error l "funcl list is empty" + | None -> typ_error env l "funcl list is empty" in 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, _) -> + | Type_error (_, l, _) -> let (quant, typ) = infer_funtyp l env tannotopt funcls in false, (quant, typ), env 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 is not a function type" + | _ -> typ_error env 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))); @@ -4222,14 +4371,14 @@ let check_fundef env (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls) if (equal_effects eff declared_eff || !opt_no_effects) then vs_def @ [DEF_fundef (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls), (l, None)))], env - else typ_error l ("Effects do not match: " ^ string_of_effect declared_eff ^ " declared and " ^ string_of_effect eff ^ " found") + else typ_error env l ("Effects do not match: " ^ string_of_effect declared_eff ^ " declared and " ^ string_of_effect eff ^ " found") let check_mapdef env (MD_aux (MD_mapping (id, tannot_opt, mapcls), (l, _)) as md_aux) = typ_print (lazy ("\nChecking mapping " ^ string_of_id id)); let have_val_spec, (quant, typ), env = try true, Env.get_val_spec id env, env with - | Type_error (l, _) as err -> + | Type_error (_, l, _) as err -> match tannot_opt with | Typ_annot_opt_aux (Typ_annot_opt_some (quant, typ), _) -> false, (quant, typ), env @@ -4238,18 +4387,18 @@ let check_mapdef env (MD_aux (MD_mapping (id, tannot_opt, mapcls), (l, _)) as md in let vtyp1, vtyp2, vl = match typ with | Typ_aux (Typ_bidir (vtyp1, vtyp2), vl) -> vtyp1, vtyp2, vl - | _ -> typ_error l "Mapping val spec was not a mapping type" + | _ -> typ_error env l "Mapping val spec was not a mapping type" in begin match tannot_opt with | Typ_annot_opt_aux (Typ_annot_opt_none, _) -> () | Typ_annot_opt_aux (Typ_annot_opt_some (annot_typq, annot_typ), l) -> if typ_identical env typ annot_typ then () - else typ_error l (string_of_bind (quant, typ) ^ " and " ^ string_of_bind (annot_typq, annot_typ) ^ " do not match between mapping and val spec") + else typ_error env l (string_of_bind (quant, typ) ^ " and " ^ string_of_bind (annot_typq, annot_typ) ^ " do not match between mapping and val spec") end; typ_debug (lazy ("Checking mapdef " ^ string_of_id id ^ " has type " ^ string_of_bind (quant, typ))); let vs_def, env = if not have_val_spec then - [mk_val_spec env quant typ id], Env.add_val_spec id (quant, typ) env + [mk_val_spec env quant (Env.expand_synonyms env typ) id], Env.add_val_spec id (quant, typ) env else [], env in @@ -4260,13 +4409,13 @@ let check_mapdef env (MD_aux (MD_mapping (id, tannot_opt, mapcls), (l, _)) as md if equal_effects eff no_effect || equal_effects eff (mk_effect [BE_escape]) || !opt_no_effects then vs_def @ [DEF_mapdef (MD_aux (MD_mapping (id, tannot_opt, mapcls), (l, None)))], env else - typ_error l ("Mapping not pure (or escape only): " ^ string_of_effect eff ^ " found") + typ_error env 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. *) let check_val_spec env (VS_aux (vs, (l, _))) = - let annotate vs typ eff = DEF_spec (VS_aux (vs, (l, Some ((env, typ, eff), None)))) in + let annotate vs typ eff = DEF_spec (VS_aux (vs, (l, mk_tannot env typ eff))) in 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)); @@ -4292,7 +4441,7 @@ let check_default env (DT_aux (ds, l)) = match ds with | DT_order (Ord_aux (Ord_inc, _)) -> [DEF_default (DT_aux (ds, l))], Env.set_default_order_inc env | DT_order (Ord_aux (Ord_dec, _)) -> [DEF_default (DT_aux (ds, l))], Env.set_default_order_dec env - | DT_order (Ord_aux (Ord_var _, _)) -> typ_error l "Cannot have variable default order" + | DT_order (Ord_aux (Ord_var _, _)) -> typ_error env l "Cannot have variable default order" let kinded_id_arg kind_id = let typ_arg arg = A_aux (arg, Parse_ast.Unknown) in @@ -4315,7 +4464,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 K_type) (KidSet.elements (typ_frees typ))) in + let typq = mk_typquant (List.map (mk_qi_id K_type) (KidSet.elements (tyvars_of_typ typ))) in env |> Env.add_union_id v (typq, typ) |> Env.add_val_spec v (typq, typ) @@ -4348,41 +4497,33 @@ let mk_synonym typq typ_arg = let typ_arg, ncs = subst_args kopts args in typ_arg_subst (kopt_kid kopt) (arg_bool arg) typ_arg, ncs | [], [] -> typ_arg, ncs - | _, A_aux (_, l) :: _ -> typ_error l "Synonym applied to bad arguments" - | _, _ -> typ_error Parse_ast.Unknown "Synonym applied to bad arguments" + | _, A_aux (_, l) :: _ -> typ_error Env.empty l "Synonym applied to bad arguments" + | _, _ -> typ_error Env.empty Parse_ast.Unknown "Synonym applied to bad arguments" in fun env args -> let typ_arg, ncs = subst_args kopts args in - if List.for_all (prove env) ncs + if List.for_all (prove __POS__ env) ncs then typ_arg - else typ_error Parse_ast.Unknown ("Could not prove constraints " ^ string_of_list ", " string_of_n_constraint ncs + else typ_error env Parse_ast.Unknown ("Could not prove constraints " ^ string_of_list ", " string_of_n_constraint ncs ^ " 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, _))) = - let kd_err () = raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented kind def") in - match kdef with - | 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 () - 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) -> [DEF_type (TD_aux (tdef, (l, None)))], Env.add_typ_synonym id (mk_synonym typq typ_arg) env - | TD_record (id, nmscm, typq, fields, _) -> + | TD_record (id, typq, fields, _) -> [DEF_type (TD_aux (tdef, (l, None)))], Env.add_record id typq fields env - | TD_variant (id, nmscm, typq, arms, _) -> + | TD_variant (id, typq, arms, _) -> let env = env |> Env.add_variant id (typq, arms) |> (fun env -> List.fold_left (fun env tu -> check_type_union env id typq tu) env arms) in [DEF_type (TD_aux (tdef, (l, None)))], env - | TD_enum (id, nmscm, ids, _) -> + | TD_enum (id, ids, _) -> [DEF_type (TD_aux (tdef, (l, None)))], Env.add_enum id ids env | TD_bitfield (id, typ, ranges) -> let typ = Env.expand_synonyms env typ in @@ -4397,15 +4538,15 @@ let rec check_typedef : 'a. Env.t -> 'a type_def -> (tannot def) list * Env.t = let (Defs defs), env = check env (Bitfield.macro id size order ranges) in defs, env | _ -> - typ_error l "Bad bitfield type" + typ_error env 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_variant (id, typq) -> + [DEF_scattered (SD_aux (SD_variant (id, 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 @@ -4426,7 +4567,6 @@ 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 match def with - | DEF_kind kdef -> check_kinddef env kdef | DEF_type tdef -> check_typedef env tdef | DEF_fixity (prec, n, op) -> [DEF_fixity (prec, n, op)], env | DEF_fundef fdef -> check_fundef env fdef @@ -4442,31 +4582,35 @@ and check_def : 'a. Env.t -> 'a def -> (tannot def) list * Env.t = | DEF_spec vs -> check_val_spec env vs | DEF_default default -> check_default env default | DEF_overload (id, ids) -> [DEF_overload (id, ids)], Env.add_overloads id ids env - | DEF_reg_dec (DEC_aux (DEC_reg (typ, id), (l, _))) -> - let env = Env.add_register id (mk_effect [BE_rreg]) (mk_effect [BE_wreg]) typ env in - [DEF_reg_dec (DEC_aux (DEC_reg (typ, id), (l, Some ((env, typ, no_effect), Some typ))))], env + | DEF_reg_dec (DEC_aux (DEC_reg (reffect, weffect, typ, id), (l, _))) -> + let env = Env.add_register id reffect weffect typ env in + [DEF_reg_dec (DEC_aux (DEC_reg (reffect, weffect, typ, id), (l, mk_expected_tannot env typ no_effect (Some typ))))], env | DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp), (l, _))) -> 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_reg_dec (DEC_aux (DEC_config (id, typ, checked_exp), (l, mk_expected_tannot 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 sdef -> check_scattered env sdef | DEF_measure (id, pat, exp) -> [check_termination_measure_decl env (id, pat, exp)], env -and check : 'a. Env.t -> 'a defs -> tannot defs * Env.t = - fun env (Defs defs) -> +and check_defs : 'a. int -> int -> Env.t -> 'a def list -> tannot defs * Env.t = + fun n total env defs -> match defs with - | [] -> (Defs []), env + | [] -> Defs [], env | def :: defs -> + Util.progress "Type check " (string_of_int n ^ "/" ^ string_of_int total) n total; let (def, env) = check_def env def in - let (Defs defs, env) = check env (Defs defs) in - (Defs (def @ defs)), env + let Defs defs, env = check_defs (n + 1) total env defs in + Defs (def @ defs), env + +and check : 'a. Env.t -> 'a defs -> tannot defs * Env.t = + fun env (Defs defs) -> let total = List.length defs in check_defs 1 total env defs let initial_env = Env.empty - |> Env.add_prover prove + |> Env.add_prover (prove __POS__) (* |> Env.add_typ_synonym (mk_id "atom") (fun _ args -> mk_typ (Typ_app (mk_id "range", args @ args))) *) (* Internal functions for Monomorphise.AtomToItself *) diff --git a/src/type_check.mli b/src/type_check.mli index 81682606..7a5a3446 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -80,9 +80,11 @@ 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 + | Err_because of type_error * Ast.l * type_error -exception Type_error of l * type_error;; +type env + +exception Type_error of env * l * type_error;; val typ_debug : ?level:int -> string Lazy.t -> unit val typ_print : string Lazy.t -> unit @@ -93,7 +95,7 @@ val typ_print : string Lazy.t -> unit contains functions that operate on that state. *) module Env : sig (** Env.t is the type of environments *) - type t + type t = env (** Note: Most get_ functions assume the identifiers exist, and throw type errors if they don't. *) @@ -182,6 +184,8 @@ module Env : sig old one. *) val fresh_kid : ?kid:kid -> t -> kid + val expand_constraint_synonyms : t -> n_constraint -> n_constraint + val expand_synonyms : t -> typ -> typ (** Expand type synonyms and remove register annotations (i.e. register<t> -> t)) *) @@ -212,8 +216,8 @@ val add_typquant : Ast.l -> typquant -> Env.t -> Env.t is not existential. This function will pick a fresh name for the 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 destruct_exist_plain : ?name:string option -> typ -> (kinded_id list * n_constraint * typ) option +val destruct_exist : ?name:string option -> typ -> (kinded_id list * n_constraint * typ) option val add_existential : Ast.l -> kinded_id list -> n_constraint -> Env.t -> Env.t @@ -301,7 +305,7 @@ val check_fundef : Env.t -> 'a fundef -> tannot def list * Env.t val check_val_spec : Env.t -> 'a val_spec -> tannot def list * Env.t -val prove : Env.t -> n_constraint -> bool +val prove : (string * int * int * int) -> Env.t -> n_constraint -> bool val solve : Env.t -> nexp -> Big_int.num option @@ -316,7 +320,7 @@ val bind_pat : Env.t -> unit pat -> typ -> tannot pat * Env.t * unit Ast.exp lis on patterns that have previously been type checked. *) val bind_pat_no_guard : Env.t -> unit pat -> typ -> tannot pat * Env.t -val typ_error : Ast.l -> string -> 'a +val typ_error : Env.t -> Ast.l -> string -> 'a (** {2 Destructuring type annotations} Partial functions: The expressions and patterns passed to these functions must be @@ -356,7 +360,7 @@ val destruct_atom_nexp : Env.t -> typ -> nexp option val destruct_range : Env.t -> typ -> (kid list * n_constraint * nexp * nexp) option -val destruct_numeric : typ -> (kid list * n_constraint * nexp) option +val destruct_numeric : ?name:string option -> typ -> (kid list * n_constraint * nexp) option val destruct_vector : Env.t -> typ -> (nexp * order * typ) option diff --git a/src/type_error.ml b/src/type_error.ml index 9144e993..e75d2cd4 100644 --- a/src/type_error.ml +++ b/src/type_error.ml @@ -48,63 +48,16 @@ (* SUCH DAMAGE. *) (**************************************************************************) -open PPrint open Util open Ast open Ast_util open Type_check -let bullet f xs = - group (separate_map hardline (fun x -> string "* " ^^ nest 2 (f x)) xs) - -let pp_nexp, pp_n_constraint = - let pp_nexp' nexp = - string (string_of_nexp nexp) - in - - 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_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 +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 @@ -126,7 +79,7 @@ let rec analyze_unresolved_quant2 locals ncs = function | _ -> [] 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 + let nc = List.fold_left (fun nc (v, nexp) -> constraint_subst v (arg_nexp nexp) nc) nc substs in if not (KidSet.exists is_kid_generated (tyvars_of_constraint nc)) then Suggest_add_constraint nc else @@ -140,7 +93,7 @@ let rec analyze_unresolved_quant2 locals ncs = function [] 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 + let nc = List.fold_left (fun nc (v, nexp, _) -> constraint_subst v (arg_nexp nexp) nc) nc substs in if not (KidSet.exists is_kid_generated (tyvars_of_constraint nc)) then Suggest_none else @@ -149,124 +102,89 @@ let rec analyze_unresolved_quant2 locals ncs = function | 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 - 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, [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)) -> - [] - 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 +let message_of_type_error = + let open Error_format in + let rec msg = function + | Err_because (err, l', err') -> + Seq [msg err; + Line "This error occured because of a previous error:"; + Location (l', msg err')] - | QI_aux (QI_id kopt, _) -> - empty + | Err_other str -> Line str -let rec pp_type_error = function - | 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 "Coercion failed because:" ^//^ pp_type_error trigger) - ^^ if not (reasons = []) then - hardline - ^^ (string "Possible reasons:" ^//^ separate_map hardline pp_type_error reasons) - else - empty + | Err_no_overloading (id, errs) -> + Seq [Line ("No overloading for " ^ string_of_id id ^ ", tried:"); + List (List.map (fun (id, err) -> string_of_id id, msg err) errs)] - | 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_unresolved_quants (id, quants, locals, ncs) -> + Seq [Line ("Could not resolve quantifiers for " ^ string_of_id id); + Line (bullet ^ " " ^ Util.string_of_list ("\n" ^ bullet ^ " ") string_of_quant_item quants)] - | Err_subtype (typ1, typ2, constrs, locs) -> - (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" - ^/^ bullet (fun (kid, l) -> string (string_of_kid kid ^ " bound at " ^ Reporting.loc_to_string l ^ "\n")) (KBindings.bindings locs) + | Err_subtype (typ1, typ2, _, vars) -> + let vars = KBindings.bindings vars in + let vars = List.filter (fun (v, _) -> KidSet.mem v (KidSet.union (tyvars_of_typ typ1) (tyvars_of_typ typ2))) vars in + With ((fun ppf -> { ppf with loc_color = Util.yellow }), + Seq (Line (string_of_typ typ1 ^ " is not a subtype of " ^ string_of_typ typ2) + :: List.map (fun (kid, l) -> Location (l, Line (string_of_kid kid ^ " bound here"))) vars)) | Err_no_num_ident id -> - string "No num identifier" ^^ space ^^ string (string_of_id id) - - | 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) + Line ("No num identifier " ^ string_of_id id) - (* 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 + | Err_no_casts (exp, typ_from, typ_to, trigger, reasons) -> + let coercion = + Line ("Tried performing type coercion from " ^ string_of_typ typ_from + ^ " to " ^ string_of_typ typ_to + ^ " on " ^ string_of_exp exp) + in + Seq ([coercion; Line "Coercion failed because:"; msg trigger] + @ if not (reasons = []) then + Line "Possible reasons:" :: List.map msg reasons + else + []) + in + msg let rec string_of_type_error err = - let open PPrint in + let open Error_format in let b = Buffer.create 20 in - ToBuffer.pretty 1. 400 b (pp_type_error err); - "\n" ^ Buffer.contents b + format_message (message_of_type_error err) (buffer_formatter b); + 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_no_overloading (_, errs) as no_collapse) -> + let errs = List.map (fun (_, err) -> collapse_errors err) errs in + let interesting = function + | Err_other _ -> false + | Err_no_casts _ -> false + | _ -> true + in + begin match List.filter interesting errs with + | err :: errs -> + let fold_equal msg err = + match msg, err with + | Some msg, Err_no_overloading _ -> 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 + | [] -> no_collapse + end + | Err_because (err1, l, err2) as no_collapse -> + let err1 = collapse_errors err1 in + let err2 = collapse_errors err2 in + if string_of_type_error err1 = string_of_type_error err2 then + err1 + else + Err_because (err1, l, err2) | err -> 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.err_typ l (string_of_type_error err)) + | Type_error (env, l, err) -> + Interactive.env := env; + raise (Reporting.err_typ l (string_of_type_error err)) diff --git a/src/util.ml b/src/util.ml index 5e5654d1..0ff00df1 100644 --- a/src/util.ml +++ b/src/util.ml @@ -96,6 +96,7 @@ let opt_warnings = ref true let opt_colors = ref true +let opt_verbosity = ref 0 let rec last = function | [x] -> x @@ -465,3 +466,32 @@ 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) '=' + +let verbose_endline level str = + if level >= !opt_verbosity then + prerr_endline str + else + () + +let progress prefix msg n total = + if !opt_verbosity > 0 then + let len = truncate ((float n /. float total) *. 50.0) in + let percent = truncate ((float n /. float total) *. 100.0) in + let msg = + if String.length msg <= 20 then + msg ^ ")" ^ String.make (20 - String.length msg) ' ' + else + String.sub msg 0 17 ^ "...)" + in + let str = prefix ^ "[" ^ String.make len '=' ^ String.make (50 - len) ' ' ^ "] " + ^ string_of_int percent ^ "%" + ^ " (" ^ msg + in + prerr_string str; + if n = total then + prerr_char '\n' + else + prerr_string ("\x1B[" ^ string_of_int (String.length str) ^ "D"); + flush stderr + else + () diff --git a/src/util.mli b/src/util.mli index fd0242a3..51504941 100644 --- a/src/util.mli +++ b/src/util.mli @@ -53,6 +53,7 @@ val last : 'a list -> 'a val opt_warnings : bool ref val opt_colors : bool ref +val opt_verbosity : int ref val butlast : 'a list -> 'a list @@ -263,3 +264,5 @@ val file_encode_string : string -> string val log_line : string -> int -> string -> string val header : string -> int -> string + +val progress : string -> string -> int -> int -> unit |