diff options
Diffstat (limited to 'src')
76 files changed, 4203 insertions, 4211 deletions
@@ -1,6 +1,6 @@ # META file of package sail: description = "Sail is a language for describing the instruction-set architecture (ISA) semantics of processors." -requires = "linenoise lem linksem omd base64 yojson" +requires = "linenoise lem linksem omd base64 yojson pprint" version = "0.8" archive(byte) = "libsail.cma" archive(native) = "libsail.cmxa" diff --git a/src/Makefile b/src/Makefile index a002d4f3..00475654 100644 --- a/src/Makefile +++ b/src/Makefile @@ -72,7 +72,11 @@ all: sail lib doc full: sail lib doc ast.lem: ../language/sail.ott - ott -sort false -generate_aux_rules true -o ast.lem -picky_multiple_parses true ../language/sail.ott + ott -sort false -generate_aux_rules true -o ast.lem -picky_multiple_parses true ../language/sail.ott + +sail_pp.ml: ../language/sail.ott + ott -sort false -generate_aux_rules true -picky_multiple_parses true -ocaml_pp sail_pp.ml ../language/sail.ott + jib.lem: ../language/jib.ott ast.lem ott -sort false -generate_aux_rules true -o jib.lem -picky_multiple_parses true ../language/jib.ott @@ -2,17 +2,16 @@ true: -traverse, debug, use_menhir <**/parser.ml>: bin_annot, annot <**/*.ml> and not <**/parser.ml>: bin_annot, annot -<sail.{byte,native}>: package(zarith), package(linksem), package(lem), package(omd), package(base64), use_pprint -<isail.{byte,native}>: package(zarith), package(linenoise), package(linksem), package(lem), package(omd), package(base64), package(yojson), use_pprint +<sail.{byte,native}>: package(zarith), package(linksem), package(lem), package(omd), package(base64), package(pprint) +<isail.{byte,native}>: package(zarith), package(linenoise), package(linksem), package(lem), package(omd), package(base64), package(yojson), package(pprint) <isail.ml>: package(linenoise), package(yojson) <elf_loader.ml>: package(linksem) <latex.ml>: package(omd) -<**/*.m{l,li}>: package(lem), package(base64) +<**/*.m{l,li}>: package(lem), package(base64), package(pprint) <gen_lib>: include <jib>: include -<pprint> or <pprint/src>: include # disable partial match and unused variable warnings <**/*.ml>: warn_y diff --git a/src/ast_util.ml b/src/ast_util.ml index 065b443c..e318a423 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -60,7 +60,7 @@ let lvar_typ = function | Local (_, typ) -> typ | Register (_, _, typ) -> typ | Enum typ -> typ - | Unbound -> failwith "No type for unbound variable" + | Unbound -> Reporting.unreachable Parse_ast.Unknown __POS__ "No type for unbound variable" let no_annot = (Parse_ast.Unknown, ()) @@ -847,7 +847,7 @@ and string_of_typ_aux = function | Typ_fn (typ_args, typ_ret, eff) -> "(" ^ string_of_list ", " string_of_typ typ_args ^ ") -> " ^ string_of_typ typ_ret ^ " effect " ^ string_of_effect eff - | Typ_bidir (typ1, typ2) -> string_of_typ typ1 ^ " <-> " ^ string_of_typ typ2 + | Typ_bidir (typ1, typ2, eff) -> string_of_typ typ1 ^ " <-> " ^ string_of_typ typ2 ^ " effect " ^ string_of_effect eff | Typ_exist (kids, nc, typ) -> "{" ^ string_of_list " " string_of_kinded_id kids ^ ", " ^ string_of_n_constraint nc ^ ". " ^ string_of_typ typ ^ "}" and string_of_typ_arg = function @@ -1170,10 +1170,12 @@ and typ_compare (Typ_aux (t1,_)) (Typ_aux (t2,_)) = | 0 -> effect_compare e1 e2 | n -> n) | n -> n) - | Typ_bidir (t1,t2), Typ_bidir (t3,t4) -> + | Typ_bidir (t1,t2,e1), Typ_bidir (t3,t4,e2) -> (match typ_compare t1 t3 with - | 0 -> typ_compare t2 t3 - | n -> n) + | 0 -> (match typ_compare t2 t4 with + | 0 -> effect_compare e1 e2 + | n -> n) + | n -> n) | Typ_tup ts1, Typ_tup ts2 -> Util.compare_list typ_compare ts1 ts2 | Typ_exist (ks1,nc1,t1), Typ_exist (ks2,nc2,t2) -> (match Util.compare_list KOpt.compare ks1 ks2 with @@ -1247,7 +1249,7 @@ let rec lexp_to_exp (LEXP_aux (lexp_aux, annot) as le) = | LEXP_vector_concat [] -> rewrap (E_vector []) | LEXP_vector_concat (lexp :: lexps) -> List.fold_left (fun exp lexp -> rewrap (E_vector_append (exp, lexp_to_exp lexp))) (lexp_to_exp lexp) lexps - | LEXP_deref exp -> rewrap (E_app (mk_id "reg_deref", [exp])) + | LEXP_deref exp -> rewrap (E_app (mk_id "__deref", [exp])) let is_unit_typ = function | Typ_aux (Typ_id u, _) -> string_of_id u = "unit" @@ -1378,7 +1380,7 @@ and kopts_of_typ (Typ_aux (t,_)) = | 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_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 @@ -1438,11 +1440,11 @@ and tyvars_of_typ (Typ_aux (t,_)) = | Typ_id _ -> KidSet.empty | Typ_var kid -> KidSet.singleton kid | Typ_fn (ts, t, _) -> List.fold_left KidSet.union (tyvars_of_typ t) (List.map tyvars_of_typ ts) - | Typ_bidir (t1, t2) -> KidSet.union (tyvars_of_typ t1) (tyvars_of_typ t2) + | Typ_bidir (t1, t2, _) -> KidSet.union (tyvars_of_typ t1) (tyvars_of_typ t2) | Typ_tup ts -> List.fold_left (fun s t -> KidSet.union s (tyvars_of_typ t)) KidSet.empty ts - | Typ_app (_,tas) -> + | Typ_app (_,tas) -> List.fold_left (fun s ta -> KidSet.union s (tyvars_of_typ_arg ta)) KidSet.empty tas | Typ_exist (kids, nc, t) -> @@ -1661,6 +1663,41 @@ let hex_to_bin hex = |> List.map Sail_lib.char_of_bit |> (fun bits -> String.init (List.length bits) (List.nth bits)) +let explode s = + let rec exp i l = if i < 0 then l else exp (i - 1) (s.[i] :: l) in + exp (String.length s - 1) [] + +let vector_string_to_bit_list (L_aux (lit, l)) = + + let hexchar_to_binlist = function + | '0' -> ['0';'0';'0';'0'] + | '1' -> ['0';'0';'0';'1'] + | '2' -> ['0';'0';'1';'0'] + | '3' -> ['0';'0';'1';'1'] + | '4' -> ['0';'1';'0';'0'] + | '5' -> ['0';'1';'0';'1'] + | '6' -> ['0';'1';'1';'0'] + | '7' -> ['0';'1';'1';'1'] + | '8' -> ['1';'0';'0';'0'] + | '9' -> ['1';'0';'0';'1'] + | 'A' -> ['1';'0';'1';'0'] + | 'B' -> ['1';'0';'1';'1'] + | 'C' -> ['1';'1';'0';'0'] + | 'D' -> ['1';'1';'0';'1'] + | 'E' -> ['1';'1';'1';'0'] + | 'F' -> ['1';'1';'1';'1'] + | _ -> raise (Reporting.err_unreachable l __POS__ "hexchar_to_binlist given unrecognized character") in + + let s_bin = match lit with + | L_hex s_hex -> List.flatten (List.map hexchar_to_binlist (explode (String.uppercase_ascii s_hex))) + | L_bin s_bin -> explode s_bin + | _ -> raise (Reporting.err_unreachable l __POS__ "s_bin given non vector literal") in + + List.map (function '0' -> L_aux (L_zero, gen_loc l) + | '1' -> L_aux (L_one, gen_loc l) + | _ -> raise (Reporting.err_unreachable (gen_loc l) __POS__ "binary had non-zero or one")) s_bin + + (* Functions for working with locations *) let locate_id f (Id_aux (name, l)) = Id_aux (name, f l) @@ -1726,7 +1763,7 @@ and locate_typ f (Typ_aux (typ_aux, l)) = | Typ_var kid -> Typ_var (locate_kid f kid) | Typ_fn (arg_typs, ret_typ, effect) -> Typ_fn (List.map (locate_typ f) arg_typs, locate_typ f ret_typ, locate_effect f effect) - | Typ_bidir (typ1, typ2) -> Typ_bidir (locate_typ f typ1, locate_typ f typ2) + | Typ_bidir (typ1, typ2, effect) -> Typ_bidir (locate_typ f typ1, locate_typ f typ2, locate_effect f effect) | Typ_tup typs -> Typ_tup (List.map (locate_typ f) typs) | Typ_exist (kopts, constr, typ) -> Typ_exist (List.map (locate_kinded_id f) kopts, locate_nc f constr, locate_typ f typ) | Typ_app (id, typ_args) -> Typ_app (locate_id f id, List.map (locate_typ_arg f) typ_args) @@ -1945,7 +1982,7 @@ and typ_subst_aux sv subst = function | _ -> Typ_var kid end | Typ_fn (arg_typs, ret_typ, effs) -> Typ_fn (List.map (typ_subst sv subst) arg_typs, typ_subst sv subst ret_typ, effs) - | Typ_bidir (typ1, typ2) -> Typ_bidir (typ_subst sv subst typ1, typ_subst sv subst typ2) + | Typ_bidir (typ1, typ2, effs) -> Typ_bidir (typ_subst sv subst typ1, typ_subst sv subst typ2, effs) | Typ_tup typs -> Typ_tup (List.map (typ_subst sv subst) typs) | Typ_app (f, args) -> Typ_app (f, List.map (typ_arg_subst sv subst) args) | Typ_exist (kopts, nc, typ) when KidSet.mem sv (KidSet.of_list (List.map kopt_kid kopts)) -> @@ -2043,7 +2080,7 @@ let subst_kids_nc, subst_kids_typ, subst_kids_typ_arg = | Typ_var _ -> ty | Typ_fn (t1,t2,e) -> re (Typ_fn (List.map (s_styp substs) t1, s_styp substs t2,e)) - | Typ_bidir (t1, t2) -> re (Typ_bidir (s_styp substs t1, s_styp substs t2)) + | Typ_bidir (t1,t2,e) -> re (Typ_bidir (s_styp substs t1, s_styp substs t2,e)) | Typ_tup ts -> re (Typ_tup (List.map (s_styp substs) ts)) | Typ_app (id,tas) -> re (Typ_app (id,List.map (s_starg substs) tas)) | Typ_exist (kopts,nc,t) -> diff --git a/src/ast_util.mli b/src/ast_util.mli index f6bf1fcc..6be8ca34 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -472,6 +472,8 @@ val subst : id -> 'a exp -> 'a exp -> 'a exp val hex_to_bin : string -> string +val vector_string_to_bit_list : lit -> lit list + (** {2 Manipulating locations} *) (** locate takes an expression and recursively sets the location in diff --git a/src/constant_fold.ml b/src/constant_fold.ml index 7a7067ef..35417ac8 100644 --- a/src/constant_fold.ml +++ b/src/constant_fold.ml @@ -91,7 +91,7 @@ and exp_of_value = let safe_primops = List.fold_left (fun m k -> StringMap.remove k m) - Value.primops + !Value.primops [ "print_endline"; "prerr_endline"; "putchar"; @@ -191,7 +191,17 @@ let rec run frame = let initial_state ast env = Interpreter.initial_state ~registers:false ast env safe_primops -let rw_exp target ok not_ok istate = +type fixed = { + registers: tannot exp Bindings.t; + fields: tannot exp Bindings.t Bindings.t; + } + +let no_fixed = { + registers = Bindings.empty; + fields = Bindings.empty; + } + +let rw_exp fixed target ok not_ok istate = let evaluate e_aux annot = let initial_monad = Interpreter.return (E_aux (e_aux, annot)) in try @@ -219,6 +229,34 @@ let rw_exp target ok not_ok istate = | E_app (id, args) when fold_to_unit id -> ok (); E_aux (E_lit (L_aux (L_unit, fst annot)), annot) + | E_id id -> + begin match Bindings.find_opt id fixed.registers with + | Some exp -> + ok (); exp + | None -> + E_aux (e_aux, annot) + end + + | E_field (E_aux (E_id id, _), field) -> + begin match Bindings.find_opt id fixed.fields with + | Some fields -> + begin match Bindings.find_opt field fields with + | Some exp -> + ok (); exp + | None -> + E_aux (e_aux, annot) + end + | None -> + E_aux (e_aux, annot) + end + + (* Short-circuit boolean operators with constants *) + | E_app (id, [(E_aux (E_lit (L_aux (L_false, _)), _) as false_exp); _]) when string_of_id id = "and_bool" -> + ok (); false_exp + + | E_app (id, [(E_aux (E_lit (L_aux (L_true, _)), _) as true_exp); _]) when string_of_id id = "or_bool" -> + ok (); true_exp + | E_app (id, args) when List.for_all is_constant args -> let env = env_of_annot annot in (* We want to fold all primitive operations, but avoid folding @@ -252,9 +290,9 @@ let rw_exp target ok not_ok istate = in fold_exp { id_exp_alg with e_aux = (fun (e_aux, annot) -> rw_funcall e_aux annot)} -let rewrite_exp_once target = rw_exp target (fun _ -> ()) (fun _ -> ()) +let rewrite_exp_once target = rw_exp no_fixed target (fun _ -> ()) (fun _ -> ()) -let rec rewrite_constant_function_calls' target ast = +let rec rewrite_constant_function_calls' fixed target ast = let rewrite_count = ref 0 in let ok () = incr rewrite_count in let not_ok () = decr rewrite_count in @@ -262,16 +300,78 @@ let rec rewrite_constant_function_calls' target ast = let rw_defs = { rewriters_base with - rewrite_exp = (fun _ -> rw_exp target ok not_ok istate) + rewrite_exp = (fun _ -> rw_exp fixed target ok not_ok istate) } in let ast = rewrite_defs_base rw_defs ast in (* We keep iterating until we have no more re-writes to do *) if !rewrite_count > 0 - then rewrite_constant_function_calls' target ast + then rewrite_constant_function_calls' fixed target ast else ast -let rewrite_constant_function_calls target ast = +let rewrite_constant_function_calls fixed target ast = if !optimize_constant_fold then - rewrite_constant_function_calls' target ast + rewrite_constant_function_calls' fixed target ast else ast + +type to_constant = + | Register of id * typ * tannot exp + | Register_field of id * id * typ * tannot exp + +let () = + let open Interactive in + let open Printf in + + let update_fixed fixed = function + | Register (id, _, exp) -> + { fixed with registers = Bindings.add id exp fixed.registers } + | Register_field (id, field, _, exp) -> + let prev_fields = match Bindings.find_opt id fixed.fields with Some f -> f | None -> Bindings.empty in + let updated_fields = Bindings.add field exp prev_fields in + { fixed with fields = Bindings.add id updated_fields fixed.fields } + in + + ArgString ("target", fun target -> ArgString ("assignments", fun assignments -> Action (fun () -> + let assignments = Str.split (Str.regexp " +") assignments in + let assignments = + List.map (fun assignment -> + match String.split_on_char '=' assignment with + | [reg; value] -> + begin match String.split_on_char '.' reg with + | [reg; field] -> + let reg = mk_id reg in + let field = mk_id field in + begin match Env.lookup_id reg !env with + | Register (_, _, Typ_aux (Typ_id rec_id, _)) -> + let (_, fields) = Env.get_record rec_id !env in + let typ = match List.find_opt (fun (typ, id) -> Id.compare id field = 0) fields with + | Some (typ, _) -> typ + | None -> failwith (sprintf "Register %s does not have a field %s" (string_of_id reg) (string_of_id field)) + in + let exp = Initial_check.exp_of_string value in + let exp = check_exp !env exp typ in + Register_field (reg, field, typ, exp) + | _ -> + failwith (sprintf "Register %s is not defined as a record in the current environment" (string_of_id reg)) + end + | _ -> + let reg = mk_id reg in + begin match Env.lookup_id reg !env with + | Register (_, _, typ) -> + let exp = Initial_check.exp_of_string value in + let exp = check_exp !env exp typ in + Register (reg, typ, exp) + | _ -> + failwith (sprintf "Register %s is not defined in the current environment" (string_of_id reg)) + end + end + | _ -> failwith (sprintf "Could not parse '%s' as an assignment <register>=<value>" assignment) + ) assignments in + let assignments = List.fold_left update_fixed no_fixed assignments in + + ast := rewrite_constant_function_calls' assignments target !ast))) + |> register_command + ~name:"fix_registers" + ~help:"Fix the value of specified registers, specified as a \ + list of <register>=<value>. Can also fix a specific \ + register field as <register>.<field>=<value>." diff --git a/src/constant_propagation_mutrec.ml b/src/constant_propagation_mutrec.ml index 6cc6d28c..03d8e154 100644 --- a/src/constant_propagation_mutrec.ml +++ b/src/constant_propagation_mutrec.ml @@ -97,7 +97,8 @@ let generate_fun_id id args = that will be propagated in *) let generate_val_spec env id args l annot = match Env.get_val_spec_orig id env with - | tq, Typ_aux (Typ_fn (arg_typs, ret_typ, eff), _) -> + | tq, (Typ_aux (Typ_fn (arg_typs, ret_typ, eff), _) as fn_typ) -> + (* Get instantiation of type variables at call site *) let orig_ksubst (kid, typ_arg) = match typ_arg with | A_aux ((A_nexp _ | A_bool _), _) -> (orig_kid kid, typ_arg) @@ -110,21 +111,38 @@ let generate_val_spec env id args l annot = |> List.map orig_ksubst |> List.fold_left (fun s (v,i) -> KBindings.add v i s) KBindings.empty in + (* Apply instantiation to original function type. Also collect the + type variables in the new type together their kinds for the new + val spec. *) + let kopts_of_typ env typ = + tyvars_of_typ typ |> KidSet.elements + |> List.map (fun kid -> mk_kopt (Env.get_typ_var kid env) kid) + |> KOptSet.of_list + in let ret_typ' = KBindings.fold typ_subst ksubsts ret_typ in - let arg_typs' = - List.map (KBindings.fold typ_subst ksubsts) arg_typs - |> List.map2 (fun arg typ -> if is_const_exp arg then [] else [typ]) args - |> List.concat - |> function [] -> [unit_typ] | typs -> typs + let (arg_typs', kopts') = + List.fold_right2 (fun arg typ (arg_typs', kopts') -> + if is_const_exp arg then + (arg_typs', kopts') + else + let typ' = KBindings.fold typ_subst ksubsts typ in + let arg_kopts = kopts_of_typ (env_of arg) typ' in + (typ' :: arg_typs', KOptSet.union arg_kopts kopts')) + args arg_typs ([], kopts_of_typ (env_of_tannot annot) ret_typ') in + let arg_typs' = if arg_typs' = [] then [unit_typ] else arg_typs' in let typ' = mk_typ (Typ_fn (arg_typs', ret_typ', eff)) in - let tyvars = tyvars_of_typ typ' in - let tq' = - quant_items tq |> - List.filter (fun qi -> KidSet.subset (tyvars_of_quant_item qi) tyvars) |> - mk_typquant + (* Construct new val spec *) + let constraints' = + quant_split tq |> snd + |> List.map (KBindings.fold constraint_subst ksubsts) + |> List.filter (fun nc -> KidSet.subset (tyvars_of_constraint nc) (tyvars_of_typ typ')) + in + let quant_items' = + List.map mk_qi_kopt (KOptSet.elements kopts') @ + List.map mk_qi_nc constraints' in - let typschm = mk_typschm tq' typ' in + let typschm = mk_typschm (mk_typquant quant_items') typ' in mk_val_spec (VS_val_spec (typschm, generate_fun_id id args, [], false)), ksubsts | _, Typ_aux (_, l) -> diff --git a/src/gdbmi.ml b/src/gdbmi.ml new file mode 100644 index 00000000..faf3ac11 --- /dev/null +++ b/src/gdbmi.ml @@ -0,0 +1,257 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Ast_util +open Printf +open Gdbmi_types + +let parse_gdb_response str = + let lexbuf = Lexing.from_string str in + Gdbmi_parser.response_eof Gdbmi_lexer.token lexbuf + +type gdb_session = (in_channel * out_channel * in_channel) option + +let gdb_command = ref "gdb-multiarch" + +let gdb_token_counter = ref 0 + +let gdb_token () = + incr gdb_token_counter; + !gdb_token_counter + +let not_connected = Reporting.err_general Parse_ast.Unknown "Not connected to gdb" + +let rec wait_for' regexp stdout = + let line = input_line stdout in + if Str.string_match regexp line 0 then ( + line + ) else ( + print_endline Util.(line |> dim |> clear); + wait_for' regexp stdout + ) + +let wait_for token stdout = + let regexp = Str.regexp (sprintf "^%i\\^" token) in + wait_for' regexp stdout + +let wait_for_gdb stdout = + let regexp = Str.regexp_string "(gdb)" in + wait_for' regexp stdout + +let send_sync session cmd = + match session with + | None -> raise not_connected + | Some (stdout, stdin, _) -> + let token = gdb_token () in + let cmd = sprintf "%i-%s\n" token cmd in + print_string Util.(cmd |> yellow |> clear); + flush stdin; + output_string stdin cmd; + flush stdin; + wait_for token stdout + +let send_regular session cmd = + match session with + | None -> raise not_connected + | Some (stdout, stdin, _) -> + let token = gdb_token () in + print_endline Util.(cmd |> yellow |> clear); + flush stdin; + output_string stdin (cmd ^ "\n"); + flush stdin; + ignore (wait_for_gdb stdout) + +let synced_registers = ref [] + +let gdb_sync session = + let gdb_register_names = parse_gdb_response (send_sync session "data-list-register-names") in + let gdb_register_values = parse_gdb_response (send_sync session "data-list-register-values x") in + let names = match gdb_register_names with + | Result (_, "done", output) -> + List.assoc "register-names" output |> gdb_seq |> List.map gdb_string + | _ -> failwith "GDB could not get register names" + in + let values = match gdb_register_values with + | Result (_, "done", output) -> + List.assoc "register-values" output + |> gdb_seq + |> List.map gdb_assoc + |> List.map (List.assoc "value") + |> List.map gdb_string + | _ -> failwith "GDB could not get register names" + in + synced_registers := List.combine names values + +let gdb_list_registers session = + gdb_sync session; + List.iter (fun (name, value) -> + print_endline (sprintf "%s: %s" name value) + ) !synced_registers + +let gdb_read_mem session addr data_size = + let open Value in + let cmd = sprintf "data-read-memory %s x 1 1 %i" (Sail_lib.string_of_bits addr) (Big_int.to_int data_size) in + (* An example response looks something like: + + 7^done,addr="0x0000000040009e64",nr-bytes="4",total-bytes="4",next-row="0x0000000040009e68", + prev-row="0x0000000040009e60",next-page="0x0000000040009e68",prev-page="0x0000000040009e60", + memory=[{addr="0x0000000040009e64",data=["0x03","0xfc","0x5a","0xd3"]}] + *) + match parse_gdb_response (send_sync session cmd) with + | Result (_, "done", output) -> + List.assoc "memory" output |> gdb_seq + |> List.hd |> gdb_assoc + |> List.assoc "data" |> gdb_seq + |> List.rev_map (fun byte -> Sail_lib.byte_of_int (int_of_string (gdb_string byte))) + |> List.concat + + | _ -> failwith "Unexpected response from GDB" + +let value_gdb_read_ram session = + let open Value in + function + | [addr_size; data_size; _; addr] -> + mk_vector (gdb_read_mem session (coerce_bv addr) (coerce_int data_size)) + + | _ -> failwith "gdb_read_ram" + +let gdb_effect_interp session state eff = + let open Value in + let open Interpreter in + let lstate, gstate = state in + match eff with + | Read_mem (rk, addr, len, cont) -> + let result = mk_vector (gdb_read_mem session (coerce_bv addr) (coerce_int len)) in + cont result state + | Read_reg (name, cont) -> + begin match List.assoc_opt name !synced_registers with + | Some value -> + let value = mk_vector (Sail_lib.to_bits' (64, Big_int.of_string value)) in + cont value state + | None -> + cont (Bindings.find (mk_id name) gstate.registers) state + end + | Write_reg (name, v, cont) -> + let id = mk_id name in + if Bindings.mem id gstate.registers then + let state' = (lstate, { gstate with registers = Bindings.add id v gstate.registers }) in + cont () state' + else + failwith ("Write of nonexistent register: " ^ name) + | _ -> + failwith "Unsupported in GDB state" + +let gdb_hooks session = + Value.add_primop "read_ram" (value_gdb_read_ram session); + Interpreter.set_effect_interp (gdb_effect_interp session) + +let () = + let open Interactive in + let session = ref None in + + let gdb_start arg = + let stdout, stdin, stderr = Unix.open_process_full (sprintf "%s --interpreter=mi" !gdb_command) [||] in + session := Some (stdout, stdin, stderr); + wait_for_gdb stdout |> ignore; + if arg = "" then () else print_endline (send_sync !session arg) + in + + let gdb_send arg = + if arg = "" then () else print_endline (send_sync !session arg) + in + + register_command + ~name:"gdb_command" + ~help:"Use specified gdb. Default is gdb-multiarch. This is the \ + correct version on Ubuntu, but other Linux distros and \ + operating systems may differ in how they package gdb with \ + support for multiple architectures." + (ArgString ("gdb", fun arg -> Action (fun () -> gdb_command := arg))); + + register_command + ~name:"gdb_start" + ~help:"Start a child GDB process sending :0 as the first command, waiting for it to complete" + (ArgString ("command", fun cmd -> Action (fun () -> gdb_start cmd))); + + (ArgString ("port", fun port -> Action (fun () -> + if port = "" then + gdb_start "target-select remote localhost:1234" + else + gdb_start ("target-select remote localhost:" ^ port) + ))) |> register_command + ~name:"gdb_qemu" + ~help:"Connect GDB to a remote QEMU target on localhost port :0 (default is 1234, as per -s option for QEMU)"; + + register_command + ~name:"gdb_send" + ~help:"Send a GDB/MI command to a child GDB process and wait for it to complete" + (ArgString ("command", fun cmd -> Action (fun () -> gdb_send cmd))); + + register_command + ~name:"gdb_sync" + ~help:"Sync sail registers with GDB" + (Action (fun () -> gdb_sync !session)); + + register_command + ~name:"gdb_list_registers" + ~help:"Sync sail registers with GDB and list them" + (Action (fun () -> gdb_list_registers !session)); + + register_command + ~name:"gdb_hooks" + ~help:"Make reading and writing memory go via GDB" + (Action (fun () -> gdb_hooks !session)); + + (ArgString ("symbol_file", fun file -> Action (fun () -> + send_regular !session ("symbol-file " ^ file) + ))) |> register_command + ~name:"gdb_symbol_file" + ~help:"Load debugging symbols into GDB"; diff --git a/src/gdbmi_lexer.mll b/src/gdbmi_lexer.mll new file mode 100644 index 00000000..d55ea3cb --- /dev/null +++ b/src/gdbmi_lexer.mll @@ -0,0 +1,101 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +{ + +open Gdbmi_parser + +let unescaped s = Scanf.sscanf ("\"" ^ s ^ "\"") "%S%!" (fun x -> x) + +} + +let ws = [' ''\t']+ +let letter = ['a'-'z''A'-'Z''?'] +let digit = ['0'-'9'] +let hexdigit = ['0'-'9''A'-'F''a'-'f'] +let alphanum = letter|digit +let startident = letter +let ident = alphanum|['-'] +let escape_sequence = ('\\' ['\\''\"''\'''n''t''b''r']) | ('\\' digit digit digit) | ('\\' 'x' hexdigit hexdigit) + +rule token = parse + | ws + { token lexbuf } + | "\n" + { Lexing.new_line lexbuf; + token lexbuf } + | "=" { Eq } + | "[" { Lsquare } + | "]" { Rsquare } + | "{" { Lcurly } + | "}" { Rcurly } + | "," { Comma } + | "^" { Caret } + | digit+ as i { Num (int_of_string i) } + | startident ident* as i { Id i } + | '"' { String (string (Lexing.lexeme_start_p lexbuf) (Buffer.create 10) lexbuf) } + | eof { Eof } + +and string pos b = parse + | ([^'"''\n''\\']*'\n' as i) { Lexing.new_line lexbuf; + Buffer.add_string b i; + string pos b lexbuf } + | ([^'"''\n''\\']* as i) { Buffer.add_string b i; string pos b lexbuf } + | escape_sequence as i { Buffer.add_string b i; string pos b lexbuf } + | '\\' '\n' ws { Lexing.new_line lexbuf; string pos b lexbuf } + | '\\' { assert false (*raise (Reporting.Fatal_error (Reporting.Err_syntax (pos, + "illegal backslash escape in string"*) } + | '"' { let s = unescaped(Buffer.contents b) in + (*try Ulib.UTF8.validate s; s + with Ulib.UTF8.Malformed_code -> + raise (Reporting.Fatal_error (Reporting.Err_syntax (pos, + "String literal is not valid utf8"))) *) s } + | eof { assert false (*raise (Reporting.Fatal_error (Reporting.Err_syntax (pos, + "String literal not terminated")))*) }
\ No newline at end of file diff --git a/src/gdbmi_parser.mly b/src/gdbmi_parser.mly new file mode 100644 index 00000000..5ae5027f --- /dev/null +++ b/src/gdbmi_parser.mly @@ -0,0 +1,85 @@ +/**************************************************************************/ +/* Sail */ +/* */ +/* Copyright (c) 2013-2017 */ +/* Kathyrn Gray */ +/* Shaked Flur */ +/* Stephen Kell */ +/* Gabriel Kerneis */ +/* Robert Norton-Wright */ +/* Christopher Pulte */ +/* Peter Sewell */ +/* Alasdair Armstrong */ +/* Brian Campbell */ +/* Thomas Bauereiss */ +/* Anthony Fox */ +/* Jon French */ +/* Dominic Mulligan */ +/* Stephen Kell */ +/* Mark Wassell */ +/* */ +/* All rights reserved. */ +/* */ +/* This software was developed by the University of Cambridge Computer */ +/* Laboratory as part of the Rigorous Engineering of Mainstream Systems */ +/* (REMS) project, funded by EPSRC grant EP/K008528/1. */ +/* */ +/* Redistribution and use in source and binary forms, with or without */ +/* modification, are permitted provided that the following conditions */ +/* are met: */ +/* 1. Redistributions of source code must retain the above copyright */ +/* notice, this list of conditions and the following disclaimer. */ +/* 2. Redistributions in binary form must reproduce the above copyright */ +/* notice, this list of conditions and the following disclaimer in */ +/* the documentation and/or other materials provided with the */ +/* distribution. */ +/* */ +/* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' */ +/* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED */ +/* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A */ +/* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR */ +/* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, */ +/* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT */ +/* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF */ +/* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND */ +/* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, */ +/* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT */ +/* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF */ +/* SUCH DAMAGE. */ +/**************************************************************************/ + +%{ + +open Gdbmi_types + +%} + +%token Eof +%token Eq Lsquare Rsquare Lcurly Rcurly Comma Caret +%token <string> String Id +%token <int> Num + +%start response_eof +%type <Gdbmi_types.response> response_eof + +%% + +map_elem: + | Id Eq output + { ($1, $3) } + +output: + | String + { String $1 } + | Lsquare separated_list(Comma, output) Rsquare + { Seq $2 } + | Lcurly separated_list(Comma, map_elem) Rcurly + { Assoc $2 } + +response: + | Num Caret Id Comma separated_list(Comma, map_elem) + { Result ($1, $3, $5) } + +response_eof: + | response Eof + { $1 }
\ No newline at end of file diff --git a/src/gdbmi_types.ml b/src/gdbmi_types.ml new file mode 100644 index 00000000..13877a83 --- /dev/null +++ b/src/gdbmi_types.ml @@ -0,0 +1,69 @@ +(**************************************************************************) +(* 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. *) +(**************************************************************************) + +type output = + | Assoc of (string * output) list + | Seq of output list + | String of string + +let gdb_seq = function + | Seq xs -> xs + | _ -> failwith "Expected GDB sequence" + +let gdb_string = function + | String xs -> xs + | _ -> failwith "Expected GDB string" + +let gdb_assoc = function + | Assoc xs -> xs + | _ -> failwith "Expected GDB associative list" + +type response = + | Result of int * string * (string * output) list diff --git a/src/lem_interp/sail2_instr_kinds.lem b/src/gen_lib/sail2_instr_kinds.lem index f3cdfbc9..f3cdfbc9 100644 --- a/src/lem_interp/sail2_instr_kinds.lem +++ b/src/gen_lib/sail2_instr_kinds.lem diff --git a/src/gen_lib/sail2_operators_bitlists.lem b/src/gen_lib/sail2_operators_bitlists.lem index c9892e4c..15daa545 100644 --- a/src/gen_lib/sail2_operators_bitlists.lem +++ b/src/gen_lib/sail2_operators_bitlists.lem @@ -38,6 +38,9 @@ let sign_extend bits len = exts_bits len bits val zeros : integer -> list bitU let zeros len = repeat [B0] len +val ones : integer -> list bitU +let ones len = repeat [B1] len + val vector_truncate : list bitU -> integer -> list bitU let vector_truncate bs len = extz_bv len bs diff --git a/src/gen_lib/sail2_values.lem b/src/gen_lib/sail2_values.lem index f657803f..69bf0852 100644 --- a/src/gen_lib/sail2_values.lem +++ b/src/gen_lib/sail2_values.lem @@ -423,6 +423,26 @@ let char_of_nibble = function | _ -> Nothing end +let nibble_of_char = function + | #'0' -> Just (B0, B0, B0, B0) + | #'1' -> Just (B0, B0, B0, B1) + | #'2' -> Just (B0, B0, B1, B0) + | #'3' -> Just (B0, B0, B1, B1) + | #'4' -> Just (B0, B1, B0, B0) + | #'5' -> Just (B0, B1, B0, B1) + | #'6' -> Just (B0, B1, B1, B0) + | #'7' -> Just (B0, B1, B1, B1) + | #'8' -> Just (B1, B0, B0, B0) + | #'9' -> Just (B1, B0, B0, B1) + | #'A' -> Just (B1, B0, B1, B0) + | #'B' -> Just (B1, B0, B1, B1) + | #'C' -> Just (B1, B1, B0, B0) + | #'D' -> Just (B1, B1, B0, B1) + | #'E' -> Just (B1, B1, B1, B0) + | #'F' -> Just (B1, B1, B1, B1) + | _ -> Nothing + end + let rec hexstring_of_bits bs = match bs with | b1 :: b2 :: b3 :: b4 :: bs -> let n = char_of_nibble (b1, b2, b3, b4) in @@ -436,12 +456,14 @@ let rec hexstring_of_bits bs = match bs with end declare {isabelle; hol} termination_argument hexstring_of_bits = automatic -let show_bitlist bs = +let show_bitlist_prefix c bs = match hexstring_of_bits bs with - | Just s -> toString (#'0' :: #'x' :: s) - | Nothing -> toString (#'0' :: #'b' :: map bitU_char bs) + | Just s -> toString (c :: #'x' :: s) + | Nothing -> toString (c :: #'b' :: map bitU_char bs) end +let show_bitlist bs = show_bitlist_prefix #'0' bs + (*** List operations *) let inline (^^) = append_list diff --git a/src/initial_check.ml b/src/initial_check.ml index 1aebdbc2..f808af49 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -153,7 +153,7 @@ let rec to_ast_typ ctx (P.ATyp_aux (aux, l)) = | _ -> [to_ast_typ ctx from_typ] in Typ_fn (from_typs, to_ast_typ ctx to_typ, to_ast_effects effects) - | P.ATyp_bidir (typ1, typ2) -> Typ_bidir (to_ast_typ ctx typ1, to_ast_typ ctx typ2) + | P.ATyp_bidir (typ1, typ2, effects) -> Typ_bidir (to_ast_typ ctx typ1, to_ast_typ ctx typ2, to_ast_effects effects) | P.ATyp_tup typs -> Typ_tup (List.map (to_ast_typ ctx) typs) | P.ATyp_app (P.Id_aux (P.Id "int", il), [n]) -> Typ_app (Id_aux (Id "atom", il), [to_ast_typ_arg ctx n K_int]) @@ -931,8 +931,8 @@ let generate_undefineds vs_ids (Defs defs) = in let undefined_tu = function | Tu_aux (Tu_ty_id (Typ_aux (Typ_tup typs, _), id), _) -> - mk_exp (E_app (id, List.map (fun _ -> mk_lit_exp L_undef) typs)) - | Tu_aux (Tu_ty_id (typ, id), _) -> mk_exp (E_app (id, [mk_lit_exp L_undef])) + mk_exp (E_app (id, List.map (fun typ -> mk_exp (E_cast (typ, mk_lit_exp L_undef))) typs)) + | Tu_aux (Tu_ty_id (typ, id), _) -> mk_exp (E_app (id, [mk_exp (E_cast (typ, mk_lit_exp L_undef))])) in let p_tup = function | [pat] -> pat diff --git a/src/interactive.ml b/src/interactive.ml index 12a1be64..2cca944c 100644 --- a/src/interactive.ml +++ b/src/interactive.ml @@ -48,21 +48,85 @@ (* SUCH DAMAGE. *) (**************************************************************************) +open Ast +open Ast_util +open Printf + let opt_interactive = ref false let opt_emacs_mode = ref false let opt_suppress_banner = ref false let env = ref Type_check.initial_env -let ast = ref (Ast.Defs []) +let ast = ref (Defs []) let arg str = ("<" ^ str ^ ">") |> Util.yellow |> Util.clear let command str = - (":" ^ str) |> Util.green |> Util.clear + str |> Util.green |> Util.clear + +type action = + | ArgString of string * (string -> action) + | ArgInt of string * (int -> action) + | Action of (unit -> unit) let commands = ref [] +let reflect_typ action = + let open Type_check in + let rec arg_typs = function + | ArgString (_, next) -> string_typ :: arg_typs (next "") + | ArgInt (_, next) -> int_typ :: arg_typs (next 0) + | Action _ -> [] + in + function_typ (arg_typs action) unit_typ no_effect + +let generate_help name help action = + let rec args = function + | ArgString (hint, next) -> arg hint :: args (next "") + | ArgInt (hint, next) -> arg hint :: args (next 0) + | Action _ -> [] + in + let args = args action in + let help = match String.split_on_char ':' help with + | [] -> assert false + | (prefix :: splits) -> + List.map (fun split -> + match String.split_on_char ' ' split with + | [] -> assert false + | (subst :: rest) -> + if Str.string_match (Str.regexp "^[0-9]+") subst 0 then + let num_str = Str.matched_string subst in + let num_end = Str.match_end () in + let punct = String.sub subst num_end (String.length subst - num_end) in + List.nth args (int_of_string num_str) ^ punct ^ " " ^ String.concat " " rest + else + command (":" ^ subst) ^ " " ^ String.concat " " rest + ) splits + |> String.concat "" + |> (fun rest -> prefix ^ rest) + in + sprintf "%s %s - %s" Util.(name |> green |> clear) (String.concat ", " args) help + +let run_action cmd argument action = + let args = String.split_on_char ',' argument in + let rec call args action = + match args, action with + | (x :: xs), ArgString (hint, next) -> + call xs (next (String.trim x)) + | (x :: xs), ArgInt (hint, next) -> + let x = String.trim x in + if Str.string_match (Str.regexp "^[0-9]+$") x 0 then + call xs (next (int_of_string x)) + else + print_endline (sprintf "%s argument %s must be an non-negative integer" (command cmd) (arg hint)) + | _, Action act -> + act () + | _, _ -> + print_endline (sprintf "Bad arguments for %s, see (%s %s)" (command cmd) (command ":help") (command cmd)) + in + call args action + let register_command ~name:name ~help:help action = commands := (":" ^ name, (help, action)) :: !commands diff --git a/src/interactive.mli b/src/interactive.mli index b1df0630..933d0a46 100644 --- a/src/interactive.mli +++ b/src/interactive.mli @@ -62,6 +62,17 @@ val env : Env.t ref val arg : string -> string val command : string -> string -val commands : (string * (string * (string -> unit))) list ref +type action = + | ArgString of string * (string -> action) + | ArgInt of string * (int -> action) + | Action of (unit -> unit) -val register_command : name:string -> help:string -> (string -> unit) -> unit +val reflect_typ : action -> typ + +val commands : (string * (string * action)) list ref + +val register_command : name:string -> help:string -> action -> unit + +val generate_help : string -> string -> action -> string + +val run_action : string -> string -> action -> unit diff --git a/src/interpreter.ml b/src/interpreter.ml index dd322369..4c048c09 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -203,7 +203,6 @@ let throw v = Yield (Exception v) let call (f : id) (args : value list) : return_value monad = Yield (Call (f, args, fun v -> Pure v)) - let read_mem rk addr len : value monad = Yield (Read_mem (rk, addr, len, (fun v -> Pure v))) @@ -286,6 +285,7 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = match e_aux with | E_block [] -> wrap (E_lit (L_aux (L_unit, Parse_ast.Unknown))) | E_block [exp] when is_value exp -> return exp + | E_block [E_aux (E_block _, _) as exp] -> return exp | E_block (exp :: exps) when is_value exp -> wrap (E_block exps) | E_block (exp :: exps) -> step exp >>= fun exp' -> wrap (E_block (exp' :: exps)) @@ -825,7 +825,8 @@ let rec eval_frame' = function | Yield (Get_primop (name, cont)), _ -> begin try - let op = StringMap.find name gstate.primops in + (* If we are in the toplevel interactive interpreter allow the set of primops to be changed dynamically *) + let op = StringMap.find name (if !Interactive.opt_interactive then !Value.primops else gstate.primops) in eval_frame' (Step (out, state, cont op, stack)) with Not_found -> eval_frame' (Step (out, state, fail ("No such primop: " ^ name), stack)) @@ -926,8 +927,9 @@ let default_effect_interp state eff = failwith ("Register write disallowed by allow_registers setting: " ^ name) end +let effect_interp = ref default_effect_interp - +let set_effect_interp interp = effect_interp := interp let rec run_frame frame = match frame with @@ -938,7 +940,7 @@ let rec run_frame frame = | Break frame -> run_frame (eval_frame frame) | Effect_request (out, state, stack, eff) -> - run_frame (default_effect_interp state eff) + run_frame (!effect_interp state eff) let eval_exp state exp = run_frame (Step (lazy "", state, return exp, [])) diff --git a/src/isail.ml b/src/isail.ml index 1c635af0..02908321 100644 --- a/src/isail.ml +++ b/src/isail.ml @@ -56,6 +56,7 @@ open Interpreter open Pretty_print_sail module Slice = Slice +module Gdbmi = Gdbmi type mode = | Evaluation of frame @@ -108,27 +109,72 @@ let sail_logo = in List.map banner logo @ [""] @ help @ [""] -let vs_ids = ref (val_spec_ids !Interactive.ast) +let sep = "-----------------------------------------------------" |> Util.blue |> Util.clear -let interactive_state = ref (initial_state ~registers:false !Interactive.ast !Interactive.env Value.primops) +let vs_ids = ref (val_spec_ids !Interactive.ast) -let sep = "-----------------------------------------------------" |> Util.blue |> Util.clear +let interactive_state = ref (initial_state ~registers:false !Interactive.ast !Interactive.env !Value.primops) +(* We can't set up the elf commands in elf_loader.ml because it's used + by Sail OCaml emulators at runtime, so set them up here. *) let () = let open Interactive in let open Elf_loader in - let open Printf in - register_command ~name:"elf" ~help:(sprintf ":elf %s - Load an elf file" (arg "file")) load_elf; + ArgString ("file", fun file -> Action (fun () -> load_elf file)) + |> register_command ~name:"elf" ~help:"Load an elf file"; + + ArgString ("addr", fun addr_s -> ArgString ("file", fun filename -> Action (fun () -> + let addr = Big_int.of_string addr_s in + load_binary addr filename + ))) |> register_command ~name:"bin" ~help:"Load a raw binary file at :0. Use :elf to load an ELF" - (fun iarg -> - match Util.split_on_char ' ' iarg with - | [addr_s; filename] -> - let addr = Big_int.of_string addr_s in - load_binary addr filename - | _ -> - printf "Invalid argument for :bin, expected %s %s" (arg "addr") (arg "file") - ) |> register_command ~name:"bin" ~help:(sprintf ":bin %s %s - Load a binary file at a given address" (arg "addr") (arg "file")) +(* This is a feature that lets us take interpreter commands like :foo + x, y and turn the into functions that can be called by sail as + foo(x, y), which lets us use sail to script itself. The + sail_scripting_primops_once variable ensures we only add the + commands to the interpreter primops list once, although we may have + to reset the AST and env changes when we :load and :unload + files by calling this function multiple times. *) +let sail_scripting_primops_once = ref true + +let setup_sail_scripting () = + let open Interactive in + + let sail_command_name cmd = "sail_" ^ String.sub cmd 1 (String.length cmd - 1) in + + let val_specs = + List.map (fun (cmd, (_, action)) -> + let name = sail_command_name cmd in + let typschm = mk_typschm (mk_typquant []) (reflect_typ action) in + mk_val_spec (VS_val_spec (typschm, mk_id name, [("_", name)], false)) + ) !commands in + let val_specs, env' = Type_check.check !env (Defs val_specs) in + ast := append_ast !ast val_specs; + env := env'; + + if !sail_scripting_primops_once then ( + List.iter (fun (cmd, (help, action)) -> + let open Value in + let name = sail_command_name cmd in + let impl values = + let rec call values action = + match values, action with + | (v :: vs), ArgString (_, next) -> + call vs (next (coerce_string v)) + | (v :: vs), ArgInt (_, next) -> + call vs (next (Big_int.to_int (coerce_int v))) + | _, Action act -> + act (); V_unit + | _, _ -> + failwith help + in + call values action + in + Value.add_primop name impl + ) !commands; + sail_scripting_primops_once := false + ) let print_program () = match !current_mode with @@ -169,7 +215,7 @@ let rec run () = | Effect_request (out, state, stack, eff) -> begin try - current_mode := Evaluation (Interpreter.default_effect_interp state eff) + current_mode := Evaluation (!Interpreter.effect_interp state eff) with | Failure str -> print_endline str; current_mode := Normal end; @@ -204,7 +250,7 @@ let rec run_steps n = | Effect_request (out, state, stack, eff) -> begin try - current_mode := Evaluation (Interpreter.default_effect_interp state eff) + current_mode := Evaluation (!Interpreter.effect_interp state eff) with | Failure str -> print_endline str; current_mode := Normal end; @@ -282,7 +328,7 @@ let help = (color green ":commands") (color green ":help") (color yellow "<command>") | cmd -> match List.assoc_opt cmd !Interactive.commands with - | Some (help, _) -> help + | Some (help_message, action) -> Interactive.generate_help cmd help_message action | None -> sprintf "Either invalid command passed to help, or no documentation for %s. Try %s." (color green cmd) (color green ":help :help") @@ -347,7 +393,7 @@ let load_session upto file = | Some upto_file when Filename.basename upto_file = file -> None | Some upto_file -> let (_, ast, env) = - load_files ~check:true !Interactive.env [Filename.concat (Filename.dirname upto_file) file] + Process_file.load_files ~check:true options !Interactive.env [Filename.concat (Filename.dirname upto_file) file] in Interactive.ast := append_ast !Interactive.ast ast; Interactive.env := env; @@ -463,15 +509,15 @@ let handle_input' input = begin match cmd with | ":l" | ":load" -> let files = Util.split_on_char ' ' arg in - let (_, ast, env) = load_files !Interactive.env files in + let (_, ast, env) = Process_file.load_files options !Interactive.env files in Interactive.ast := append_ast !Interactive.ast ast; - interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops; + interactive_state := initial_state !Interactive.ast !Interactive.env !Value.primops; Interactive.env := env; vs_ids := val_spec_ids !Interactive.ast | ":u" | ":unload" -> Interactive.ast := Ast.Defs []; Interactive.env := Type_check.initial_env; - interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops; + interactive_state := initial_state !Interactive.ast !Interactive.env !Value.primops; vs_ids := val_spec_ids !Interactive.ast; (* See initial_check.mli for an explanation of why we need this. *) Initial_check.have_undefined_builtins := false; @@ -493,7 +539,7 @@ let handle_input' input = let ast, env = Type_check.check !Interactive.env (Defs [DEF_val (mk_letbind (mk_pat (P_id (mk_id v))) exp)]) in Interactive.ast := append_ast !Interactive.ast ast; Interactive.env := env; - interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops; + interactive_state := initial_state !Interactive.ast !Interactive.env !Value.primops; | _ -> print_endline "Invalid arguments for :let" end | ":def" -> @@ -501,7 +547,7 @@ let handle_input' input = let ast, env = Type_check.check !Interactive.env ast in Interactive.ast := append_ast !Interactive.ast ast; Interactive.env := env; - interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops; + interactive_state := initial_state !Interactive.ast !Interactive.env !Value.primops; | ":list_rewrites" -> let print_rewrite (name, rw) = print_endline (name ^ " " ^ Util.(String.concat " " (describe_rewrite rw) |> yellow |> clear)) @@ -537,17 +583,17 @@ let handle_input' input = let new_ast, new_env = Process_file.rewrite_ast_target arg !Interactive.env !Interactive.ast in Interactive.ast := new_ast; Interactive.env := new_env; - interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops + interactive_state := initial_state !Interactive.ast !Interactive.env !Value.primops | ":prover_regstate" -> let env, ast = prover_regstate (Some arg) !Interactive.ast !Interactive.env in Interactive.env := env; Interactive.ast := ast; - interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops + interactive_state := initial_state !Interactive.ast !Interactive.env !Value.primops | ":recheck" -> let ast, env = Type_check.check Type_check.initial_env !Interactive.ast in Interactive.env := env; Interactive.ast := ast; - interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops; + interactive_state := initial_state !Interactive.ast !Interactive.env !Value.primops; vs_ids := val_spec_ids !Interactive.ast | ":recheck_types" -> let ast, env = Type_check.check Type_check.initial_env !Interactive.ast in @@ -555,14 +601,14 @@ let handle_input' input = Interactive.ast := ast; vs_ids := val_spec_ids !Interactive.ast | ":compile" -> - let out_name = match !opt_file_out with + let out_name = match !Process_file.opt_file_out with | None -> "out.sail" | Some f -> f ^ ".sail" in target (Some arg) out_name !Interactive.ast !Interactive.env | _ -> match List.assoc_opt cmd !Interactive.commands with - | Some (_, action) -> action arg + | Some (_, action) -> Interactive.run_action cmd arg action | None -> unrecognised_command cmd end | Expression str -> @@ -582,9 +628,9 @@ let handle_input' input = begin try load_into_session arg; - let (_, ast, env) = load_files ~check:true !Interactive.env [arg] in + let (_, ast, env) = Process_file.load_files ~check:true options !Interactive.env [arg] in Interactive.ast := append_ast !Interactive.ast ast; - interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops; + interactive_state := initial_state !Interactive.ast !Interactive.env !Value.primops; Interactive.env := env; vs_ids := val_spec_ids !Interactive.ast; print_endline ("(message \"Checked " ^ arg ^ " done\")\n"); @@ -595,7 +641,7 @@ let handle_input' input = | ":unload" -> Interactive.ast := Ast.Defs []; Interactive.env := Type_check.initial_env; - interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops; + interactive_state := initial_state !Interactive.ast !Interactive.env !Value.primops; vs_ids := val_spec_ids !Interactive.ast; Initial_check.have_undefined_builtins := false; Process_file.clear_symbols () @@ -670,7 +716,7 @@ let handle_input' input = begin try interactive_state := state; - current_mode := Evaluation (Interpreter.default_effect_interp state eff); + current_mode := Evaluation (!Interpreter.effect_interp state eff); print_program () with | Failure str -> print_endline str; current_mode := Normal @@ -774,28 +820,26 @@ let () = ); (* Read the script file if it is set with the -is option, and excute them *) - begin - match !opt_interactive_script with - | None -> () - | Some file -> - let chan = open_in file in - try - while true do - let line = input_line chan in - handle_input line; - done; - with - | End_of_file -> () + begin match !opt_interactive_script with + | None -> () + | Some file -> + let chan = open_in file in + try + while true do + let line = input_line chan in + handle_input line; + done; + with + | End_of_file -> () end; LNoise.history_load ~filename:"sail_history" |> ignore; LNoise.history_set ~max_length:100 |> ignore; - if !Interactive.opt_interactive then - begin - if not !Interactive.opt_emacs_mode then - List.iter print_endline sail_logo - else (current_mode := Emacs; Util.opt_colors := false); - user_input handle_input - end - else () + if !Interactive.opt_interactive then ( + if not !Interactive.opt_emacs_mode then + List.iter print_endline sail_logo + else (current_mode := Emacs; Util.opt_colors := false); + setup_sail_scripting (); + user_input handle_input + ) diff --git a/src/jib/c_backend.ml b/src/jib/c_backend.ml index 98ee5bc1..2b144d35 100644 --- a/src/jib/c_backend.ml +++ b/src/jib/c_backend.ml @@ -100,7 +100,9 @@ let zencode_uid (id, ctyps) = match ctyps with | [] -> Util.zencode_string (string_of_id id) | _ -> Util.zencode_string (string_of_id id ^ "#" ^ Util.string_of_list "_" string_of_ctyp ctyps) - + +let ctor_bindings = List.fold_left (fun map (id, ctyp) -> UBindings.add id ctyp map) UBindings.empty + (**************************************************************************) (* 2. Converting sail types to C types *) (**************************************************************************) @@ -108,90 +110,9 @@ let zencode_uid (id, ctyps) = let max_int n = Big_int.pred (Big_int.pow_int_positive 2 (n - 1)) let min_int n = Big_int.negate (Big_int.pow_int_positive 2 (n - 1)) -(** Convert a sail type into a C-type. This function can be quite - slow, because it uses ctx.local_env and SMT to analyse the Sail - types and attempts to fit them into the smallest possible C - types, provided ctx.optimize_smt is true (default) **) -let rec ctyp_of_typ ctx typ = - let Typ_aux (typ_aux, l) as typ = Env.expand_synonyms ctx.tc_env typ in - match typ_aux with - | Typ_id id when string_of_id id = "bit" -> CT_bit - | Typ_id id when string_of_id id = "bool" -> CT_bool - | Typ_id id when string_of_id id = "int" -> CT_lint - | Typ_id id when string_of_id id = "nat" -> CT_lint - | Typ_id id when string_of_id id = "unit" -> CT_unit - | Typ_id id when string_of_id id = "string" -> CT_string - | Typ_id id when string_of_id id = "real" -> CT_real - - | Typ_app (id, _) when string_of_id id = "atom_bool" -> CT_bool - - | Typ_app (id, args) when string_of_id id = "itself" -> - ctyp_of_typ ctx (Typ_aux (Typ_app (mk_id "atom", args), l)) - | Typ_app (id, _) when string_of_id id = "range" || string_of_id id = "atom" || string_of_id id = "implicit" -> - begin match destruct_range Env.empty typ with - | None -> assert false (* Checked if range type in guard *) - | Some (kids, constr, n, m) -> - let ctx = { ctx with local_env = add_existential Parse_ast.Unknown (List.map (mk_kopt K_int) kids) constr ctx.local_env }in - match nexp_simp n, nexp_simp m with - | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) - when Big_int.less_equal (min_int 64) n && Big_int.less_equal m (max_int 64) -> - CT_fint 64 - | n, m -> - if prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) then - CT_fint 64 - else - CT_lint - end - - | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" -> - CT_list (ctyp_of_typ ctx typ) - - (* When converting a sail bitvector type into C, we have three options in order of efficiency: - - If the length is obviously static and smaller than 64, use the fixed bits type (aka uint64_t), fbits. - - If the length is less than 64, then use a small bits type, sbits. - - If the length may be larger than 64, use a large bits type lbits. *) - | Typ_app (id, [A_aux (A_nexp n, _); - A_aux (A_order ord, _)]) - when string_of_id id = "bitvector" -> - 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 prove __POS__ ctx.local_env (nc_lteq n (nint 64)) -> CT_sbits (64, direction) - | _ -> CT_lbits direction - end - - | Typ_app (id, [A_aux (A_nexp n, _); - A_aux (A_order ord, _); - A_aux (A_typ typ, _)]) - when string_of_id id = "vector" -> - let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in - CT_vector (direction, ctyp_of_typ ctx typ) - - | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "register" -> - CT_ref (ctyp_of_typ ctx typ) - - | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.records -> CT_struct (id, Bindings.find id ctx.records |> UBindings.bindings) - | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.variants -> CT_variant (id, Bindings.find id ctx.variants |> UBindings.bindings) - | Typ_id id when Bindings.mem id ctx.enums -> CT_enum (id, Bindings.find id ctx.enums |> IdSet.elements) - - | Typ_tup typs -> CT_tup (List.map (ctyp_of_typ ctx) typs) - - | Typ_exist _ -> - (* Use Type_check.destruct_exist when optimising with SMT, to - ensure that we don't cause any type variable clashes in - local_env, and that we can optimize the existential based upon - it's constraints. *) - begin match destruct_exist (Env.expand_synonyms ctx.local_env typ) with - | Some (kids, nc, typ) -> - let env = add_existential l kids nc ctx.local_env in - ctyp_of_typ { ctx with local_env = env } typ - | None -> raise (Reporting.err_unreachable l __POS__ "Existential cannot be destructured!") - end - - | Typ_var kid -> CT_poly - - | _ -> c_error ~loc:l ("No C type for type " ^ string_of_typ typ) - +(** This function is used to split types into those we allocate on the + stack, versus those which need to live on the heap, or otherwise + require some additional memory management *) let rec is_stack_ctyp ctyp = match ctyp with | CT_fbits _ | CT_sbits _ | CT_bit | CT_unit | CT_bool | CT_enum _ -> true | CT_fint n -> n <= 64 @@ -199,7 +120,7 @@ let rec is_stack_ctyp ctyp = match ctyp with | CT_lint -> false | CT_lbits _ when !optimize_fixed_bits -> true | CT_lbits _ -> false - | CT_real | CT_string | CT_list _ | CT_vector _ -> false + | CT_real | CT_string | CT_list _ | CT_vector _ | CT_fvector _ -> false | CT_struct (_, fields) -> List.for_all (fun (_, ctyp) -> is_stack_ctyp ctyp) fields | CT_variant (_, ctors) -> false (* List.for_all (fun (_, ctyp) -> is_stack_ctyp ctyp) ctors *) (* FIXME *) | CT_tup ctyps -> List.for_all is_stack_ctyp ctyps @@ -207,346 +128,442 @@ let rec is_stack_ctyp ctyp = match ctyp with | CT_poly -> true | CT_constant n -> Big_int.less_equal (min_int 64) n && Big_int.greater_equal n (max_int 64) -let is_stack_typ ctx typ = is_stack_ctyp (ctyp_of_typ ctx typ) - -let is_fbits_typ ctx typ = - match ctyp_of_typ ctx typ with - | CT_fbits _ -> true - | _ -> false - -let is_sbits_typ ctx typ = - match ctyp_of_typ ctx typ with - | CT_sbits _ -> true - | _ -> false - -let ctor_bindings = List.fold_left (fun map (id, ctyp) -> UBindings.add id ctyp map) UBindings.empty - -(**************************************************************************) -(* 3. Optimization of primitives and literals *) -(**************************************************************************) - -let hex_char = - let open Sail2_values in - function - | '0' -> [B0; B0; B0; B0] - | '1' -> [B0; B0; B0; B1] - | '2' -> [B0; B0; B1; B0] - | '3' -> [B0; B0; B1; B1] - | '4' -> [B0; B1; B0; B0] - | '5' -> [B0; B1; B0; B1] - | '6' -> [B0; B1; B1; B0] - | '7' -> [B0; B1; B1; B1] - | '8' -> [B1; B0; B0; B0] - | '9' -> [B1; B0; B0; B1] - | 'A' | 'a' -> [B1; B0; B1; B0] - | 'B' | 'b' -> [B1; B0; B1; B1] - | 'C' | 'c' -> [B1; B1; B0; B0] - | 'D' | 'd' -> [B1; B1; B0; B1] - | 'E' | 'e' -> [B1; B1; B1; B0] - | 'F' | 'f' -> [B1; B1; B1; B1] - | _ -> failwith "Invalid hex character" - -let literal_to_fragment (L_aux (l_aux, _) as lit) = - match l_aux with - | L_num n when Big_int.less_equal (min_int 64) n && Big_int.less_equal n (max_int 64) -> - Some (V_lit (VL_int n, CT_fint 64)) - | L_hex str when String.length str <= 16 -> - let padding = 16 - String.length str in - let padding = Util.list_init padding (fun _ -> Sail2_values.B0) in - let content = Util.string_to_list str |> List.map hex_char |> List.concat in - Some (V_lit (VL_bits (padding @ content, true), CT_fbits (String.length str * 4, true))) - | L_unit -> Some (V_lit (VL_unit, CT_unit)) - | L_true -> Some (V_lit (VL_bool true, CT_bool)) - | L_false -> Some (V_lit (VL_bool false, CT_bool)) - | _ -> None - -let c_literals ctx = - let rec c_literal env l = function - | AV_lit (lit, typ) as v when is_stack_ctyp (ctyp_of_typ { ctx with local_env = env } typ) -> - begin - match literal_to_fragment lit with - | Some cval -> AV_cval (cval, typ) - | None -> v - end - | AV_tuple avals -> AV_tuple (List.map (c_literal env l) avals) - | v -> v - in - map_aval c_literal - -let rec is_bitvector = function - | [] -> true - | AV_lit (L_aux (L_zero, _), _) :: avals -> is_bitvector avals - | AV_lit (L_aux (L_one, _), _) :: avals -> is_bitvector avals - | _ :: _ -> false - -let rec value_of_aval_bit = function - | AV_lit (L_aux (L_zero, _), _) -> Sail2_values.B0 - | AV_lit (L_aux (L_one, _), _) -> Sail2_values.B1 - | _ -> assert false - -(** Used to make sure the -Ofixed_int and -Ofixed_bits don't interfere - with assumptions made about optimizations in the common case. *) -let rec never_optimize = function - | CT_lbits _ | CT_lint -> true - | _ -> false - -let rec c_aval ctx = function - | AV_lit (lit, typ) as v -> - begin - match literal_to_fragment lit with - | Some cval -> AV_cval (cval, typ) - | None -> v - end - | AV_cval (cval, typ) -> AV_cval (cval, typ) - (* An id can be converted to a C fragment if it's type can be - stack-allocated. *) - | AV_id (id, lvar) as v -> - begin - match lvar with - | Local (_, typ) -> - let ctyp = ctyp_of_typ ctx typ in - if is_stack_ctyp ctyp && not (never_optimize ctyp) then - begin - try - (* We need to check that id's type hasn't changed due to flow typing *) - let _, ctyp' = Bindings.find id ctx.locals in - if ctyp_equal ctyp ctyp' then - AV_cval (V_id (name id, ctyp), typ) - else - (* id's type changed due to flow - typing, so it's really still heap allocated! *) - v - with - (* Hack: Assuming global letbindings don't change from flow typing... *) - Not_found -> AV_cval (V_id (name id, ctyp), typ) - end - else - v - | Register (_, _, typ) -> - let ctyp = ctyp_of_typ ctx typ in - if is_stack_ctyp ctyp && not (never_optimize ctyp) then - AV_cval (V_id (name id, ctyp), typ) - else - v - | _ -> v - end - | AV_vector (v, typ) when is_bitvector v && List.length v <= 64 -> - let bitstring = VL_bits (List.map value_of_aval_bit v, true) in - AV_cval (V_lit (bitstring, CT_fbits (List.length v, true)), typ) - | AV_tuple avals -> AV_tuple (List.map (c_aval ctx) avals) - | aval -> aval - -let c_fragment = function - | AV_cval (cval, _) -> cval - | _ -> assert false - let v_mask_lower i = V_lit (VL_bits (Util.list_init i (fun _ -> Sail2_values.B1), true), CT_fbits (i, true)) -(* Map over all the functions in an aexp. *) -let rec analyze_functions ctx f (AE_aux (aexp, env, l)) = - let ctx = { ctx with local_env = env } in - let aexp = match aexp with - | AE_app (id, vs, typ) -> f ctx id vs typ +module C_config : Config = struct - | AE_cast (aexp, typ) -> AE_cast (analyze_functions ctx f aexp, typ) +(** Convert a sail type into a C-type. This function can be quite + slow, because it uses ctx.local_env and SMT to analyse the Sail + types and attempts to fit them into the smallest possible C + types, provided ctx.optimize_smt is true (default) **) + let rec convert_typ ctx typ = + let Typ_aux (typ_aux, l) as typ = Env.expand_synonyms ctx.tc_env typ in + match typ_aux with + | Typ_id id when string_of_id id = "bit" -> CT_bit + | Typ_id id when string_of_id id = "bool" -> CT_bool + | Typ_id id when string_of_id id = "int" -> CT_lint + | Typ_id id when string_of_id id = "nat" -> CT_lint + | Typ_id id when string_of_id id = "unit" -> CT_unit + | Typ_id id when string_of_id id = "string" -> CT_string + | Typ_id id when string_of_id id = "real" -> CT_real + + | Typ_app (id, _) when string_of_id id = "atom_bool" -> CT_bool + + | Typ_app (id, args) when string_of_id id = "itself" -> + convert_typ ctx (Typ_aux (Typ_app (mk_id "atom", args), l)) + | Typ_app (id, _) when string_of_id id = "range" || string_of_id id = "atom" || string_of_id id = "implicit" -> + begin match destruct_range Env.empty typ with + | None -> assert false (* Checked if range type in guard *) + | Some (kids, constr, n, m) -> + let ctx = { ctx with local_env = add_existential Parse_ast.Unknown (List.map (mk_kopt K_int) kids) constr ctx.local_env }in + match nexp_simp n, nexp_simp m with + | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) + when Big_int.less_equal (min_int 64) n && Big_int.less_equal m (max_int 64) -> + CT_fint 64 + | n, m -> + if prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) then + CT_fint 64 + else + CT_lint + end - | AE_assign (id, typ, aexp) -> AE_assign (id, typ, analyze_functions ctx f aexp) + | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" -> + CT_list (convert_typ ctx typ) + + (* When converting a sail bitvector type into C, we have three options in order of efficiency: + - If the length is obviously static and smaller than 64, use the fixed bits type (aka uint64_t), fbits. + - If the length is less than 64, then use a small bits type, sbits. + - If the length may be larger than 64, use a large bits type lbits. *) + | Typ_app (id, [A_aux (A_nexp n, _); + A_aux (A_order ord, _)]) + when string_of_id id = "bitvector" -> + 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 prove __POS__ ctx.local_env (nc_lteq n (nint 64)) -> CT_sbits (64, direction) + | _ -> CT_lbits direction + end - | AE_write_ref (id, typ, aexp) -> AE_write_ref (id, typ, analyze_functions ctx f aexp) + | Typ_app (id, [A_aux (A_nexp n, _); + A_aux (A_order ord, _); + A_aux (A_typ typ, _)]) + when string_of_id id = "vector" -> + let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in + CT_vector (direction, convert_typ ctx typ) + + | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "register" -> + CT_ref (convert_typ ctx typ) + + | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.records -> CT_struct (id, Bindings.find id ctx.records |> UBindings.bindings) + | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.variants -> CT_variant (id, Bindings.find id ctx.variants |> UBindings.bindings) + | Typ_id id when Bindings.mem id ctx.enums -> CT_enum (id, Bindings.find id ctx.enums |> IdSet.elements) + + | Typ_tup typs -> CT_tup (List.map (convert_typ ctx) typs) + + | Typ_exist _ -> + (* Use Type_check.destruct_exist when optimising with SMT, to + ensure that we don't cause any type variable clashes in + local_env, and that we can optimize the existential based + upon it's constraints. *) + begin match destruct_exist (Env.expand_synonyms ctx.local_env typ) with + | Some (kids, nc, typ) -> + let env = add_existential l kids nc ctx.local_env in + convert_typ { ctx with local_env = env } typ + | None -> raise (Reporting.err_unreachable l __POS__ "Existential cannot be destructured!") + end - | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, aval, analyze_functions ctx f aexp) + | Typ_var kid -> CT_poly - | AE_let (mut, id, typ1, aexp1, (AE_aux (_, env2, _) as aexp2), typ2) -> - let aexp1 = analyze_functions ctx f aexp1 in - (* Use aexp2's environment because it will contain constraints for id *) - let ctyp1 = ctyp_of_typ { ctx with local_env = env2 } typ1 in - let ctx = { ctx with locals = Bindings.add id (mut, ctyp1) ctx.locals } in - AE_let (mut, id, typ1, aexp1, analyze_functions ctx f aexp2, typ2) + | _ -> c_error ~loc:l ("No C type for type " ^ string_of_typ typ) - | AE_block (aexps, aexp, typ) -> AE_block (List.map (analyze_functions ctx f) aexps, analyze_functions ctx f aexp, typ) + let is_stack_typ ctx typ = is_stack_ctyp (convert_typ ctx typ) - | AE_if (aval, aexp1, aexp2, typ) -> - AE_if (aval, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2, typ) + let is_fbits_typ ctx typ = + match convert_typ ctx typ with + | CT_fbits _ -> true + | _ -> false - | AE_loop (loop_typ, aexp1, aexp2) -> AE_loop (loop_typ, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2) + let is_sbits_typ ctx typ = + match convert_typ ctx typ with + | CT_sbits _ -> true + | _ -> false - | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> - let aexp1 = analyze_functions ctx f aexp1 in - let aexp2 = analyze_functions ctx f aexp2 in - let aexp3 = analyze_functions ctx f aexp3 in - let aexp4 = analyze_functions ctx f aexp4 in - (* Currently we assume that loop indexes are always safe to put into an int64 *) - let ctx = { ctx with locals = Bindings.add id (Immutable, CT_fint 64) ctx.locals } in - AE_for (id, aexp1, aexp2, aexp3, order, aexp4) + (**************************************************************************) + (* 3. Optimization of primitives and literals *) + (**************************************************************************) + + let hex_char = + let open Sail2_values in + function + | '0' -> [B0; B0; B0; B0] + | '1' -> [B0; B0; B0; B1] + | '2' -> [B0; B0; B1; B0] + | '3' -> [B0; B0; B1; B1] + | '4' -> [B0; B1; B0; B0] + | '5' -> [B0; B1; B0; B1] + | '6' -> [B0; B1; B1; B0] + | '7' -> [B0; B1; B1; B1] + | '8' -> [B1; B0; B0; B0] + | '9' -> [B1; B0; B0; B1] + | 'A' | 'a' -> [B1; B0; B1; B0] + | 'B' | 'b' -> [B1; B0; B1; B1] + | 'C' | 'c' -> [B1; B1; B0; B0] + | 'D' | 'd' -> [B1; B1; B0; B1] + | 'E' | 'e' -> [B1; B1; B1; B0] + | 'F' | 'f' -> [B1; B1; B1; B1] + | _ -> failwith "Invalid hex character" + + let literal_to_fragment (L_aux (l_aux, _) as lit) = + match l_aux with + | L_num n when Big_int.less_equal (min_int 64) n && Big_int.less_equal n (max_int 64) -> + Some (V_lit (VL_int n, CT_fint 64)) + | L_hex str when String.length str <= 16 -> + let padding = 16 - String.length str in + let padding = Util.list_init padding (fun _ -> Sail2_values.B0) in + let content = Util.string_to_list str |> List.map hex_char |> List.concat in + Some (V_lit (VL_bits (padding @ content, true), CT_fbits (String.length str * 4, true))) + | L_unit -> Some (V_lit (VL_unit, CT_unit)) + | L_true -> Some (V_lit (VL_bool true, CT_bool)) + | L_false -> Some (V_lit (VL_bool false, CT_bool)) + | _ -> None + + let c_literals ctx = + let rec c_literal env l = function + | AV_lit (lit, typ) as v when is_stack_ctyp (convert_typ { ctx with local_env = env } typ) -> + begin + match literal_to_fragment lit with + | Some cval -> AV_cval (cval, typ) + | None -> v + end + | AV_tuple avals -> AV_tuple (List.map (c_literal env l) avals) + | v -> v + in + map_aval c_literal + + let rec is_bitvector = function + | [] -> true + | AV_lit (L_aux (L_zero, _), _) :: avals -> is_bitvector avals + | AV_lit (L_aux (L_one, _), _) :: avals -> is_bitvector avals + | _ :: _ -> false + + let rec value_of_aval_bit = function + | AV_lit (L_aux (L_zero, _), _) -> Sail2_values.B0 + | AV_lit (L_aux (L_one, _), _) -> Sail2_values.B1 + | _ -> assert false + + (** Used to make sure the -Ofixed_int and -Ofixed_bits don't + interfere with assumptions made about optimizations in the common + case. *) + let rec never_optimize = function + | CT_lbits _ | CT_lint -> true + | _ -> false - | AE_case (aval, cases, typ) -> - let analyze_case (AP_aux (_, env, _) as pat, aexp1, aexp2) = - let pat_bindings = Bindings.bindings (apat_types pat) in - let ctx = { ctx with local_env = env } in - let ctx = - List.fold_left (fun ctx (id, typ) -> { ctx with locals = Bindings.add id (Immutable, ctyp_of_typ ctx typ) ctx.locals }) ctx pat_bindings + let rec c_aval ctx = function + | AV_lit (lit, typ) as v -> + begin + match literal_to_fragment lit with + | Some cval -> AV_cval (cval, typ) + | None -> v + end + | AV_cval (cval, typ) -> AV_cval (cval, typ) + (* An id can be converted to a C fragment if it's type can be + stack-allocated. *) + | AV_id (id, lvar) as v -> + begin + match lvar with + | Local (_, typ) -> + let ctyp = convert_typ ctx typ in + if is_stack_ctyp ctyp && not (never_optimize ctyp) then + begin + try + (* We need to check that id's type hasn't changed due to flow typing *) + let _, ctyp' = Bindings.find id ctx.locals in + if ctyp_equal ctyp ctyp' then + AV_cval (V_id (name id, ctyp), typ) + else + (* id's type changed due to flow typing, so it's + really still heap allocated! *) + v + with + (* Hack: Assuming global letbindings don't change from flow typing... *) + Not_found -> AV_cval (V_id (name id, ctyp), typ) + end + else + v + | Register (_, _, typ) -> + let ctyp = convert_typ ctx typ in + if is_stack_ctyp ctyp && not (never_optimize ctyp) then + AV_cval (V_id (name id, ctyp), typ) + else + v + | _ -> v + end + | AV_vector (v, typ) when is_bitvector v && List.length v <= 64 -> + let bitstring = VL_bits (List.map value_of_aval_bit v, true) in + AV_cval (V_lit (bitstring, CT_fbits (List.length v, true)), typ) + | AV_tuple avals -> AV_tuple (List.map (c_aval ctx) avals) + | aval -> aval + + let c_fragment = function + | AV_cval (cval, _) -> cval + | _ -> assert false + + (* Map over all the functions in an aexp. *) + let rec analyze_functions ctx f (AE_aux (aexp, env, l)) = + let ctx = { ctx with local_env = env } in + let aexp = match aexp with + | AE_app (id, vs, typ) -> f ctx id vs typ + + | AE_cast (aexp, typ) -> AE_cast (analyze_functions ctx f aexp, typ) + + | AE_assign (id, typ, aexp) -> AE_assign (id, typ, analyze_functions ctx f aexp) + + | AE_write_ref (id, typ, aexp) -> AE_write_ref (id, typ, analyze_functions ctx f aexp) + + | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, aval, analyze_functions ctx f aexp) + + | AE_let (mut, id, typ1, aexp1, (AE_aux (_, env2, _) as aexp2), typ2) -> + let aexp1 = analyze_functions ctx f aexp1 in + (* Use aexp2's environment because it will contain constraints for id *) + let ctyp1 = convert_typ { ctx with local_env = env2 } typ1 in + let ctx = { ctx with locals = Bindings.add id (mut, ctyp1) ctx.locals } in + AE_let (mut, id, typ1, aexp1, analyze_functions ctx f aexp2, typ2) + + | AE_block (aexps, aexp, typ) -> AE_block (List.map (analyze_functions ctx f) aexps, analyze_functions ctx f aexp, typ) + + | AE_if (aval, aexp1, aexp2, typ) -> + AE_if (aval, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2, typ) + + | AE_loop (loop_typ, aexp1, aexp2) -> AE_loop (loop_typ, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2) + + | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> + let aexp1 = analyze_functions ctx f aexp1 in + let aexp2 = analyze_functions ctx f aexp2 in + let aexp3 = analyze_functions ctx f aexp3 in + let aexp4 = analyze_functions ctx f aexp4 in + (* Currently we assume that loop indexes are always safe to put into an int64 *) + let ctx = { ctx with locals = Bindings.add id (Immutable, CT_fint 64) ctx.locals } in + AE_for (id, aexp1, aexp2, aexp3, order, aexp4) + + | AE_case (aval, cases, typ) -> + let analyze_case (AP_aux (_, env, _) as pat, aexp1, aexp2) = + let pat_bindings = Bindings.bindings (apat_types pat) in + let ctx = { ctx with local_env = env } in + let ctx = + List.fold_left (fun ctx (id, typ) -> { ctx with locals = Bindings.add id (Immutable, convert_typ ctx typ) ctx.locals }) ctx pat_bindings + in + pat, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2 in - pat, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2 - in - AE_case (aval, List.map analyze_case cases, typ) + AE_case (aval, List.map analyze_case cases, typ) - | AE_try (aexp, cases, typ) -> - AE_try (analyze_functions ctx f aexp, List.map (fun (pat, aexp1, aexp2) -> pat, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2) cases, typ) + | AE_try (aexp, cases, typ) -> + AE_try (analyze_functions ctx f aexp, List.map (fun (pat, aexp1, aexp2) -> pat, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2) cases, typ) - | AE_field _ | AE_record_update _ | AE_val _ | AE_return _ | AE_throw _ as v -> v - in - AE_aux (aexp, env, l) + | AE_field _ | AE_record_update _ | AE_val _ | AE_return _ | AE_throw _ as v -> v + in + AE_aux (aexp, env, l) -let analyze_primop' ctx id args typ = - let no_change = AE_app (id, args, typ) in - let args = List.map (c_aval ctx) args in - let extern = if Env.is_extern id ctx.tc_env "c" then Env.get_extern id ctx.tc_env "c" else failwith "Not extern" in + let analyze_primop' ctx id args typ = + let no_change = AE_app (id, args, typ) in + let args = List.map (c_aval ctx) args in + let extern = if Env.is_extern id ctx.tc_env "c" then Env.get_extern id ctx.tc_env "c" else failwith "Not extern" in - let v_one = V_lit (VL_int (Big_int.of_int 1), CT_fint 64) in - let v_int n = V_lit (VL_int (Big_int.of_int n), CT_fint 64) in + let v_one = V_lit (VL_int (Big_int.of_int 1), CT_fint 64) in + let v_int n = V_lit (VL_int (Big_int.of_int n), CT_fint 64) in - match extern, args with - | "eq_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> - begin match cval_ctyp v1 with - | CT_fbits _ | CT_sbits _ -> + match extern, args with + | "eq_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> + begin match cval_ctyp v1 with + | CT_fbits _ | CT_sbits _ -> AE_val (AV_cval (V_call (Eq, [v1; v2]), typ)) - | _ -> no_change - end + | _ -> no_change + end - | "neq_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> - begin match cval_ctyp v1 with - | CT_fbits _ | CT_sbits _ -> - AE_val (AV_cval (V_call (Neq, [v1; v2]), typ)) - | _ -> no_change - end + | "neq_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> + begin match cval_ctyp v1 with + | CT_fbits _ | CT_sbits _ -> + AE_val (AV_cval (V_call (Neq, [v1; v2]), typ)) + | _ -> no_change + end - | "eq_int", [AV_cval (v1, _); AV_cval (v2, _)] -> - AE_val (AV_cval (V_call (Eq, [v1; v2]), typ)) + | "eq_int", [AV_cval (v1, _); AV_cval (v2, _)] -> + AE_val (AV_cval (V_call (Eq, [v1; v2]), typ)) - | "eq_bit", [AV_cval (v1, _); AV_cval (v2, _)] -> - AE_val (AV_cval (V_call (Eq, [v1; v2]), typ)) + | "eq_bit", [AV_cval (v1, _); AV_cval (v2, _)] -> + AE_val (AV_cval (V_call (Eq, [v1; v2]), typ)) - | "zeros", [_] -> - begin match destruct_vector ctx.tc_env typ with - | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) - when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> - let n = Big_int.to_int n in - AE_val (AV_cval (V_lit (VL_bits (Util.list_init n (fun _ -> Sail2_values.B0), true), CT_fbits (n, true)), typ)) - | _ -> no_change - end + | "zeros", [_] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> + let n = Big_int.to_int n in + AE_val (AV_cval (V_lit (VL_bits (Util.list_init n (fun _ -> Sail2_values.B0), true), CT_fbits (n, true)), typ)) + | _ -> no_change + end - | "zero_extend", [AV_cval (v, _); _] -> - begin match destruct_vector ctx.tc_env typ with - | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) - when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> - AE_val (AV_cval (V_call (Zero_extend (Big_int.to_int n), [v]), typ)) - | _ -> no_change - end + | "zero_extend", [AV_cval (v, _); _] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> + AE_val (AV_cval (V_call (Zero_extend (Big_int.to_int n), [v]), typ)) + | _ -> no_change + end - | "sign_extend", [AV_cval (v, _); _] -> - begin match destruct_vector ctx.tc_env typ with - | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) - when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> - AE_val (AV_cval (V_call (Sign_extend (Big_int.to_int n), [v]), typ)) - | _ -> no_change - end + | "sign_extend", [AV_cval (v, _); _] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> + AE_val (AV_cval (V_call (Sign_extend (Big_int.to_int n), [v]), typ)) + | _ -> no_change + end - | "lteq", [AV_cval (v1, _); AV_cval (v2, _)] -> - AE_val (AV_cval (V_call (Ilteq, [v1; v2]), typ)) - | "gteq", [AV_cval (v1, _); AV_cval (v2, _)] -> - AE_val (AV_cval (V_call (Igteq, [v1; v2]), typ)) - | "lt", [AV_cval (v1, _); AV_cval (v2, _)] -> - AE_val (AV_cval (V_call (Ilt, [v1; v2]), typ)) - | "gt", [AV_cval (v1, _); AV_cval (v2, _)] -> - AE_val (AV_cval (V_call (Igt, [v1; v2]), typ)) - - | "append", [AV_cval (v1, _); AV_cval (v2, _)] -> - begin match ctyp_of_typ ctx typ with - | CT_fbits _ | CT_sbits _ -> - AE_val (AV_cval (V_call (Concat, [v1; v2]), typ)) - | _ -> no_change - end + | "lteq", [AV_cval (v1, _); AV_cval (v2, _)] -> + AE_val (AV_cval (V_call (Ilteq, [v1; v2]), typ)) + | "gteq", [AV_cval (v1, _); AV_cval (v2, _)] -> + AE_val (AV_cval (V_call (Igteq, [v1; v2]), typ)) + | "lt", [AV_cval (v1, _); AV_cval (v2, _)] -> + AE_val (AV_cval (V_call (Ilt, [v1; v2]), typ)) + | "gt", [AV_cval (v1, _); AV_cval (v2, _)] -> + AE_val (AV_cval (V_call (Igt, [v1; v2]), typ)) + + | "append", [AV_cval (v1, _); AV_cval (v2, _)] -> + begin match convert_typ ctx typ with + | CT_fbits _ | CT_sbits _ -> + AE_val (AV_cval (V_call (Concat, [v1; v2]), typ)) + | _ -> no_change + end - | "not_bits", [AV_cval (v, _)] -> - AE_val (AV_cval (V_call (Bvnot, [v]), typ)) + | "not_bits", [AV_cval (v, _)] -> + AE_val (AV_cval (V_call (Bvnot, [v]), typ)) - | "add_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> - AE_val (AV_cval (V_call (Bvadd, [v1; v2]), typ)) + | "add_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> + AE_val (AV_cval (V_call (Bvadd, [v1; v2]), typ)) - | "sub_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> - AE_val (AV_cval (V_call (Bvsub, [v1; v2]), typ)) + | "sub_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> + AE_val (AV_cval (V_call (Bvsub, [v1; v2]), typ)) - | "and_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> - AE_val (AV_cval (V_call (Bvand, [v1; v2]), typ)) + | "and_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> + AE_val (AV_cval (V_call (Bvand, [v1; v2]), typ)) - | "or_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> - AE_val (AV_cval (V_call (Bvor, [v1; v2]), typ)) + | "or_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> + AE_val (AV_cval (V_call (Bvor, [v1; v2]), typ)) - | "xor_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> - AE_val (AV_cval (V_call (Bvxor, [v1; v2]), typ)) + | "xor_bits", [AV_cval (v1, _); AV_cval (v2, _)] when ctyp_equal (cval_ctyp v1) (cval_ctyp v2) -> + AE_val (AV_cval (V_call (Bvxor, [v1; v2]), typ)) - | "vector_subrange", [AV_cval (vec, _); AV_cval (f, _); AV_cval (t, _)] -> - begin match ctyp_of_typ ctx typ with - | CT_fbits (n, true) -> - AE_val (AV_cval (V_call (Slice n, [vec; t]), typ)) - | _ -> no_change - end + | "vector_subrange", [AV_cval (vec, _); AV_cval (f, _); AV_cval (t, _)] -> + begin match convert_typ ctx typ with + | CT_fbits (n, true) -> + AE_val (AV_cval (V_call (Slice n, [vec; t]), typ)) + | _ -> no_change + end - | "slice", [AV_cval (vec, _); AV_cval (start, _); AV_cval (len, _)] -> - begin match ctyp_of_typ ctx typ with - | CT_fbits (n, _) -> - AE_val (AV_cval (V_call (Slice n, [vec; start]), typ)) - | CT_sbits (64, _) -> - AE_val (AV_cval (V_call (Sslice 64, [vec; start; len]), typ)) - | _ -> no_change - end + | "slice", [AV_cval (vec, _); AV_cval (start, _); AV_cval (len, _)] -> + begin match convert_typ ctx typ with + | CT_fbits (n, _) -> + AE_val (AV_cval (V_call (Slice n, [vec; start]), typ)) + | CT_sbits (64, _) -> + AE_val (AV_cval (V_call (Sslice 64, [vec; start; len]), typ)) + | _ -> no_change + end - | "vector_access", [AV_cval (vec, _); AV_cval (n, _)] -> - AE_val (AV_cval (V_call (Bvaccess, [vec; n]), typ)) + | "vector_access", [AV_cval (vec, _); AV_cval (n, _)] -> + AE_val (AV_cval (V_call (Bvaccess, [vec; n]), typ)) - | "add_int", [AV_cval (op1, _); AV_cval (op2, _)] -> - begin match destruct_range Env.empty typ with - | None -> no_change - | Some (kids, constr, n, m) -> - match nexp_simp n, nexp_simp m with - | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) + | "add_int", [AV_cval (op1, _); AV_cval (op2, _)] -> + begin match destruct_range Env.empty typ with + | None -> no_change + | Some (kids, constr, n, m) -> + match nexp_simp n, nexp_simp m with + | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) when Big_int.less_equal (min_int 64) n && Big_int.less_equal m (max_int 64) -> - AE_val (AV_cval (V_call (Iadd, [op1; op2]), typ)) - | n, m when prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) -> - AE_val (AV_cval (V_call (Iadd, [op1; op2]), typ)) - | _ -> no_change - end + AE_val (AV_cval (V_call (Iadd, [op1; op2]), typ)) + | n, m when prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) -> + AE_val (AV_cval (V_call (Iadd, [op1; op2]), typ)) + | _ -> no_change + end - | "replicate_bits", [AV_cval (vec, vtyp); _] -> - begin match destruct_vector ctx.tc_env typ, destruct_vector ctx.tc_env vtyp with - | Some (Nexp_aux (Nexp_constant n, _), _, _), Some (Nexp_aux (Nexp_constant m, _), _, _) - when Big_int.less_equal n (Big_int.of_int 64) -> - let times = Big_int.div n m in - if Big_int.equal (Big_int.mul m times) n then - AE_val (AV_cval (V_call (Replicate (Big_int.to_int times), [vec]), typ)) - else + | "replicate_bits", [AV_cval (vec, vtyp); _] -> + begin match destruct_vector ctx.tc_env typ, destruct_vector ctx.tc_env vtyp with + | Some (Nexp_aux (Nexp_constant n, _), _, _), Some (Nexp_aux (Nexp_constant m, _), _, _) + when Big_int.less_equal n (Big_int.of_int 64) -> + let times = Big_int.div n m in + if Big_int.equal (Big_int.mul m times) n then + AE_val (AV_cval (V_call (Replicate (Big_int.to_int times), [vec]), typ)) + else + no_change + | _, _ -> no_change - | _, _ -> - no_change - end - - | "undefined_bit", _ -> - AE_val (AV_cval (V_lit (VL_bit Sail2_values.B0, CT_bit), typ)) + end - | "undefined_bool", _ -> - AE_val (AV_cval (V_lit (VL_bool false, CT_bool), typ)) + | "undefined_bit", _ -> + AE_val (AV_cval (V_lit (VL_bit Sail2_values.B0, CT_bit), typ)) - | _, _ -> - no_change + | "undefined_bool", _ -> + AE_val (AV_cval (V_lit (VL_bool false, CT_bool), typ)) -let analyze_primop ctx id args typ = - let no_change = AE_app (id, args, typ) in - if !optimize_primops then - try analyze_primop' ctx id args typ with - | Failure str -> + | _, _ -> no_change - else - no_change + + let analyze_primop ctx id args typ = + let no_change = AE_app (id, args, typ) in + if !optimize_primops then + try analyze_primop' ctx id args typ with + | Failure str -> + no_change + else + no_change + + let optimize_anf ctx aexp = + analyze_functions ctx analyze_primop (c_literals ctx aexp) + + + let unroll_loops () = None + let specialize_calls = false + let ignore_64 = false + let struct_value = false + let use_real = false +end (** Functions that have heap-allocated return types are implemented by passing a pointer a location where the return value should be @@ -571,9 +588,9 @@ let fix_early_heap_return ret ret_ctyp instrs = before @ [iblock (rewrite_return instrs)] @ rewrite_return after - | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> + | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), (_, l)) :: after -> before - @ [iif cval (rewrite_return then_instrs) (rewrite_return else_instrs) ctyp] + @ [iif l cval (rewrite_return then_instrs) (rewrite_return else_instrs) ctyp] @ rewrite_return after | before, I_aux (I_funcall (CL_id (Return _, ctyp), extern, fid, args), aux) :: after -> before @@ -608,9 +625,9 @@ let fix_early_stack_return ret ret_ctyp instrs = before @ [iblock (rewrite_return instrs)] @ rewrite_return after - | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> + | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), (_, l)) :: after -> before - @ [iif cval (rewrite_return then_instrs) (rewrite_return else_instrs) ctyp] + @ [iif l cval (rewrite_return then_instrs) (rewrite_return else_instrs) ctyp] @ rewrite_return after | before, I_aux (I_funcall (CL_id (Return _, ctyp), extern, fid, args), aux) :: after -> before @@ -631,7 +648,7 @@ let fix_early_stack_return ret ret_ctyp instrs = rewrite_return instrs let rec insert_heap_returns ret_ctyps = function - | (CDEF_spec (id, _, ret_ctyp) as cdef) :: cdefs -> + | (CDEF_spec (id, _, _, ret_ctyp) as cdef) :: cdefs -> cdef :: insert_heap_returns (Bindings.add id ret_ctyp ret_ctyps) cdefs | CDEF_fundef (id, None, args, body) :: cdefs -> @@ -1022,7 +1039,7 @@ let optimize recursive_functions cdefs = let sgen_id id = Util.zencode_string (string_of_id id) let sgen_uid uid = zencode_uid uid -let sgen_name id = string_of_name id +let sgen_name id = string_of_name ~deref_current_exception:true ~zencode:true id let codegen_id id = string (sgen_id id) let codegen_uid id = string (sgen_uid id) @@ -1033,7 +1050,7 @@ let sgen_function_id id = let sgen_function_uid uid = let str = zencode_uid uid in !opt_prefix ^ String.sub str 1 (String.length str - 1) - + let codegen_function_id id = string (sgen_function_id id) let rec sgen_ctyp = function @@ -1052,6 +1069,7 @@ let rec sgen_ctyp = function | CT_variant (id, _) -> "struct " ^ sgen_id id | CT_list _ as l -> Util.zencode_string (string_of_ctyp l) | CT_vector _ as v -> Util.zencode_string (string_of_ctyp v) + | CT_fvector (_, ord, typ) -> sgen_ctyp (CT_vector (ord, typ)) | CT_string -> "sail_string" | CT_real -> "real" | CT_ref ctyp -> sgen_ctyp ctyp ^ "*" @@ -1073,6 +1091,7 @@ let rec sgen_ctyp_name = function | CT_variant (id, _) -> sgen_id id | CT_list _ as l -> Util.zencode_string (string_of_ctyp l) | CT_vector _ as v -> Util.zencode_string (string_of_ctyp v) + | CT_fvector (_, ord, typ) -> sgen_ctyp_name (CT_vector (ord, typ)) | CT_string -> "sail_string" | CT_real -> "real" | CT_ref ctyp -> "ref_" ^ sgen_ctyp_name ctyp @@ -1094,24 +1113,27 @@ let sgen_mask n = else failwith "Tried to create a mask literal for a vector greater than 64 bits." -let sgen_value = function +let rec sgen_value = function | VL_bits ([], _) -> "UINT64_C(0)" | VL_bits (bs, true) -> "UINT64_C(" ^ Sail2_values.show_bitlist bs ^ ")" | VL_bits (bs, false) -> "UINT64_C(" ^ Sail2_values.show_bitlist (List.rev bs) ^ ")" | VL_int i -> Big_int.to_string i ^ "l" | VL_bool true -> "true" | VL_bool false -> "false" - | VL_null -> "NULL" | VL_unit -> "UNIT" | VL_bit Sail2_values.B0 -> "UINT64_C(0)" | VL_bit Sail2_values.B1 -> "UINT64_C(1)" | VL_bit Sail2_values.BU -> failwith "Undefined bit found in value" | VL_real str -> str | VL_string str -> "\"" ^ str ^ "\"" - + | VL_empty_list -> "NULL" + | VL_enum element -> Util.zencode_string element + | VL_ref r -> "&" ^ Util.zencode_string r + | VL_undefined -> + Reporting.unreachable Parse_ast.Unknown __POS__ "Cannot generate C value for an undefined literal" + let rec sgen_cval = function - | V_id (id, ctyp) -> string_of_name id - | V_ref (id, _) -> "&" ^ string_of_name id + | V_id (id, ctyp) -> sgen_name id | V_lit (vl, ctyp) -> sgen_value vl | V_call (op, cvals) -> sgen_call op cvals | V_field (f, field) -> @@ -1133,8 +1155,6 @@ let rec sgen_cval = function and sgen_call op cvals = let open Printf in match op, cvals with - | Bit_to_bool, [v] -> - sprintf "((bool) %s)" (sgen_cval v) | Bnot, [v] -> "!(" ^ sgen_cval v ^ ")" | List_hd, [v] -> sprintf "(%s).hd" ("*" ^ sgen_cval v) @@ -1306,6 +1326,7 @@ let sgen_cval_param cval = let rec sgen_clexp = function | CL_id (Have_exception _, _) -> "have_exception" | CL_id (Current_exception _, _) -> "current_exception" + | CL_id (Throw_location _, _) -> "throw_location" | CL_id (Return _, _) -> assert false | CL_id (Name (id, _), _) -> "&" ^ sgen_id id | CL_field (clexp, field) -> "&((" ^ sgen_clexp clexp ^ ")->" ^ zencode_uid field ^ ")" @@ -1317,6 +1338,7 @@ let rec sgen_clexp = function let rec sgen_clexp_pure = function | CL_id (Have_exception _, _) -> "have_exception" | CL_id (Current_exception _, _) -> "current_exception" + | CL_id (Throw_location _, _) -> "throw_location" | CL_id (Return _, _) -> assert false | CL_id (Name (id, _), _) -> sgen_id id | CL_field (clexp, field) -> sgen_clexp_pure clexp ^ "." ^ zencode_uid field @@ -1400,21 +1422,26 @@ let rec codegen_instr fid ctx (I_aux (instr, (_, l))) = ^^ jump 2 2 (separate_map hardline (codegen_instr fid ctx) instrs) ^^ hardline ^^ string " }" - | I_funcall (x, extern, f, args) -> + | I_funcall (x, special_extern, f, args) -> let c_args = Util.string_of_list ", " sgen_cval args in let ctyp = clexp_ctyp x in - let is_extern = Env.is_extern (fst f) ctx.tc_env "c" || extern in + let is_extern = Env.is_extern (fst f) ctx.tc_env "c" || special_extern in let fname = - if Env.is_extern (fst f) ctx.tc_env "c" then - Env.get_extern (fst f) ctx.tc_env "c" - else if extern then + if special_extern then string_of_id (fst f) + else if Env.is_extern (fst f) ctx.tc_env "c" then + Env.get_extern (fst f) ctx.tc_env "c" else sgen_function_uid f in let fname = match fname, ctyp with | "internal_pick", _ -> Printf.sprintf "pick_%s" (sgen_ctyp_name ctyp) + | "cons", _ -> + begin match snd f with + | [ctyp] -> Util.zencode_string ("cons#" ^ string_of_ctyp ctyp) + | _ -> c_error "cons without specified type" + end | "eq_anything", _ -> begin match args with | cval :: _ -> Printf.sprintf "eq_%s" (sgen_ctyp_name (cval_ctyp cval)) @@ -1765,6 +1792,8 @@ let codegen_type_def ctx = function ^^ string "struct zexception *current_exception = NULL;" ^^ hardline ^^ string "bool have_exception = false;" + ^^ hardline + ^^ string "sail_string *throw_location = NULL;" else empty @@ -1994,7 +2023,7 @@ let codegen_def' ctx = function string (Printf.sprintf "// register %s" (string_of_id id)) ^^ hardline ^^ string (Printf.sprintf "%s %s;" (sgen_ctyp ctyp) (sgen_id id)) - | CDEF_spec (id, arg_ctyps, ret_ctyp) -> + | CDEF_spec (id, _, arg_ctyps, ret_ctyp) -> let static = if !opt_static then "static " else "" in if Env.is_extern id ctx.tc_env "c" then empty @@ -2009,7 +2038,7 @@ let codegen_def' ctx = function | None -> c_error ~loc:(id_loc id) ("No valspec found for " ^ string_of_id id) in - + (* Check that the function has the correct arity at this point. *) if List.length arg_ctyps <> List.length args then c_error ~loc:(id_loc id) ("function arguments " @@ -2095,7 +2124,7 @@ type c_gen_typ = let rec ctyp_dependencies = function | CT_tup ctyps -> List.concat (List.map ctyp_dependencies ctyps) @ [CTG_tup ctyps] | CT_list ctyp -> ctyp_dependencies ctyp @ [CTG_list ctyp] - | CT_vector (direction, ctyp) -> ctyp_dependencies ctyp @ [CTG_vector (direction, ctyp)] + | CT_vector (direction, ctyp) | CT_fvector (_, direction, ctyp) -> ctyp_dependencies ctyp @ [CTG_vector (direction, ctyp)] | CT_ref ctyp -> ctyp_dependencies ctyp | CT_struct (_, ctors) -> List.concat (List.map (fun (_, ctyp) -> ctyp_dependencies ctyp) ctors) | CT_variant (_, ctors) -> List.concat (List.map (fun (_, ctyp) -> ctyp_dependencies ctyp) ctors) @@ -2169,20 +2198,17 @@ let rec get_recursive_functions (Defs defs) = | [] -> IdSet.empty let jib_of_ast env ast = - let ctx = - initial_ctx - ~convert_typ:ctyp_of_typ - ~optimize_anf:(fun ctx aexp -> analyze_functions ctx analyze_primop (c_literals ctx aexp)) - env - in - Jib_compile.compile_ast ctx ast + let module Jibc = Make(C_config) in + let ctx = initial_ctx (add_special_functions env) in + Jibc.compile_ast ctx ast let compile_ast env output_chan c_includes ast = try let recursive_functions = Spec_analysis.top_sort_defs ast |> get_recursive_functions in let cdefs, ctx = jib_of_ast env ast in - Jib_interactive.ir := cdefs; + let cdefs', _ = Jib_optimize.remove_tuples cdefs ctx in + Jib_interactive.ir := cdefs'; let cdefs = insert_heap_returns Bindings.empty cdefs in let cdefs = optimize recursive_functions cdefs in @@ -2199,10 +2225,15 @@ let compile_ast env output_chan c_includes ast = let exn_boilerplate = if not (Bindings.mem (mk_id "exception") ctx.variants) then ([], []) else ([ " current_exception = sail_malloc(sizeof(struct zexception));"; - " CREATE(zexception)(current_exception);" ], - [ " KILL(zexception)(current_exception);"; + " CREATE(zexception)(current_exception);"; + " throw_location = sail_malloc(sizeof(sail_string));"; + " CREATE(sail_string)(throw_location);" ], + [ " if (have_exception) {fprintf(stderr, \"Exiting due to uncaught exception: %s\\n\", *throw_location);}"; + " KILL(zexception)(current_exception);"; " sail_free(current_exception);"; - " if (have_exception) {fprintf(stderr, \"Exiting due to uncaught exception\\n\"); exit(EXIT_FAILURE);}" ]) + " KILL(sail_string)(throw_location);"; + " sail_free(throw_location);"; + " if (have_exception) {exit(EXIT_FAILURE);}" ]) in let letbind_initializers = diff --git a/src/jib/c_backend.mli b/src/jib/c_backend.mli index 2f748fd7..e627ebd8 100644 --- a/src/jib/c_backend.mli +++ b/src/jib/c_backend.mli @@ -106,8 +106,5 @@ val optimize_alias : bool ref val optimize_fixed_int : bool ref val optimize_fixed_bits : bool ref -(** Convert a typ to a IR ctyp *) -val ctyp_of_typ : Jib_compile.ctx -> Ast.typ -> ctyp - val jib_of_ast : Env.t -> tannot Ast.defs -> cdef list * Jib_compile.ctx val compile_ast : Env.t -> out_channel -> string list -> tannot Ast.defs -> unit diff --git a/src/jib/jib_compile.ml b/src/jib/jib_compile.ml index 0efac940..4282ae30 100644 --- a/src/jib/jib_compile.ml +++ b/src/jib/jib_compile.ml @@ -58,6 +58,7 @@ open Value2 open Anf let opt_memo_cache = ref false +let opt_track_throw = ref true let optimize_aarch64_fast_struct = ref false @@ -151,38 +152,38 @@ type ctx = enums : IdSet.t Bindings.t; variants : (ctyp UBindings.t) Bindings.t; valspecs : (ctyp list * ctyp) Bindings.t; - tc_env : Env.t; local_env : Env.t; + tc_env : Env.t; locals : (mut * ctyp) Bindings.t; letbinds : int list; no_raw : bool; - convert_typ : ctx -> typ -> ctyp; - optimize_anf : ctx -> typ aexp -> typ aexp; - specialize_calls : bool; - ignore_64 : bool; - struct_value : bool; - use_real : bool; } -let initial_ctx ~convert_typ:convert_typ ~optimize_anf:optimize_anf env = +let initial_ctx env = { records = Bindings.empty; enums = Bindings.empty; variants = Bindings.empty; valspecs = Bindings.empty; - tc_env = env; local_env = env; + tc_env = env; locals = Bindings.empty; letbinds = []; no_raw = false; - convert_typ = convert_typ; - optimize_anf = optimize_anf; - specialize_calls = false; - ignore_64 = false; - struct_value = false; - use_real = false; } -let ctyp_of_typ ctx typ = ctx.convert_typ ctx typ +module type Config = sig + val convert_typ : ctx -> typ -> ctyp + val optimize_anf : ctx -> typ aexp -> typ aexp + val unroll_loops : unit -> int option + val specialize_calls : bool + val ignore_64 : bool + val struct_value : bool + val use_real : bool +end + +module Make(C: Config) = struct + +let ctyp_of_typ ctx typ = C.convert_typ ctx typ let rec chunkify n xs = match Util.take n xs, Util.drop n xs with @@ -210,12 +211,12 @@ let rec compile_aval l ctx = function end | AV_ref (id, typ) -> - [], V_ref (name id, ctyp_of_typ ctx (lvar_typ typ)), [] + [], V_lit (VL_ref (string_of_id id), CT_ref (ctyp_of_typ ctx (lvar_typ typ))), [] | AV_lit (L_aux (L_string str, _), typ) -> [], V_lit ((VL_string (String.escaped str)), ctyp_of_typ ctx typ), [] - | AV_lit (L_aux (L_num n, _), typ) when ctx.ignore_64 -> + | AV_lit (L_aux (L_num n, _), typ) when C.ignore_64 -> [], V_lit ((VL_int n), ctyp_of_typ ctx typ), [] | AV_lit (L_aux (L_num n, _), typ) when Big_int.less_equal (min_int 64) n && Big_int.less_equal n (max_int 64) -> @@ -237,7 +238,7 @@ let rec compile_aval l ctx = function | AV_lit (L_aux (L_false, _), _) -> [], V_lit (VL_bool false, CT_bool), [] | AV_lit (L_aux (L_real str, _), _) -> - if ctx.use_real then + if C.use_real then [], V_lit (VL_real str, CT_real), [] else let gs = ngensym () in @@ -247,6 +248,10 @@ let rec compile_aval l ctx = function | AV_lit (L_aux (L_unit, _), _) -> [], V_lit (VL_unit, CT_unit), [] + | AV_lit (L_aux (L_undef, _), typ) -> + let ctyp = ctyp_of_typ ctx typ in + [], V_lit (VL_undefined, ctyp), [] + | AV_lit (L_aux (_, l) as lit, _) -> raise (Reporting.err_general l ("Encountered unexpected literal " ^ string_of_lit lit ^ " when converting ANF represention into IR")) @@ -264,7 +269,7 @@ let rec compile_aval l ctx = function [iclear tup_ctyp gs] @ cleanup - | AV_record (fields, typ) when ctx.struct_value -> + | AV_record (fields, typ) when C.struct_value -> let ctyp = ctyp_of_typ ctx typ in let gs = ngensym () in let compile_fields (id, aval) = @@ -309,7 +314,7 @@ let rec compile_aval l ctx = function end (* Convert a small bitvector to a uint64_t literal. *) - | AV_vector (avals, typ) when is_bitvector avals && (List.length avals <= 64 || ctx.ignore_64) -> + | AV_vector (avals, typ) when is_bitvector avals && (List.length avals <= 64 || C.ignore_64) -> begin let bitstring = List.map value_of_aval_bit avals in let len = List.length avals in @@ -358,11 +363,14 @@ let rec compile_aval l ctx = function | V_lit (VL_bit Sail2_values.B1, _) -> [icopy l (CL_id (gs, ctyp)) (V_call (Bvor, [V_id (gs, ctyp); V_lit (mask i, ctyp)]))] | _ -> - (* FIXME: Make this work in C *) - setup @ [iif (V_call (Bit_to_bool, [cval])) [icopy l (CL_id (gs, ctyp)) (V_call (Bvor, [V_id (gs, ctyp); V_lit (mask i, ctyp)]))] [] CT_unit] @ cleanup + setup + @ [iextern (CL_id (gs, ctyp)) + (mk_id "update_fbits", []) + [V_id (gs, ctyp); V_lit (VL_int (Big_int.of_int i), CT_fint 64); cval]] + @ cleanup in [idecl ctyp gs; - icopy l (CL_id (gs, ctyp)) (V_lit (VL_bits (Util.list_init 64 (fun _ -> Sail2_values.B0), direction), ctyp))] + icopy l (CL_id (gs, ctyp)) (V_lit (VL_bits (Util.list_init len (fun _ -> Sail2_values.B0), direction), ctyp))] @ List.concat (List.mapi aval_mask (List.rev avals)), V_id (gs, ctyp), [] @@ -403,7 +411,7 @@ let rec compile_aval l ctx = function let gs = ngensym () in let mk_cons aval = let setup, cval, cleanup = compile_aval l ctx aval in - setup @ [ifuncall (CL_id (gs, CT_list ctyp)) (mk_id ("cons#" ^ string_of_ctyp ctyp), []) [cval; V_id (gs, CT_list ctyp)]] @ cleanup + setup @ [iextern (CL_id (gs, CT_list ctyp)) (mk_id "cons", [ctyp]) [cval; V_id (gs, CT_list ctyp)]] @ cleanup in [idecl (CT_list ctyp) gs] @ List.concat (List.map mk_cons (List.rev avals)), @@ -420,7 +428,7 @@ let optimize_call l ctx clexp id args arg_ctyps ret_ctyp = let have_ctyp = cval_ctyp cval in if is_polymorphic ctyp then V_poly (cval, have_ctyp) - else if ctx.specialize_calls || ctyp_equal ctyp have_ctyp then + else if C.specialize_calls || ctyp_equal ctyp have_ctyp then cval else let gs = ngensym () in @@ -429,7 +437,7 @@ let optimize_call l ctx clexp id args arg_ctyps ret_ctyp = V_id (gs, ctyp)) arg_ctyps args in - if ctx.specialize_calls || ctyp_equal (clexp_ctyp clexp) ret_ctyp then + if C.specialize_calls || ctyp_equal (clexp_ctyp clexp) ret_ctyp then !setup @ [ifuncall clexp id cast_args] @ !cleanup else let gs = ngensym () in @@ -440,7 +448,7 @@ let optimize_call l ctx clexp id args arg_ctyps ret_ctyp = iclear ret_ctyp gs] @ !cleanup in - if not ctx.specialize_calls && Env.is_extern (fst id) ctx.tc_env "c" then + if not C.specialize_calls && Env.is_extern (fst id) ctx.tc_env "c" then let extern = Env.get_extern (fst id) ctx.tc_env "c" in begin match extern, List.map cval_ctyp args, clexp_ctyp clexp with | "slice", [CT_fbits _; CT_lint; _], CT_fbits (n, _) -> @@ -506,7 +514,7 @@ let rec compile_match ctx (AP_aux (apat_aux, env, l)) cval case_label = let ctyp = cval_ctyp cval in match apat_aux with | AP_id (pid, _) when Env.is_union_constructor pid ctx.tc_env -> - [ijump (V_ctor_kind (cval, pid, [], cval_ctyp cval)) case_label], + [ijump l (V_ctor_kind (cval, pid, [], cval_ctyp cval)) case_label], [], ctx @@ -517,7 +525,7 @@ let rec compile_match ctx (AP_aux (apat_aux, env, l)) cval case_label = | AP_id (pid, _) when is_ct_enum ctyp -> begin match Env.lookup_id pid ctx.tc_env with | Unbound -> [idecl ctyp (name pid); icopy l (CL_id (name pid, ctyp)) cval], [], ctx - | _ -> [ijump (V_call (Neq, [V_id (name pid, ctyp); cval])) case_label], [], ctx + | _ -> [ijump l (V_call (Neq, [V_id (name pid, ctyp); cval])) case_label], [], ctx end | AP_id (pid, typ) -> @@ -562,7 +570,7 @@ let rec compile_match ctx (AP_aux (apat_aux, env, l)) cval case_label = [], ctor_ctyp in let instrs, cleanup, ctx = compile_match ctx apat (V_ctor_unwrap (ctor, cval, unifiers, ctor_ctyp)) case_label in - [ijump (V_ctor_kind (cval, ctor, unifiers, pat_ctyp)) case_label] + [ijump l (V_ctor_kind (cval, ctor, unifiers, pat_ctyp)) case_label] @ instrs, cleanup, ctx @@ -581,12 +589,12 @@ let rec compile_match ctx (AP_aux (apat_aux, env, l)) cval case_label = | CT_list ctyp -> let hd_setup, hd_cleanup, ctx = compile_match ctx hd_apat (V_call (List_hd, [cval])) case_label in let tl_setup, tl_cleanup, ctx = compile_match ctx tl_apat (V_call (List_tl, [cval])) case_label in - [ijump (V_call (Eq, [cval; V_lit (VL_null, CT_list ctyp)])) case_label] @ hd_setup @ tl_setup, tl_cleanup @ hd_cleanup, ctx + [ijump l (V_call (Eq, [cval; V_lit (VL_empty_list, CT_list ctyp)])) case_label] @ hd_setup @ tl_setup, tl_cleanup @ hd_cleanup, ctx | _ -> raise (Reporting.err_general l "Tried to pattern match cons on non list type") end - | AP_nil _ -> [ijump (V_call (Neq, [cval; V_lit (VL_null, ctyp)])) case_label], [], ctx + | AP_nil _ -> [ijump l (V_call (Neq, [cval; V_lit (VL_empty_list, ctyp)])) case_label], [], ctx let unit_cval = V_lit (VL_unit, CT_unit) @@ -633,7 +641,7 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = destructure @ (if not trivial_guard then guard_setup @ [idecl CT_bool gs; guard_call (CL_id (gs, CT_bool))] @ guard_cleanup - @ [iif (V_call (Bnot, [V_id (gs, CT_bool)])) (destructure_cleanup @ [igoto case_label]) [] CT_unit] + @ [iif l (V_call (Bnot, [V_id (gs, CT_bool)])) (destructure_cleanup @ [igoto case_label]) [] CT_unit] else []) @ body_setup @ [body_call (CL_id (case_return_id, ctyp))] @ body_cleanup @ destructure_cleanup @ [igoto finish_match_label] @@ -674,7 +682,7 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = destructure @ [icomment "end destructuring"] @ (if not trivial_guard then guard_setup @ [idecl CT_bool gs; guard_call (CL_id (gs, CT_bool))] @ guard_cleanup - @ [ijump (V_call (Bnot, [V_id (gs, CT_bool)])) try_label] + @ [ijump l (V_call (Bnot, [V_id (gs, CT_bool)])) try_label] @ [icomment "end guard"] else []) @ body_setup @ [body_call (CL_id (try_return_id, ctyp))] @ body_cleanup @ destructure_cleanup @@ -685,7 +693,7 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = assert (ctyp_equal ctyp (ctyp_of_typ ctx typ)); [idecl ctyp try_return_id; itry_block (aexp_setup @ [aexp_call (CL_id (try_return_id, ctyp))] @ aexp_cleanup); - ijump (V_call (Bnot, [V_id (have_exception, CT_bool)])) handled_exception_label] + ijump l (V_call (Bnot, [V_id (have_exception, CT_bool)])) handled_exception_label] @ List.concat (List.map compile_case cases) @ [igoto fallthrough_label; ilabel handled_exception_label; @@ -707,7 +715,7 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = in let setup, cval, cleanup = compile_aval l ctx aval in setup, - (fun clexp -> iif cval + (fun clexp -> iif l cval (compile_branch then_aexp clexp) (compile_branch else_aexp clexp) if_ctyp), @@ -742,7 +750,7 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = let gs = ngensym () in left_setup @ [ idecl CT_bool gs; - iif cval + iif l cval (right_setup @ [call (CL_id (gs, CT_bool))] @ right_cleanup) [icopy l (CL_id (gs, CT_bool)) (V_lit (VL_bool false, CT_bool))] CT_bool ] @@ -755,7 +763,7 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = let gs = ngensym () in left_setup @ [ idecl CT_bool gs; - iif cval + iif l cval [icopy l (CL_id (gs, CT_bool)) (V_lit (VL_bool true, CT_bool))] (right_setup @ [call (CL_id (gs, CT_bool))] @ right_cleanup) CT_bool ] @@ -813,7 +821,7 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = @ [iblock (cond_setup @ [cond_call (CL_id (gs, CT_bool))] @ cond_cleanup - @ [ijump loop_test loop_end_label] + @ [ijump l loop_test loop_end_label] @ body_setup @ [body_call (CL_id (unit_gs, CT_unit))] @ body_cleanup @@ -838,7 +846,7 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = @ cond_setup @ [cond_call (CL_id (gs, CT_bool))] @ cond_cleanup - @ [ijump loop_test loop_end_label] + @ [ijump l loop_test loop_end_label] @ [igoto loop_start_label])] @ [ilabel loop_end_label], (fun clexp -> icopy l clexp unit_cval), @@ -869,7 +877,7 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = | AE_throw (aval, typ) -> (* Cleanup info will be handled by fix_exceptions *) let throw_setup, cval, _ = compile_aval l ctx aval in - throw_setup @ [ithrow cval], + throw_setup @ [ithrow l cval], (fun clexp -> icomment "unreachable after throw"), [] @@ -927,21 +935,29 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = let loop_var = name loop_var in + let loop_body prefix continue = + prefix + @ [iblock ([ijump l (V_call ((if is_inc then Igt else Ilt), [V_id (loop_var, CT_fint 64); V_id (to_gs, CT_fint 64)])) loop_end_label] + @ body_setup + @ [body_call (CL_id (body_gs, CT_unit))] + @ body_cleanup + @ [icopy l (CL_id (loop_var, (CT_fint 64))) + (V_call ((if is_inc then Iadd else Isub), [V_id (loop_var, CT_fint 64); V_id (step_gs, CT_fint 64)]))] + @ continue ())] + in + (* We can either generate an actual loop body for C, or unroll the body for SMT *) + let actual = loop_body [ilabel loop_start_label] (fun () -> [igoto loop_start_label]) in + let rec unroll max n = loop_body [] (fun () -> if n < max then unroll max (n + 1) else [imatch_failure ()]) in + let body = match C.unroll_loops () with Some times -> unroll times 0 | None -> actual in + variable_init from_gs from_setup from_call from_cleanup @ variable_init to_gs to_setup to_call to_cleanup @ variable_init step_gs step_setup step_call step_cleanup @ [iblock ([idecl (CT_fint 64) loop_var; icopy l (CL_id (loop_var, (CT_fint 64))) (V_id (from_gs, CT_fint 64)); - idecl CT_unit body_gs; - iblock ([ilabel loop_start_label] - @ [ijump (V_call ((if is_inc then Igt else Ilt), [V_id (loop_var, CT_fint 64); V_id (to_gs, CT_fint 64)])) loop_end_label] - @ body_setup - @ [body_call (CL_id (body_gs, CT_unit))] - @ body_cleanup - @ [icopy l (CL_id (loop_var, (CT_fint 64))) - (V_call ((if is_inc then Iadd else Isub), [V_id (loop_var, CT_fint 64); V_id (step_gs, CT_fint 64)]))] - @ [igoto loop_start_label]); - ilabel loop_end_label])], + idecl CT_unit body_gs] + @ body + @ [ilabel loop_end_label])], (fun clexp -> icopy l clexp unit_cval), [] @@ -1032,19 +1048,23 @@ let fix_exception_block ?return:(return=None) ctx instrs = before @ [iblock (rewrite_exception (historic @ before) instrs)] @ rewrite_exception (historic @ before) after - | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> + | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), (_, l)) :: after -> let historic = historic @ before in before - @ [iif cval (rewrite_exception historic then_instrs) (rewrite_exception historic else_instrs) ctyp] + @ [iif l cval (rewrite_exception historic then_instrs) (rewrite_exception historic else_instrs) ctyp] @ rewrite_exception historic after | before, I_aux (I_throw cval, (_, l)) :: after -> before @ [icopy l (CL_id (current_exception, cval_ctyp cval)) cval; icopy l (CL_id (have_exception, CT_bool)) (V_lit (VL_bool true, CT_bool))] + @ (if !opt_track_throw then + let loc_string = Reporting.short_loc_to_string l in + [icopy l (CL_id (throw_location, CT_string)) (V_lit (VL_string loc_string, CT_string))] + else []) @ generate_cleanup (historic @ before) @ [igoto end_block_label] @ rewrite_exception (historic @ before) after - | before, (I_aux (I_funcall (x, _, f, args), _) as funcall) :: after -> + | before, (I_aux (I_funcall (x, _, f, args), (_, l)) as funcall) :: after -> let effects = match Env.get_val_spec (fst f) ctx.tc_env with | _, Typ_aux (Typ_fn (_, _, effects), _) -> effects | exception (Type_error _) -> no_effect (* nullary union constructor, so no val spec *) @@ -1053,7 +1073,7 @@ let fix_exception_block ?return:(return=None) ctx instrs = if has_effect effects BE_escape then before @ [funcall; - iif (V_id (have_exception, CT_bool)) (generate_cleanup (historic @ before) @ [igoto end_block_label]) [] CT_unit] + iif l (V_id (have_exception, CT_bool)) (generate_cleanup (historic @ before) @ [igoto end_block_label]) [] CT_unit] @ rewrite_exception (historic @ before) after else before @ funcall :: rewrite_exception (historic @ before) after @@ -1147,10 +1167,10 @@ let fix_early_return ret instrs = before @ [iblock (rewrite_return (historic @ before) instrs)] @ rewrite_return (historic @ before) after - | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> + | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), (_, l)) :: after -> let historic = historic @ before in before - @ [iif cval (rewrite_return historic then_instrs) (rewrite_return historic else_instrs) ctyp] + @ [iif l cval (rewrite_return historic then_instrs) (rewrite_return historic else_instrs) ctyp] @ rewrite_return historic after | before, I_aux (I_return cval, (_, l)) :: after -> let cleanup_label = label "cleanup_" in @@ -1211,7 +1231,7 @@ let compile_funcl ctx id pat guard exp = let guard_instrs = match guard with | Some guard -> - let guard_aexp = ctx.optimize_anf ctx (no_shadow (pat_ids pat) (anf guard)) in + let guard_aexp = C.optimize_anf ctx (no_shadow (pat_ids pat) (anf guard)) in let guard_setup, guard_call, guard_cleanup = compile_aexp ctx guard_aexp in let guard_label = label "guard_" in let gs = ngensym () in @@ -1220,7 +1240,7 @@ let compile_funcl ctx id pat guard exp = @ guard_setup @ [guard_call (CL_id (gs, CT_bool))] @ guard_cleanup - @ [ijump (V_id (gs, CT_bool)) guard_label; + @ [ijump (id_loc id) (V_id (gs, CT_bool)) guard_label; imatch_failure (); ilabel guard_label] )] @@ -1228,7 +1248,7 @@ let compile_funcl ctx id pat guard exp = in (* Optimize and compile the expression to ANF. *) - let aexp = ctx.optimize_anf ctx (no_shadow (pat_ids pat) (anf exp)) in + let aexp = C.optimize_anf ctx (no_shadow (pat_ids pat) (anf exp)) in let setup, call, cleanup = compile_aexp ctx aexp in let destructure, destructure_cleanup = @@ -1280,7 +1300,7 @@ and 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 = ctx.optimize_anf ctx (no_shadow IdSet.empty (anf exp)) in + let aexp = C.optimize_anf ctx (no_shadow IdSet.empty (anf exp)) in let setup, call, cleanup = compile_aexp ctx aexp in let instrs = setup @ [call (CL_id (name id, ctyp_of_typ ctx typ))] @ cleanup in [CDEF_reg_dec (id, ctyp_of_typ ctx typ, instrs)], ctx @@ -1290,13 +1310,19 @@ and compile_def' n total ctx = function | DEF_spec (VS_aux (VS_val_spec (_, id, _, _), _)) -> let quant, Typ_aux (fn_typ, _) = Env.get_val_spec id ctx.tc_env in + let extern = + if Env.is_extern id ctx.tc_env "c" then + Some (Env.get_extern id ctx.tc_env "c") + else + None + in let arg_typs, ret_typ = match fn_typ with | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ | _ -> assert false in let ctx' = { ctx with local_env = add_typquant (id_loc id) quant ctx.local_env } in let arg_ctyps, ret_ctyp = List.map (ctyp_of_typ ctx') arg_typs, ctyp_of_typ ctx' ret_typ in - [CDEF_spec (id, arg_ctyps, ret_ctyp)], + [CDEF_spec (id, extern, arg_ctyps, ret_ctyp)], { ctx with valspecs = Bindings.add id (arg_ctyps, ret_ctyp) ctx.valspecs } | DEF_fundef (FD_aux (FD_function (_, _, _, [FCL_aux (FCL_Funcl (id, Pat_aux (Pat_exp (pat, exp), _)), _)]), _)) -> @@ -1323,7 +1349,7 @@ and compile_def' n total ctx = function | DEF_val (LB_aux (LB_val (pat, exp), _)) -> let ctyp = ctyp_of_typ ctx (typ_of_pat pat) in - let aexp = ctx.optimize_anf ctx (no_shadow IdSet.empty (anf exp)) in + let aexp = C.optimize_anf ctx (no_shadow IdSet.empty (anf exp)) in let setup, call, cleanup = compile_aexp ctx aexp in let apat = anf_pat ~global:true pat in let gs = ngensym () in @@ -1544,12 +1570,6 @@ let sort_ctype_defs cdefs = ctype_defs @ cdefs let compile_ast ctx (Defs defs) = - let assert_vs = Initial_check.extern_of_string (mk_id "sail_assert") "(bool, string) -> unit" in - let exit_vs = Initial_check.extern_of_string (mk_id "sail_exit") "unit -> unit" in - let cons_vs = Initial_check.extern_of_string (mk_id "sail_cons") "forall ('a : Type). ('a, list('a)) -> list('a)" in - - let ctx = { ctx with tc_env = snd (Type_error.check ctx.tc_env (Defs [assert_vs; exit_vs; cons_vs])) } in - if !opt_memo_cache then (try if Sys.is_directory "_sbuild" then @@ -1568,3 +1588,12 @@ let compile_ast ctx (Defs defs) = let cdefs, ctx = specialize_variants ctx [] cdefs in let cdefs = sort_ctype_defs cdefs in cdefs, ctx + +end + +let add_special_functions env = + let assert_vs = Initial_check.extern_of_string (mk_id "sail_assert") "(bool, string) -> unit" in + let exit_vs = Initial_check.extern_of_string (mk_id "sail_exit") "unit -> unit" in + let cons_vs = Initial_check.extern_of_string (mk_id "sail_cons") "forall ('a : Type). ('a, list('a)) -> list('a)" in + + snd (Type_error.check env (Defs [assert_vs; exit_vs; cons_vs])) diff --git a/src/jib/jib_compile.mli b/src/jib/jib_compile.mli index 273e9e03..9014d8f7 100644 --- a/src/jib/jib_compile.mli +++ b/src/jib/jib_compile.mli @@ -58,53 +58,69 @@ open Type_check (** This forces all integer struct fields to be represented as int64_t. Specifically intended for the various TLB structs in the - ARM v8.5 spec. *) + ARM v8.5 spec. It is unsound in general. *) val optimize_aarch64_fast_struct : bool ref +(** If true (default) track the location of the last exception thrown, + useful for debugging C but we want to turn it off for SMT generation + where we can't use strings *) +val opt_track_throw : bool ref + (** {2 Jib context} *) -(** Context for compiling Sail to Jib. We need to pass a (global) - typechecking environment given by checking the full AST. We have to - provide a conversion function from Sail types into Jib types, as - well as a function that optimizes ANF expressions (which can just - be the identity function) *) +(** Dynamic context for compiling Sail to Jib. We need to pass a + (global) typechecking environment given by checking the full + AST. *) type ctx = { records : (ctyp Jib_util.UBindings.t) Bindings.t; enums : IdSet.t Bindings.t; variants : (ctyp Jib_util.UBindings.t) Bindings.t; valspecs : (ctyp list * ctyp) Bindings.t; - tc_env : Env.t; local_env : Env.t; + tc_env : Env.t; locals : (mut * ctyp) Bindings.t; letbinds : int list; no_raw : bool; - convert_typ : ctx -> typ -> ctyp; - optimize_anf : ctx -> typ aexp -> typ aexp; - (** If false (default), function arguments must match the function - type exactly. If true, they can be more specific. *) - specialize_calls : bool; - (** If false (default), will ensure that fixed size bitvectors are - specifically less that 64-bits. If true this restriction will - be ignored. *) - ignore_64 : bool; - (** If false (default) we won't generate any V_struct values *) - struct_value : bool; - (** Allow real literals *) - use_real : bool; } -val initial_ctx : - convert_typ:(ctx -> typ -> ctyp) -> - optimize_anf:(ctx -> typ aexp -> typ aexp) -> - Env.t -> - ctx +val initial_ctx : Env.t -> ctx (** {2 Compilation functions} *) -(** Compile a Sail definition into a Jib definition. The first two - arguments are is the current definition number and the total number - of definitions, and can be used to drive a progress bar (see - Util.progress). *) -val compile_def : int -> int -> ctx -> tannot def -> cdef list * ctx +(** The Config module specifies static configuration for compiling + Sail into Jib. We have to provide a conversion function from Sail + types into Jib types, as well as a function that optimizes ANF + expressions (which can just be the identity function) *) +module type Config = sig + val convert_typ : ctx -> typ -> ctyp + val optimize_anf : ctx -> typ aexp -> typ aexp + (** Unroll all for loops a bounded number of times. Used for SMT + generation. *) + val unroll_loops : unit -> int option + (** If false, function arguments must match the function + type exactly. If true, they can be more specific. *) + val specialize_calls : bool + (** If false, will ensure that fixed size bitvectors are + specifically less that 64-bits. If true this restriction will + be ignored. *) + val ignore_64 : bool + (** If false we won't generate any V_struct values *) + val struct_value : bool + (** Allow real literals *) + val use_real : bool +end + +module Make(C: Config) : sig + (** Compile a Sail definition into a Jib definition. The first two + arguments are is the current definition number and the total + number of definitions, and can be used to drive a progress bar + (see Util.progress). *) + val compile_def : int -> int -> ctx -> tannot def -> cdef list * ctx + + val compile_ast : ctx -> tannot defs -> cdef list * ctx +end -val compile_ast : ctx -> tannot defs -> cdef list * ctx +(** Adds some special functions to the environment that are used to + convert several Sail language features, these are sail_assert, + sail_exit, and sail_cons. *) +val add_special_functions : Env.t -> Env.t diff --git a/src/jib/jib_ir.ml b/src/jib/jib_ir.ml index c5f2b20a..4bf726aa 100644 --- a/src/jib/jib_ir.ml +++ b/src/jib/jib_ir.ml @@ -69,7 +69,9 @@ let string_of_name = "return" ^ ssa_num n | Current_exception n -> "current_exception" ^ ssa_num n - + | Throw_location n -> + "throw_location" ^ ssa_num n + let rec string_of_clexp = function | CL_id (id, ctyp) -> string_of_name id | CL_field (clexp, field) -> string_of_clexp clexp ^ "." ^ string_of_uid field @@ -107,7 +109,9 @@ module Ir_formatter = struct | I_label label -> C.output_label_instr buf label_map label | I_jump (cval, label) -> - add_instr n buf indent (C.keyword "jump" ^ " " ^ C.value cval ^ " " ^ C.string_of_label (StringMap.find label label_map)) + add_instr n buf indent (C.keyword "jump" ^ " " ^ C.value cval ^ " " + ^ C.keyword "goto" ^ " " ^ C.string_of_label (StringMap.find label label_map) + ^ " ` \"" ^ Reporting.short_loc_to_string l ^ "\"") | I_goto label -> add_instr n buf indent (C.keyword "goto" ^ " " ^ C.string_of_label (StringMap.find label label_map)) | I_match_failure -> @@ -151,8 +155,10 @@ module Ir_formatter = struct let output_def buf = function | CDEF_reg_dec (id, ctyp, _) -> Buffer.add_string buf (sprintf "%s %s : %s" (C.keyword "register") (zencode_id id) (C.typ ctyp)) - | CDEF_spec (id, ctyps, ctyp) -> + | CDEF_spec (id, None, ctyps, ctyp) -> Buffer.add_string buf (sprintf "%s %s : (%s) -> %s" (C.keyword "val") (zencode_id id) (Util.string_of_list ", " C.typ ctyps) (C.typ ctyp)); + | CDEF_spec (id, Some extern, ctyps, ctyp) -> + Buffer.add_string buf (sprintf "%s %s = \"%s\" : (%s) -> %s" (C.keyword "val") (zencode_id id) extern (Util.string_of_list ", " C.typ ctyps) (C.typ ctyp)); | CDEF_fundef (id, ret, args, instrs) -> let instrs = C.modify_instrs instrs in let label_map = C.make_label_map instrs in @@ -244,10 +250,10 @@ let () = let open Interactive in let open Jib_interactive in - (fun arg -> + ArgString ("(val|register)? identifier", fun arg -> Action (fun () -> let is_def id = function | CDEF_fundef (id', _, _, _) -> Id.compare id id' = 0 - | CDEF_spec (id', _, _) -> Id.compare id (prepend_id "val " id') = 0 + | CDEF_spec (id', _, _, _) -> Id.compare id (prepend_id "val " id') = 0 | CDEF_reg_dec (id', _, _) -> Id.compare id (prepend_id "register " id') = 0 | _ -> false in @@ -258,12 +264,12 @@ let () = let buf = Buffer.create 256 in with_colors (fun () -> Flat_ir_formatter.output_def buf cdef); print_endline (Buffer.contents buf) - ) |> Interactive.(register_command ~name:"ir" ~help:(sprintf ":ir %s - Print the ir representation of a toplevel definition" (arg "(val|register)? identifier"))); + )) |> Interactive.register_command ~name:"ir" ~help:"Print the ir representation of a toplevel definition"; - (fun file -> + ArgString ("file", fun file -> Action (fun () -> let buf = Buffer.create 256 in let out_chan = open_out file in Flat_ir_formatter.output_defs buf !ir; output_string out_chan (Buffer.contents buf); close_out out_chan - ) |> Interactive.(register_command ~name:"dump_ir" ~help:(sprintf ":dump_ir %s - Dump the ir to a file" (arg "file"))) + )) |> Interactive.register_command ~name:"dump_ir" ~help:"Dump the ir to a file" diff --git a/src/jib/jib_optimize.ml b/src/jib/jib_optimize.ml index 323f3cd0..e0f3bf0d 100644 --- a/src/jib/jib_optimize.ml +++ b/src/jib/jib_optimize.ml @@ -102,10 +102,10 @@ let rec flatten_instrs = function | I_aux ((I_block block | I_try_block block), _) :: instrs -> flatten_instrs block @ flatten_instrs instrs - | I_aux (I_if (cval, then_instrs, else_instrs, _), _) :: instrs -> + | I_aux (I_if (cval, then_instrs, else_instrs, _), (_, l)) :: instrs -> let then_label = label "then_" in let endif_label = label "endif_" in - [ijump cval then_label] + [ijump l cval then_label] @ flatten_instrs else_instrs @ [igoto endif_label] @ [ilabel then_label] @@ -153,7 +153,7 @@ let unique_per_function_ids cdefs = | CDEF_reg_dec (id, ctyp, instrs) -> CDEF_reg_dec (id, ctyp, unique_instrs i instrs) | CDEF_type ctd -> CDEF_type ctd | CDEF_let (n, bindings, instrs) -> CDEF_let (n, bindings, unique_instrs i instrs) - | CDEF_spec (id, ctyps, ctyp) -> CDEF_spec (id, ctyps, ctyp) + | CDEF_spec (id, extern, ctyps, ctyp) -> CDEF_spec (id, extern, ctyps, ctyp) | CDEF_fundef (id, heap_return, args, instrs) -> CDEF_fundef (id, heap_return, args, unique_instrs i instrs) | CDEF_startup (id, instrs) -> CDEF_startup (id, unique_instrs i instrs) | CDEF_finish (id, instrs) -> CDEF_finish (id, unique_instrs i instrs) @@ -162,7 +162,6 @@ let unique_per_function_ids cdefs = let rec cval_subst id subst = function | V_id (id', ctyp) -> if Name.compare id id' = 0 then subst else V_id (id', ctyp) - | V_ref (reg_id, ctyp) -> V_ref (reg_id, ctyp) | V_lit (vl, ctyp) -> V_lit (vl, ctyp) | V_call (op, cvals) -> V_call (op, List.map (cval_subst id subst) cvals) | V_field (cval, field) -> V_field (cval_subst id subst cval, field) @@ -174,7 +173,6 @@ let rec cval_subst id subst = function let rec cval_map_id f = function | V_id (id, ctyp) -> V_id (f id, ctyp) - | V_ref (id, ctyp) -> V_ref (f id, ctyp) | V_lit (vl, ctyp) -> V_lit (vl, ctyp) | V_call (call, cvals) -> V_call (call, List.map (cval_map_id f) cvals) | V_field (cval, field) -> V_field (cval_map_id f cval, field) @@ -249,6 +247,7 @@ let ssa_name i = function | Name (id, _) -> Name (id, i) | Have_exception _ -> Have_exception i | Current_exception _ -> Current_exception i + | Throw_location _ -> Throw_location i | Return _ -> Return i let inline cdefs should_inline instrs = @@ -347,6 +346,15 @@ let rec remove_pointless_goto = function instr :: remove_pointless_goto instrs | [] -> [] +let rec remove_pointless_exit = function + | I_aux (I_end id, aux) :: I_aux (I_end _, _) :: instrs -> + I_aux (I_end id, aux) :: remove_pointless_exit instrs + | I_aux (I_end id, aux) :: I_aux (I_undefined _, _) :: instrs -> + I_aux (I_end id, aux) :: remove_pointless_exit instrs + | instr :: instrs -> + instr :: remove_pointless_exit instrs + | [] -> [] + module StringSet = Set.Make(String) let rec get_used_labels set = function @@ -364,7 +372,6 @@ let remove_unused_labels instrs = in go [] instrs - let remove_dead_after_goto instrs = let rec go acc = function | (I_aux (I_goto _, _) as instr) :: instrs -> go_dead (instr :: acc) instrs @@ -379,7 +386,7 @@ let remove_dead_after_goto instrs = let rec remove_dead_code instrs = let instrs' = - instrs |> remove_unused_labels |> remove_pointless_goto |> remove_dead_after_goto + instrs |> remove_unused_labels |> remove_pointless_goto |> remove_dead_after_goto |> remove_pointless_exit in if List.length instrs' < List.length instrs then remove_dead_code instrs' @@ -398,7 +405,7 @@ let remove_tuples cdefs ctx = CTSet.add ctyp (List.fold_left CTSet.union CTSet.empty (List.map all_tuples ctyps)) | CT_struct (_, id_ctyps) | CT_variant (_, id_ctyps) -> List.fold_left (fun cts (_, ctyp) -> CTSet.union (all_tuples ctyp) cts) CTSet.empty id_ctyps - | CT_list ctyp | CT_vector (_, ctyp) | CT_ref ctyp -> + | CT_list ctyp | CT_vector (_, ctyp) | CT_fvector (_, _, ctyp) | CT_ref ctyp -> all_tuples ctyp | CT_lint | CT_fint _ | CT_lbits _ | CT_sbits _ | CT_fbits _ | CT_constant _ | CT_unit | CT_bool | CT_real | CT_bit | CT_poly | CT_string | CT_enum _ -> @@ -409,7 +416,7 @@ let remove_tuples cdefs ctx = 1 + List.fold_left (fun d ctyp -> max d (tuple_depth ctyp)) 0 ctyps | CT_struct (_, id_ctyps) | CT_variant (_, id_ctyps) -> List.fold_left (fun d (_, ctyp) -> max (tuple_depth ctyp) d) 0 id_ctyps - | CT_list ctyp | CT_vector (_, ctyp) | CT_ref ctyp -> + | CT_list ctyp | CT_vector (_, ctyp) | CT_fvector (_, _, ctyp) | CT_ref ctyp -> tuple_depth ctyp | CT_lint | CT_fint _ | CT_lbits _ | CT_sbits _ | CT_fbits _ | CT_constant _ | CT_unit | CT_bool | CT_real | CT_bit | CT_poly | CT_string | CT_enum _ -> @@ -426,6 +433,7 @@ let remove_tuples cdefs ctx = CT_variant (id, List.map (fun (id, ctyp) -> id, fix_tuples ctyp) id_ctyps) | CT_list ctyp -> CT_list (fix_tuples ctyp) | CT_vector (d, ctyp) -> CT_vector (d, fix_tuples ctyp) + | CT_fvector (n, d, ctyp) -> CT_fvector (n, d, fix_tuples ctyp) | CT_ref ctyp -> CT_ref (fix_tuples ctyp) | (CT_lint | CT_fint _ | CT_lbits _ | CT_sbits _ | CT_fbits _ | CT_constant _ | CT_unit | CT_bool | CT_real | CT_bit | CT_poly | CT_string | CT_enum _) as ctyp -> @@ -433,7 +441,6 @@ let remove_tuples cdefs ctx = in let rec fix_cval = function | V_id (id, ctyp) -> V_id (id, ctyp) - | V_ref (id, ctyp) -> V_ref (id, ctyp) | V_lit (vl, ctyp) -> V_lit (vl, ctyp) | V_ctor_kind (cval, id, unifiers, ctyp) -> V_ctor_kind (fix_cval cval, id, unifiers, ctyp) diff --git a/src/jib/jib_smt.ml b/src/jib/jib_smt.ml index fbaf8d3f..81b876a4 100644 --- a/src/jib/jib_smt.ml +++ b/src/jib/jib_smt.ml @@ -73,6 +73,8 @@ let opt_debug_graphs = ref false let opt_propagate_vars = ref false +let opt_unroll_limit = ref 10 + module EventMap = Map.Make(Event) (* Note that we have to use x : ty ref rather than mutable x : ty, to @@ -89,6 +91,8 @@ type ctx = { pragma_l : Ast.l; arg_stack : (int * string) Stack.t; ast : Type_check.tannot defs; + shared : ctyp Bindings.t; + preserved : IdSet.t; events : smt_exp Stack.t EventMap.t ref; node : int; pathcond : smt_exp Lazy.t; @@ -114,6 +118,8 @@ let initial_ctx () = { pragma_l = Parse_ast.Unknown; arg_stack = Stack.create (); ast = Defs []; + shared = Bindings.empty; + preserved = IdSet.empty; events = ref EventMap.empty; node = -1; pathcond = lazy (Bool_lit true); @@ -129,6 +135,19 @@ let event_stack ctx ev = ctx.events := EventMap.add ev stack !(ctx.events); stack +let add_event ctx ev smt = + let stack = event_stack ctx ev in + Stack.push (Fn ("and", [Lazy.force ctx.pathcond; smt])) stack + +let add_pathcond_event ctx ev = + Stack.push (Lazy.force ctx.pathcond) (event_stack ctx ev) + +let overflow_check ctx smt = + if not !opt_ignore_overflow then ( + Reporting.warn "Overflow check in generated SMT for" ctx.pragma_l ""; + add_event ctx Overflow smt + ) + let lbits_size ctx = Util.power 2 ctx.lbits_index let vector_index = ref 5 @@ -179,6 +198,8 @@ let rec smt_ctyp ctx = function | _ -> failwith ("No registers with ctyp: " ^ string_of_ctyp ctyp) end | CT_list _ -> raise (Reporting.err_todo ctx.pragma_l "Lists not yet supported in SMT generation") + | CT_fvector _ -> + Reporting.unreachable ctx.pragma_l __POS__ "Found CT_fvector in SMT property" | CT_poly -> Reporting.unreachable ctx.pragma_l __POS__ "Found polymorphic type in SMT property" @@ -188,21 +209,17 @@ let rec smt_ctyp ctx = function don't have a very good way to get the binary representation of either an ocaml integer or a big integer. *) let bvpint sz x = + let open Sail2_values in if Big_int.less_equal Big_int.zero x && Big_int.less_equal x (Big_int.of_int max_int) then ( - let open Sail_lib in let x = Big_int.to_int x in - if sz mod 4 = 0 then - let hex = Printf.sprintf "%X" x in - let padding = String.make (sz / 4 - String.length hex) '0' in - Hex (padding ^ hex) - else - let bin = Printf.sprintf "%X" x |> list_of_string |> List.map hex_char |> List.concat in - let _, bin = Util.take_drop (function B0 -> true | B1 -> false) bin in - let bin = String.concat "" (List.map string_of_bit bin) in - let padding = String.make (sz - String.length bin) '0' in - Bin (padding ^ bin) + match Printf.sprintf "%X" x |> Util.string_to_list |> List.map nibble_of_char |> Util.option_all with + | Some nibbles -> + let bin = List.map (fun (a, b, c, d) -> [a; b; c; d]) nibbles |> List.concat in + let _, bin = Util.take_drop (function B0 -> true | _ -> false) bin in + let padding = List.init (sz - List.length bin) (fun _ -> B0) in + Bitvec_lit (padding @ bin) + | None -> assert false ) else if Big_int.greater x (Big_int.of_int max_int) then ( - let open Sail_lib in let y = ref x in let bin = ref [] in while (not (Big_int.equal !y Big_int.zero)) do @@ -210,14 +227,13 @@ let bvpint sz x = bin := (if Big_int.equal m Big_int.zero then B0 else B1) :: !bin; y := q done; - let bin = String.concat "" (List.map string_of_bit !bin) in - let padding_size = sz - String.length bin in + let padding_size = sz - List.length !bin in if padding_size < 0 then raise (Reporting.err_general Parse_ast.Unknown (Printf.sprintf "Could not create a %d-bit integer with value %s.\nTry increasing the maximum integer size" sz (Big_int.to_string x))); - let padding = String.make (sz - String.length bin) '0' in - Bin (padding ^ bin) + let padding = List.init padding_size (fun _ -> B0) in + Bitvec_lit (padding @ !bin) ) else failwith "Invalid bvpint" let bvint sz x = @@ -226,22 +242,68 @@ let bvint sz x = else bvpint sz x +(** [force_size ctx n m exp] takes a smt expression assumed to be a + integer (signed bitvector) of length m and forces it to be length n + by either sign extending it or truncating it as required *) +let force_size ?checked:(checked=true) ctx n m smt = + if n = m then + smt + else if n > m then + SignExtend (n - m, smt) + else + let check = + (* If the top bit of the truncated number is one *) + Ite (Fn ("=", [Extract (n - 1, n - 1, smt); Bitvec_lit [Sail2_values.B1]]), + (* Then we have an overflow, unless all bits we truncated were also one *) + Fn ("not", [Fn ("=", [Extract (m - 1, n, smt); bvones (m - n)])]), + (* Otherwise, all the top bits must be zero *) + Fn ("not", [Fn ("=", [Extract (m - 1, n, smt); bvzero (m - n)])])) + in + if checked then overflow_check ctx check else (); + Extract (n - 1, 0, smt) + +(** [unsigned_size ctx n m exp] is much like force_size, but it + assumes that the bitvector is unsigned *) +let unsigned_size ?checked:(checked=true) ctx n m smt = + if n = m then + smt + else if n > m then + Fn ("concat", [bvzero (n - m); smt]) + else + Extract (n - 1, 0, smt) + +let smt_conversion ctx from_ctyp to_ctyp x = + match from_ctyp, to_ctyp with + | _, _ when ctyp_equal from_ctyp to_ctyp -> x + | CT_constant c, CT_fint sz -> + bvint sz c + | CT_constant c, CT_lint -> + bvint ctx.lint_size c + | CT_fint sz, CT_lint -> + force_size ctx ctx.lint_size sz x + | CT_lint, CT_fint sz -> + force_size ctx sz ctx.lint_size x + | CT_lbits _, CT_fbits (n, _) -> + unsigned_size ctx n (lbits_size ctx) (Fn ("contents", [x])) + | CT_fbits (n, _), CT_lbits _ -> + Fn ("Bits", [bvint ctx.lbits_index (Big_int.of_int n); unsigned_size ctx (lbits_size ctx) n x]) + + | _, _ -> failwith (Printf.sprintf "Cannot perform conversion from %s to %s" (string_of_ctyp from_ctyp) (string_of_ctyp to_ctyp)) + (* Translate Jib literals into SMT *) -let smt_value ctx vl ctyp = +let rec smt_value ctx vl ctyp = let open Value2 in match vl, ctyp with - | VL_bits (bs, true), CT_fbits (n, _) -> - (* FIXME: Output the correct number of bits in Jib_compile *) - begin match Sail2_values.hexstring_of_bits (List.rev (Util.take n (List.rev bs))) with - | Some s -> Hex (Xstring.implode s) - | None -> Bin (Xstring.implode (List.map Sail2_values.bitU_char (List.rev (Util.take n (List.rev bs))))) - end + | VL_bits (bv, true), CT_fbits (n, _) -> + unsigned_size ctx n (List.length bv) (Bitvec_lit bv) + | VL_bits (bv, true), CT_lbits _ -> + let sz = List.length bv in + Fn ("Bits", [bvint ctx.lbits_index (Big_int.of_int sz); unsigned_size ctx (lbits_size ctx) sz (Bitvec_lit bv)]) | VL_bool b, _ -> Bool_lit b | VL_int n, CT_constant m -> bvint (required_width n) n | VL_int n, CT_fint sz -> bvint sz n | VL_int n, CT_lint -> bvint ctx.lint_size n - | VL_bit Sail2_values.B0, CT_bit -> Bin "0" - | VL_bit Sail2_values.B1, CT_bit -> Bin "1" + | VL_bit b, CT_bit -> Bitvec_lit [b] | VL_unit, _ -> Enum "unit" | VL_string str, _ -> ctx.use_string := true; @@ -252,7 +314,21 @@ let smt_value ctx vl ctyp = Fn ("-", [Real_lit (String.sub str 1 (String.length str - 1))]) else Real_lit str - | vl, _ -> failwith ("Cannot translate literal to SMT: " ^ string_of_value vl) + | VL_enum str, _ -> Enum (Util.zencode_string str) + | VL_ref reg_name, _ -> + let id = mk_id reg_name in + let rmap = CTMap.filter (fun ctyp regs -> List.exists (fun reg -> Id.compare reg id = 0) regs) ctx.register_map in + assert (CTMap.cardinal rmap = 1); + begin match CTMap.min_binding_opt rmap with + | Some (ctyp, regs) -> + begin match Util.list_index (fun reg -> Id.compare reg id = 0) regs with + | Some i -> + bvint (required_width (Big_int.of_int (List.length regs))) (Big_int.of_int i) + | None -> assert false + end + | _ -> assert false + end + | _ -> failwith ("Cannot translate literal to SMT: " ^ string_of_value vl ^ " : " ^ string_of_ctyp ctyp) let rec smt_cval ctx cval = match cval_ctyp cval with @@ -264,6 +340,7 @@ let rec smt_cval ctx cval = | V_id (Name (id, _) as ssa_id, _) -> begin match Type_check.Env.lookup_id id ctx.tc_env with | Enum _ -> Enum (zencode_id id) + | _ when Bindings.mem id ctx.shared -> Shared (zencode_id id) | _ -> Var (zencode_name ssa_id) end | V_id (ssa_id, _) -> Var (zencode_name ssa_id) @@ -271,8 +348,6 @@ let rec smt_cval ctx cval = Fn ("not", [Fn ("=", [smt_cval ctx cval1; smt_cval ctx cval2])]) | V_call (Bvor, [cval1; cval2]) -> Fn ("bvor", [smt_cval ctx cval1; smt_cval ctx cval2]) - | V_call (Bit_to_bool, [cval]) -> - Fn ("=", [smt_cval ctx cval; Bin "1"]) | V_call (Eq, [cval1; cval2]) -> Fn ("=", [smt_cval ctx cval1; smt_cval ctx cval2]) | V_call (Bnot, [cval]) -> @@ -281,14 +356,18 @@ let rec smt_cval ctx cval = smt_conj (List.map (smt_cval ctx) cvals) | V_call (Bor, cvals) -> smt_disj (List.map (smt_cval ctx) cvals) + | V_call (Igt, [cval1; cval2]) -> + Fn ("bvsgt", [smt_cval ctx cval1; smt_cval ctx cval2]) + | V_call (Iadd, [cval1; cval2]) -> + Fn ("bvadd", [smt_cval ctx cval1; smt_cval ctx cval2]) | V_ctor_kind (union, ctor_id, unifiers, _) -> Fn ("not", [Tester (zencode_uid (ctor_id, unifiers), smt_cval ctx union)]) | V_ctor_unwrap (ctor_id, union, unifiers, _) -> Fn ("un" ^ zencode_uid (ctor_id, unifiers), [smt_cval ctx union]) - | V_field (union, field) -> - begin match cval_ctyp union with + | V_field (record, field) -> + begin match cval_ctyp record with | CT_struct (struct_id, _) -> - Fn (zencode_upper_id struct_id ^ "_" ^ zencode_uid field, [smt_cval ctx union]) + Field (zencode_upper_id struct_id ^ "_" ^ zencode_uid field, smt_cval ctx record) | _ -> failwith "Field for non-struct type" end | V_struct (fields, ctyp) -> @@ -297,43 +376,18 @@ let rec smt_cval ctx cval = let set_field (field, cval) = match Util.assoc_compare_opt UId.compare field field_ctyps with | None -> failwith "Field type not found" - | Some ctyp when ctyp_equal (cval_ctyp cval) ctyp -> - smt_cval ctx cval - | _ -> failwith "Type mismatch when generating struct for SMT" + | Some ctyp -> + zencode_upper_id struct_id ^ "_" ^ zencode_uid field, + smt_conversion ctx (cval_ctyp cval) ctyp (smt_cval ctx cval) in - Fn (zencode_upper_id struct_id, List.map set_field fields) + Struct (zencode_upper_id struct_id, List.map set_field fields) | _ -> failwith "Struct does not have struct type" end | V_tuple_member (frag, len, n) -> ctx.tuple_sizes := IntSet.add len !(ctx.tuple_sizes); Fn (Printf.sprintf "tup_%d_%d" len n, [smt_cval ctx frag]) - | V_ref (Name (id, _), _) -> - let rmap = CTMap.filter (fun ctyp regs -> List.exists (fun reg -> Id.compare reg id = 0) regs) ctx.register_map in - assert (CTMap.cardinal rmap = 1); - begin match CTMap.min_binding_opt rmap with - | Some (ctyp, regs) -> - begin match Util.list_index (fun reg -> Id.compare reg id = 0) regs with - | Some i -> - bvint (required_width (Big_int.of_int (List.length regs))) (Big_int.of_int i) - | None -> assert false - end - | _ -> assert false - end | cval -> failwith ("Unrecognised cval " ^ string_of_cval cval) -let add_event ctx ev smt = - let stack = event_stack ctx ev in - Stack.push (Fn ("=>", [Lazy.force ctx.pathcond; smt])) stack - -let add_pathcond_event ctx ev = - Stack.push (Lazy.force ctx.pathcond) (event_stack ctx ev) - -let overflow_check ctx smt = - if not !opt_ignore_overflow then ( - Reporting.warn "Overflow check in generated SMT for" ctx.pragma_l ""; - add_event ctx Overflow smt - ) - (**************************************************************************) (* 1. Generating SMT for Sail builtins *) (**************************************************************************) @@ -342,8 +396,8 @@ let builtin_type_error ctx fn cvals = let args = Util.string_of_list ", " (fun cval -> string_of_ctyp (cval_ctyp cval)) cvals in function | Some ret_ctyp -> - raise (Reporting.err_todo ctx.pragma_l - (Printf.sprintf "%s : (%s) -> %s" fn args (string_of_ctyp ret_ctyp))) + let message = Printf.sprintf "%s : (%s) -> %s" fn args (string_of_ctyp ret_ctyp) in + raise (Reporting.err_todo ctx.pragma_l message) | None -> raise (Reporting.err_todo ctx.pragma_l (Printf.sprintf "%s : (%s)" fn args)) @@ -385,36 +439,6 @@ let builtin_gteq = builtin_int_comparison "bvsge" Big_int.greater_equal (* ***** Arithmetic operations: lib/arith.sail ***** *) -(** [force_size ctx n m exp] takes a smt expression assumed to be a - integer (signed bitvector) of length m and forces it to be length n - by either sign extending it or truncating it as required *) -let force_size ?checked:(checked=true) ctx n m smt = - if n = m then - smt - else if n > m then - SignExtend (n - m, smt) - else - let check = - (* If the top bit of the truncated number is one *) - Ite (Fn ("=", [Extract (n - 1, n - 1, smt); Bin "1"]), - (* Then we have an overflow, unless all bits we truncated were also one *) - Fn ("not", [Fn ("=", [Extract (m - 1, n, smt); bvones (m - n)])]), - (* Otherwise, all the top bits must be zero *) - Fn ("not", [Fn ("=", [Extract (m - 1, n, smt); bvzero (m - n)])])) - in - if checked then overflow_check ctx check else (); - Extract (n - 1, 0, smt) - -(** [unsigned_size ctx n m exp] is much like force_size, but it - assumes that the bitvector is unsigned *) -let unsigned_size ?checked:(checked=true) ctx n m smt = - if n = m then - smt - else if n > m then - Fn ("concat", [bvzero (n - m); smt]) - else - Extract (n - 1, 0, smt) - let int_size ctx = function | CT_constant n -> required_width n | CT_fint sz -> sz @@ -457,8 +481,9 @@ let builtin_negate_int ctx v ret_ctyp = | CT_constant c, _ -> bvint (int_size ctx ret_ctyp) (Big_int.negate c) | ctyp, _ -> + let open Sail2_values in let smt = force_size ctx (int_size ctx ret_ctyp) (int_size ctx ctyp) (smt_cval ctx v) in - overflow_check ctx (Fn ("=", [smt; Bin ("1" ^ String.make (int_size ctx ret_ctyp - 1) '0')])); + overflow_check ctx (Fn ("=", [smt; Bitvec_lit (B1 :: List.init (int_size ctx ret_ctyp - 1) (fun _ -> B0))])); Fn ("bvneg", [smt]) let builtin_shift_int fn big_int_fn ctx v1 v2 ret_ctyp = @@ -494,7 +519,7 @@ let builtin_abs_int ctx v ret_ctyp = | ctyp, _ -> let sz = int_size ctx ctyp in let smt = smt_cval ctx v in - Ite (Fn ("=", [Extract (sz - 1, sz -1, smt); Bin "1"]), + Ite (Fn ("=", [Extract (sz - 1, sz -1, smt); Bitvec_lit [Sail2_values.B1]]), force_size ctx (int_size ctx ret_ctyp) sz (Fn ("bvneg", [smt])), force_size ctx (int_size ctx ret_ctyp) sz smt) @@ -531,6 +556,25 @@ let builtin_min_int ctx v1 v2 ret_ctyp = smt1, smt2) +let builtin_min_int ctx v1 v2 ret_ctyp = + match cval_ctyp v1, cval_ctyp v2 with + | CT_constant n, CT_constant m -> + bvint (int_size ctx ret_ctyp) (min n m) + + | ctyp1, ctyp2 -> + let ret_sz = int_size ctx ret_ctyp in + let smt1 = force_size ctx ret_sz (int_size ctx ctyp1) (smt_cval ctx v1) in + let smt2 = force_size ctx ret_sz (int_size ctx ctyp2) (smt_cval ctx v2) in + Ite (Fn ("bvslt", [smt1; smt2]), + smt1, + smt2) + +let builtin_tdiv_int = + builtin_arith "bvudiv" (Sail2_values.tdiv_int) (fun x -> x) + +let builtin_tmod_int = + builtin_arith "bvurem" (Sail2_values.tmod_int) (fun x -> x) + let bvmask ctx len = let all_ones = bvones (lbits_size ctx) in let shift = Fn ("concat", [bvzero (lbits_size ctx - ctx.lbits_index); len]) in @@ -623,7 +667,7 @@ let builtin_sign_extend ctx vbits vlen ret_ctyp = smt_cval ctx vbits | CT_fbits (n, _), CT_fbits (m, _) -> let bv = smt_cval ctx vbits in - let top_bit_one = Fn ("=", [Extract (n - 1, n - 1, bv); Bin "1"]) in + let top_bit_one = Fn ("=", [Extract (n - 1, n - 1, bv); Bitvec_lit [Sail2_values.B1]]) in Ite (top_bit_one, Fn ("concat", [bvones (m - n); bv]), Fn ("concat", [bvzero (m - n); bv])) | _ -> builtin_type_error ctx "sign_extend" [vbits; vlen] (Some ret_ctyp) @@ -658,14 +702,14 @@ let builtin_not_bits ctx v ret_ctyp = | _, _ -> builtin_type_error ctx "not_bits" [v] (Some ret_ctyp) let builtin_bitwise fn ctx v1 v2 ret_ctyp = - match cval_ctyp v1, cval_ctyp v2 with - | CT_fbits (n, _), CT_fbits (m, _) -> - assert (n = m); + match cval_ctyp v1, cval_ctyp v2, ret_ctyp with + | CT_fbits (n, _), CT_fbits (m, _), CT_fbits (o, _) -> + assert (n = m && m = o); let smt1 = smt_cval ctx v1 in let smt2 = smt_cval ctx v2 in Fn (fn, [smt1; smt2]) - | CT_lbits _, CT_lbits _ -> + | CT_lbits _, CT_lbits _, CT_lbits _ -> let smt1 = smt_cval ctx v1 in let smt2 = smt_cval ctx v2 in Fn ("Bits", [Fn ("len", [smt1]); Fn (fn, [Fn ("contents", [smt1]); Fn ("contents", [smt2])])]) @@ -674,6 +718,7 @@ let builtin_bitwise fn ctx v1 v2 ret_ctyp = let builtin_and_bits = builtin_bitwise "bvand" let builtin_or_bits = builtin_bitwise "bvor" +let builtin_xor_bits = builtin_bitwise "bvxor" let builtin_append ctx v1 v2 ret_ctyp = match cval_ctyp v1, cval_ctyp v2, ret_ctyp with @@ -743,19 +788,29 @@ let builtin_length ctx v ret_ctyp = | _, _ -> builtin_type_error ctx "length" [v] (Some ret_ctyp) let builtin_vector_subrange ctx vec i j ret_ctyp = - match cval_ctyp vec, cval_ctyp i, cval_ctyp j with - | CT_fbits (n, _), CT_constant i, CT_constant j -> + match cval_ctyp vec, cval_ctyp i, cval_ctyp j, ret_ctyp with + | CT_fbits (n, _), CT_constant i, CT_constant j, CT_fbits _ -> Extract (Big_int.to_int i, Big_int.to_int j, smt_cval ctx vec) - | CT_lbits _, CT_constant i, CT_constant j -> + | CT_lbits _, CT_constant i, CT_constant j, CT_fbits _ -> Extract (Big_int.to_int i, Big_int.to_int j, Fn ("contents", [smt_cval ctx vec])) + | CT_fbits (n, _), i_ctyp, CT_constant j, CT_lbits _ when Big_int.equal j Big_int.zero -> + let len = force_size ~checked:false ctx ctx.lbits_index (int_size ctx i_ctyp) (smt_cval ctx i) in + Fn ("Bits", [len; Fn ("bvand", [bvmask ctx len; unsigned_size ctx (lbits_size ctx) n (smt_cval ctx vec)])]) + | _ -> builtin_type_error ctx "vector_subrange" [vec; i; j] (Some ret_ctyp) let builtin_vector_access ctx vec i ret_ctyp = match cval_ctyp vec, cval_ctyp i, ret_ctyp with | CT_fbits (n, _), CT_constant i, CT_bit -> Extract (Big_int.to_int i, Big_int.to_int i, smt_cval ctx vec) + | CT_lbits _, CT_constant i, CT_bit -> + Extract (Big_int.to_int i, Big_int.to_int i, Fn ("contents", [smt_cval ctx vec])) + + | CT_lbits _, i_ctyp, CT_bit -> + let shift = force_size ~checked:false ctx (lbits_size ctx) (int_size ctx i_ctyp) (smt_cval ctx i) in + Extract (0, 0, Fn ("bvlshr", [Fn ("contents", [smt_cval ctx vec]); shift])) | CT_vector _, CT_constant i, _ -> Fn ("select", [smt_cval ctx vec; bvint !vector_index i]) @@ -787,6 +842,21 @@ let builtin_vector_update ctx vec i x ret_ctyp = | _ -> builtin_type_error ctx "vector_update" [vec; i; x] (Some ret_ctyp) +let builtin_vector_update_subrange ctx vec i j x ret_ctyp = + match cval_ctyp vec, cval_ctyp i, cval_ctyp j, cval_ctyp x, ret_ctyp with + | CT_fbits (n, _), CT_constant i, CT_constant j, CT_fbits (sz, _), CT_fbits (m, _) when n - 1 > Big_int.to_int i && Big_int.to_int j >= 0 -> + assert (n = m); + let top = Extract (n - 1, Big_int.to_int i + 1, smt_cval ctx vec) in + let bot = Extract (Big_int.to_int j - 1, 0, smt_cval ctx vec) in + Fn ("concat", [top; Fn ("concat", [smt_cval ctx x; bot])]) + + | CT_fbits (n, _), CT_constant i, CT_constant j, CT_fbits (sz, _), CT_fbits (m, _) when n - 1 = Big_int.to_int i && Big_int.to_int j >= 0 -> + assert (n = m); + let bot = Extract (Big_int.to_int j - 1, 0, smt_cval ctx vec) in + Fn ("concat", [smt_cval ctx x; bot]) + + | _ -> builtin_type_error ctx "vector_update_subrange" [vec; i; j; x] (Some ret_ctyp) + let builtin_unsigned ctx v ret_ctyp = match cval_ctyp v, ret_ctyp with | CT_fbits (n, _), CT_fint m when m > n -> @@ -800,6 +870,9 @@ let builtin_unsigned ctx v ret_ctyp = let smt = smt_cval ctx v in Fn ("concat", [bvzero (ctx.lint_size - n); smt]) + | CT_lbits _, CT_lint -> + Extract (ctx.lint_size - 1, 0, Fn ("contents", [smt_cval ctx v])) + | ctyp, _ -> builtin_type_error ctx "unsigned" [v] (Some ret_ctyp) let builtin_signed ctx v ret_ctyp = @@ -810,6 +883,9 @@ let builtin_signed ctx v ret_ctyp = | CT_fbits (n, _), CT_lint -> SignExtend(ctx.lint_size - n, smt_cval ctx v) + | CT_lbits _, CT_lint -> + Extract (ctx.lint_size - 1, 0, Fn ("contents", [smt_cval ctx v])) + | ctyp, _ -> builtin_type_error ctx "signed" [v] (Some ret_ctyp) let builtin_add_bits ctx v1 v2 ret_ctyp = @@ -818,6 +894,11 @@ let builtin_add_bits ctx v1 v2 ret_ctyp = assert (n = m && m = o); Fn ("bvadd", [smt_cval ctx v1; smt_cval ctx v2]) + | CT_lbits _, CT_lbits _, CT_lbits _ -> + let smt1 = smt_cval ctx v1 in + let smt2 = smt_cval ctx v2 in + Fn ("Bits", [Fn ("len", [smt1]); Fn ("bvadd", [Fn ("contents", [smt1]); Fn ("contents", [smt2])])]) + | _ -> builtin_type_error ctx "add_bits" [v1; v2] (Some ret_ctyp) let builtin_sub_bits ctx v1 v2 ret_ctyp = @@ -866,6 +947,13 @@ let builtin_replicate_bits ctx v1 v2 ret_ctyp = let c = m / n in Fn ("concat", List.init c (fun _ -> smt)) + | CT_fbits (n, _), v2_ctyp, CT_lbits _ -> + let times = (lbits_size ctx / n) + 1 in + let len = force_size ~checked:false ctx ctx.lbits_index (int_size ctx v2_ctyp) (smt_cval ctx v2) in + let smt1 = smt_cval ctx v1 in + let contents = Extract (lbits_size ctx - 1, 0, Fn ("concat", List.init times (fun _ -> smt1))) in + Fn ("Bits", [len; Fn ("bvand", [bvmask ctx len; contents])]) + | _ -> builtin_type_error ctx "replicate_bits" [v1; v2] (Some ret_ctyp) let builtin_sail_truncate ctx v1 v2 ret_ctyp = @@ -928,13 +1016,18 @@ let builtin_get_slice_int ctx v1 v2 v3 ret_ctyp = in Extract ((start + len) - 1, start, smt) + | CT_lint, CT_lint, CT_constant start, CT_lbits _ when Big_int.equal start Big_int.zero -> + let len = Extract (ctx.lbits_index - 1, 0, smt_cval ctx v1) in + let contents = unsigned_size ~checked:false ctx (lbits_size ctx) ctx.lint_size (smt_cval ctx v2) in + Fn ("Bits", [len; Fn ("bvand", [bvmask ctx len; contents])]) + | _ -> builtin_type_error ctx "get_slice_int" [v1; v2; v3] (Some ret_ctyp) let builtin_count_leading_zeros ctx v ret_ctyp = let ret_sz = int_size ctx ret_ctyp in let rec lzcnt sz smt = if sz == 1 then - Ite (Fn ("=", [Extract (0, 0, smt); Bin "0"]), + Ite (Fn ("=", [Extract (0, 0, smt); Bitvec_lit [Sail2_values.B0]]), bvint ret_sz (Big_int.of_int 1), bvint ret_sz (Big_int.zero)) else ( @@ -1050,6 +1143,8 @@ let smt_builtin ctx name args ret_ctyp = | "max_int", [v1; v2], _ -> builtin_max_int ctx v1 v2 ret_ctyp | "min_int", [v1; v2], _ -> builtin_min_int ctx v1 v2 ret_ctyp + | "ediv_int", [v1; v2], _ -> builtin_tdiv_int ctx v1 v2 ret_ctyp + (* All signed and unsigned bitvector comparisons *) | "slt_bits", [v1; v2], CT_bool -> builtin_compare_bits "bvslt" ctx v1 v2 ret_ctyp | "ult_bits", [v1; v2], CT_bool -> builtin_compare_bits "bvult" ctx v1 v2 ret_ctyp @@ -1072,8 +1167,9 @@ let smt_builtin ctx name args ret_ctyp = | "sail_truncateLSB", [v1; v2], _ -> builtin_sail_truncateLSB ctx v1 v2 ret_ctyp | "shiftl", [v1; v2], _ -> builtin_shift "bvshl" ctx v1 v2 ret_ctyp | "shiftr", [v1; v2], _ -> builtin_shift "bvlshr" ctx v1 v2 ret_ctyp - | "or_bits", [v1; v2], _ -> builtin_or_bits ctx v1 v2 ret_ctyp | "and_bits", [v1; v2], _ -> builtin_and_bits ctx v1 v2 ret_ctyp + | "or_bits", [v1; v2], _ -> builtin_or_bits ctx v1 v2 ret_ctyp + | "xor_bits", [v1; v2], _ -> builtin_xor_bits ctx v1 v2 ret_ctyp | "not_bits", [v], _ -> builtin_not_bits ctx v ret_ctyp | "add_bits", [v1; v2], _ -> builtin_add_bits ctx v1 v2 ret_ctyp | "add_bits_int", [v1; v2], _ -> builtin_add_bits_int ctx v1 v2 ret_ctyp @@ -1084,6 +1180,7 @@ let smt_builtin ctx name args ret_ctyp = | "vector_access", [v1; v2], ret_ctyp -> builtin_vector_access ctx v1 v2 ret_ctyp | "vector_subrange", [v1; v2; v3], ret_ctyp -> builtin_vector_subrange ctx v1 v2 v3 ret_ctyp | "vector_update", [v1; v2; v3], ret_ctyp -> builtin_vector_update ctx v1 v2 v3 ret_ctyp + | "vector_update_subrange", [v1; v2; v3; v4], ret_ctyp -> builtin_vector_update_subrange ctx v1 v2 v3 v4 ret_ctyp | "sail_unsigned", [v], ret_ctyp -> builtin_unsigned ctx v ret_ctyp | "sail_signed", [v], ret_ctyp -> builtin_signed ctx v ret_ctyp | "replicate_bits", [v1; v2], ret_ctyp -> builtin_replicate_bits ctx v1 v2 ret_ctyp @@ -1110,16 +1207,30 @@ let smt_builtin ctx name args ret_ctyp = | "lteq_real", [v1; v2], CT_bool -> ctx.use_real := true; Fn ("<=", [smt_cval ctx v1; smt_cval ctx v2]) | "gteq_real", [v1; v2], CT_bool -> ctx.use_real := true; Fn (">=", [smt_cval ctx v1; smt_cval ctx v2]) - | _ -> failwith ("Unknown builtin " ^ name ^ " " ^ Util.string_of_list ", " string_of_ctyp (List.map cval_ctyp args) ^ " -> " ^ string_of_ctyp ret_ctyp) + | _ -> + Reporting.unreachable ctx.pragma_l __POS__ ("Unknown builtin " ^ name ^ " " ^ Util.string_of_list ", " string_of_ctyp (List.map cval_ctyp args) ^ " -> " ^ string_of_ctyp ret_ctyp) + +let loc_doc = function + | Parse_ast.Documented (str, l) -> str + | _ -> "UNKNOWN" (* Memory reads and writes as defined in lib/regfp.sail *) let writes = ref (-1) -let builtin_write_mem ctx wk addr_size addr data_size data = +let builtin_write_mem l ctx wk addr_size addr data_size data = incr writes; let name = "W" ^ string_of_int !writes in - [Write_mem (name, ctx.node, Lazy.force ctx.pathcond, smt_cval ctx wk, - smt_cval ctx addr, smt_ctyp ctx (cval_ctyp addr), smt_cval ctx data, smt_ctyp ctx (cval_ctyp data))], + [Write_mem { + name = name; + node = ctx.node; + active = Lazy.force ctx.pathcond; + kind = smt_cval ctx wk; + addr = smt_cval ctx addr; + addr_type = smt_ctyp ctx (cval_ctyp addr); + data = smt_cval ctx data; + data_type = smt_ctyp ctx (cval_ctyp data); + doc = loc_doc l + }], Var (name ^ "_ret") let ea_writes = ref (-1) @@ -1133,11 +1244,19 @@ let builtin_write_mem_ea ctx wk addr_size addr data_size = let reads = ref (-1) -let builtin_read_mem ctx rk addr_size addr data_size ret_ctyp = +let builtin_read_mem l ctx rk addr_size addr data_size ret_ctyp = incr reads; let name = "R" ^ string_of_int !reads in - [Read_mem (name, ctx.node, Lazy.force ctx.pathcond, smt_ctyp ctx ret_ctyp, smt_cval ctx rk, - smt_cval ctx addr, smt_ctyp ctx (cval_ctyp addr))], + [Read_mem { + name = name; + node = ctx.node; + active = Lazy.force ctx.pathcond; + ret_type = smt_ctyp ctx ret_ctyp; + kind = smt_cval ctx rk; + addr = smt_cval ctx addr; + addr_type = smt_ctyp ctx (cval_ctyp addr); + doc = loc_doc l + }], Read_res name let excl_results = ref (-1) @@ -1150,26 +1269,51 @@ let builtin_excl_res ctx = let barriers = ref (-1) -let builtin_barrier ctx bk = +let builtin_barrier l ctx bk = incr barriers; let name = "B" ^ string_of_int !barriers in - [Barrier (name, ctx.node, Lazy.force ctx.pathcond, smt_cval ctx bk)], + [Barrier { + name = name; + node = ctx.node; + active = Lazy.force ctx.pathcond; + kind = smt_cval ctx bk; + doc = loc_doc l + }], Enum "unit" -let rec smt_conversion ctx from_ctyp to_ctyp x = - match from_ctyp, to_ctyp with - | _, _ when ctyp_equal from_ctyp to_ctyp -> x - | CT_constant c, CT_fint sz -> - bvint sz c - | CT_constant c, CT_lint -> - bvint ctx.lint_size c - | CT_fint sz, CT_lint -> - force_size ctx ctx.lint_size sz x - | CT_lbits _, CT_fbits (n, _) -> - unsigned_size ctx n (lbits_size ctx) (Fn ("contents", [x])) - | _, _ -> failwith (Printf.sprintf "Cannot perform conversion from %s to %s" (string_of_ctyp from_ctyp) (string_of_ctyp to_ctyp)) +let cache_maintenances = ref (-1) + +let builtin_cache_maintenance l ctx cmk addr_size addr = + incr cache_maintenances; + let name = "M" ^ string_of_int !cache_maintenances in + [Cache_maintenance { + name = name; + node = ctx.node; + active = Lazy.force ctx.pathcond; + kind = smt_cval ctx cmk; + addr = smt_cval ctx addr; + addr_type = smt_ctyp ctx (cval_ctyp addr); + doc = loc_doc l + }], + Enum "unit" + +let branch_announces = ref (-1) + +let builtin_branch_announce l ctx addr_size addr = + incr branch_announces; + let name = "C" ^ string_of_int !branch_announces in + [Branch_announce { + name = name; + node = ctx.node; + active = Lazy.force ctx.pathcond; + addr = smt_cval ctx addr; + addr_type = smt_ctyp ctx (cval_ctyp addr); + doc = loc_doc l + }], + Enum "unit" let define_const ctx id ctyp exp = Define_const (zencode_name id, smt_ctyp ctx ctyp, exp) +let preserve_const ctx id ctyp exp = Preserve_const (string_of_id id, smt_ctyp ctx ctyp, exp) let declare_const ctx id ctyp = Declare_const (zencode_name id, smt_ctyp ctx ctyp) let smt_ctype_def ctx = function @@ -1205,143 +1349,144 @@ let rec generate_reg_decs ctx inits = function let max_int n = Big_int.pred (Big_int.pow_int_positive 2 (n - 1)) let min_int n = Big_int.negate (Big_int.pow_int_positive 2 (n - 1)) -(** Convert a sail type into a C-type. This function can be quite - slow, because it uses ctx.local_env and SMT to analyse the Sail - types and attempts to fit them into the smallest possible C - types, provided ctx.optimize_smt is true (default) **) -let rec ctyp_of_typ ctx typ = - let open Ast in - let open Type_check in - let open Jib_compile in - let Typ_aux (typ_aux, l) as typ = Env.expand_synonyms ctx.tc_env typ in - match typ_aux with - | Typ_id id when string_of_id id = "bit" -> CT_bit - | Typ_id id when string_of_id id = "bool" -> CT_bool - | Typ_id id when string_of_id id = "int" -> CT_lint - | Typ_id id when string_of_id id = "nat" -> CT_lint - | Typ_id id when string_of_id id = "unit" -> CT_unit - | Typ_id id when string_of_id id = "string" -> CT_string - | Typ_id id when string_of_id id = "real" -> CT_real - - | Typ_app (id, _) when string_of_id id = "atom_bool" -> CT_bool - - | Typ_app (id, args) when string_of_id id = "itself" -> - ctyp_of_typ ctx (Typ_aux (Typ_app (mk_id "atom", args), l)) - | Typ_app (id, _) when string_of_id id = "range" || string_of_id id = "atom" || string_of_id id = "implicit" -> - begin match destruct_range Env.empty typ with - | None -> assert false (* Checked if range type in guard *) - | Some (kids, constr, n, m) -> - let ctx = { ctx with local_env = add_existential Parse_ast.Unknown (List.map (mk_kopt K_int) kids) constr ctx.local_env } in - match nexp_simp n, nexp_simp m with - | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) - when n = m -> - CT_constant n - | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) - when Big_int.less_equal (min_int 64) n && Big_int.less_equal m (max_int 64) -> - CT_fint 64 - | n, m -> - if prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) then +module SMT_config : Jib_compile.Config = struct + open Jib_compile + + (** Convert a sail type into a C-type. This function can be quite + slow, because it uses ctx.local_env and SMT to analyse the Sail + types and attempts to fit them into the smallest possible C + types, provided ctx.optimize_smt is true (default) **) + let rec convert_typ ctx typ = + let open Ast in + let open Type_check in + let Typ_aux (typ_aux, l) as typ = Env.expand_synonyms ctx.tc_env typ in + match typ_aux with + | Typ_id id when string_of_id id = "bit" -> CT_bit + | Typ_id id when string_of_id id = "bool" -> CT_bool + | Typ_id id when string_of_id id = "int" -> CT_lint + | Typ_id id when string_of_id id = "nat" -> CT_lint + | Typ_id id when string_of_id id = "unit" -> CT_unit + | Typ_id id when string_of_id id = "string" -> CT_string + | Typ_id id when string_of_id id = "real" -> CT_real + + | Typ_app (id, _) when string_of_id id = "atom_bool" -> CT_bool + + | Typ_app (id, args) when string_of_id id = "itself" -> + convert_typ ctx (Typ_aux (Typ_app (mk_id "atom", args), l)) + | Typ_app (id, _) when string_of_id id = "range" || string_of_id id = "atom" || string_of_id id = "implicit" -> + begin match destruct_range Env.empty typ with + | None -> assert false (* Checked if range type in guard *) + | Some (kids, constr, n, m) -> + let ctx = { ctx with local_env = add_existential Parse_ast.Unknown (List.map (mk_kopt K_int) kids) constr ctx.local_env } in + match nexp_simp n, nexp_simp m with + | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) + when n = m -> + CT_constant n + | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) + when Big_int.less_equal (min_int 64) n && Big_int.less_equal m (max_int 64) -> CT_fint 64 - else - CT_lint - end - - | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" -> - CT_list (ctyp_of_typ ctx typ) - - (* Note that we have to use lbits for zero-length bitvectors because they are not allowed by SMTLIB *) - | Typ_app (id, [A_aux (A_nexp n, _); A_aux (A_order ord, _)]) - when string_of_id id = "bitvector" -> - 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.equal n Big_int.zero -> CT_lbits direction - | Nexp_aux (Nexp_constant n, _) -> CT_fbits (Big_int.to_int n, direction) - | _ -> CT_lbits direction - end - - | Typ_app (id, [A_aux (A_nexp n, _); - A_aux (A_order ord, _); - A_aux (A_typ typ, _)]) - when string_of_id id = "vector" -> - let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in - CT_vector (direction, ctyp_of_typ ctx typ) - - | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "register" -> - CT_ref (ctyp_of_typ ctx typ) - - | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.records -> CT_struct (id, Bindings.find id ctx.records |> UBindings.bindings) - | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.variants -> CT_variant (id, Bindings.find id ctx.variants |> UBindings.bindings) - | Typ_id id when Bindings.mem id ctx.enums -> CT_enum (id, Bindings.find id ctx.enums |> IdSet.elements) - - | Typ_tup typs -> CT_tup (List.map (ctyp_of_typ ctx) typs) - - | Typ_exist _ -> - (* Use Type_check.destruct_exist when optimising with SMT, to - ensure that we don't cause any type variable clashes in - local_env, and that we can optimize the existential based upon - it's constraints. *) - begin match destruct_exist (Env.expand_synonyms ctx.local_env typ) with - | Some (kids, nc, typ) -> - let env = add_existential l kids nc ctx.local_env in - ctyp_of_typ { ctx with local_env = env } typ - | None -> raise (Reporting.err_unreachable l __POS__ "Existential cannot be destructured!") - end - - | Typ_var kid -> CT_poly - - | _ -> raise (Reporting.err_unreachable l __POS__ ("No SMT type for type " ^ string_of_typ typ)) + | n, m -> + if prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) then + CT_fint 64 + else + CT_lint + end -(**************************************************************************) -(* 3. Optimization of primitives and literals *) -(**************************************************************************) + | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" -> + CT_list (convert_typ ctx typ) + + (* Note that we have to use lbits for zero-length bitvectors because they are not allowed by SMTLIB *) + | Typ_app (id, [A_aux (A_nexp n, _); A_aux (A_order ord, _)]) + when string_of_id id = "bitvector" -> + 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.equal n Big_int.zero -> CT_lbits direction + | Nexp_aux (Nexp_constant n, _) -> CT_fbits (Big_int.to_int n, direction) + | _ -> CT_lbits direction + end -let hex_char = - let open Sail2_values in - function - | '0' -> [B0; B0; B0; B0] - | '1' -> [B0; B0; B0; B1] - | '2' -> [B0; B0; B1; B0] - | '3' -> [B0; B0; B1; B1] - | '4' -> [B0; B1; B0; B0] - | '5' -> [B0; B1; B0; B1] - | '6' -> [B0; B1; B1; B0] - | '7' -> [B0; B1; B1; B1] - | '8' -> [B1; B0; B0; B0] - | '9' -> [B1; B0; B0; B1] - | 'A' | 'a' -> [B1; B0; B1; B0] - | 'B' | 'b' -> [B1; B0; B1; B1] - | 'C' | 'c' -> [B1; B1; B0; B0] - | 'D' | 'd' -> [B1; B1; B0; B1] - | 'E' | 'e' -> [B1; B1; B1; B0] - | 'F' | 'f' -> [B1; B1; B1; B1] - | _ -> failwith "Invalid hex character" - -let literal_to_cval (L_aux (l_aux, _) as lit) = - match l_aux with - | L_num n -> Some (V_lit (VL_int n, CT_constant n)) - | L_hex str when String.length str <= 16 -> - let content = Util.string_to_list str |> List.map hex_char |> List.concat in - Some (V_lit (VL_bits (content, true), CT_fbits (String.length str * 4, true))) - | L_unit -> Some (V_lit (VL_unit, CT_unit)) - | L_true -> Some (V_lit (VL_bool true, CT_bool)) - | L_false -> Some (V_lit (VL_bool false, CT_bool)) - | _ -> None - -let c_literals ctx = - let rec c_literal env l = function - | AV_lit (lit, typ) as v -> - begin match literal_to_cval lit with - | Some cval -> AV_cval (cval, typ) - | None -> v + | Typ_app (id, [A_aux (A_nexp n, _); + A_aux (A_order ord, _); + A_aux (A_typ typ, _)]) + when string_of_id id = "vector" -> + let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in + CT_vector (direction, convert_typ ctx typ) + + | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "register" -> + CT_ref (convert_typ ctx typ) + + | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.records -> CT_struct (id, Bindings.find id ctx.records |> UBindings.bindings) + | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.variants -> CT_variant (id, Bindings.find id ctx.variants |> UBindings.bindings) + | Typ_id id when Bindings.mem id ctx.enums -> CT_enum (id, Bindings.find id ctx.enums |> IdSet.elements) + + | Typ_tup typs -> CT_tup (List.map (convert_typ ctx) typs) + + | Typ_exist _ -> + (* Use Type_check.destruct_exist when optimising with SMT, to + ensure that we don't cause any type variable clashes in + local_env, and that we can optimize the existential based + upon it's constraints. *) + begin match destruct_exist (Env.expand_synonyms ctx.local_env typ) with + | Some (kids, nc, typ) -> + let env = add_existential l kids nc ctx.local_env in + convert_typ { ctx with local_env = env } typ + | None -> raise (Reporting.err_unreachable l __POS__ "Existential cannot be destructured!") end - | AV_tuple avals -> AV_tuple (List.map (c_literal env l) avals) - | v -> v - in - map_aval c_literal -let unroll_foreach ctx = function + | Typ_var kid -> CT_poly + + | _ -> raise (Reporting.err_unreachable l __POS__ ("No SMT type for type " ^ string_of_typ typ)) + + let hex_char = + let open Sail2_values in + function + | '0' -> [B0; B0; B0; B0] + | '1' -> [B0; B0; B0; B1] + | '2' -> [B0; B0; B1; B0] + | '3' -> [B0; B0; B1; B1] + | '4' -> [B0; B1; B0; B0] + | '5' -> [B0; B1; B0; B1] + | '6' -> [B0; B1; B1; B0] + | '7' -> [B0; B1; B1; B1] + | '8' -> [B1; B0; B0; B0] + | '9' -> [B1; B0; B0; B1] + | 'A' | 'a' -> [B1; B0; B1; B0] + | 'B' | 'b' -> [B1; B0; B1; B1] + | 'C' | 'c' -> [B1; B1; B0; B0] + | 'D' | 'd' -> [B1; B1; B0; B1] + | 'E' | 'e' -> [B1; B1; B1; B0] + | 'F' | 'f' -> [B1; B1; B1; B1] + | _ -> failwith "Invalid hex character" + + let literal_to_cval (L_aux (l_aux, _) as lit) = + match l_aux with + | L_num n -> Some (V_lit (VL_int n, CT_constant n)) + | L_hex str when String.length str <= 16 -> + let content = Util.string_to_list str |> List.map hex_char |> List.concat in + Some (V_lit (VL_bits (content, true), CT_fbits (String.length str * 4, true))) + | L_unit -> Some (V_lit (VL_unit, CT_unit)) + | L_true -> Some (V_lit (VL_bool true, CT_bool)) + | L_false -> Some (V_lit (VL_bool false, CT_bool)) + | _ -> None + + let c_literals ctx = + let rec c_literal env l = function + | AV_lit (lit, typ) as v -> + begin match literal_to_cval lit with + | Some cval -> AV_cval (cval, typ) + | None -> v + end + | AV_tuple avals -> AV_tuple (List.map (c_literal env l) avals) + | v -> v + in + map_aval c_literal + +(* If we know the loop variables exactly (especially after + specialization), we can unroll the exact number of times required, + and omit any comparisons. *) +let unroll_static_foreach ctx = function | AE_aux (AE_for (id, from_aexp, to_aexp, by_aexp, order, body), env, l) as aexp -> - begin match ctyp_of_typ ctx (aexp_typ from_aexp), ctyp_of_typ ctx (aexp_typ to_aexp), ctyp_of_typ ctx (aexp_typ by_aexp), order with + begin match convert_typ ctx (aexp_typ from_aexp), convert_typ ctx (aexp_typ to_aexp), convert_typ ctx (aexp_typ by_aexp), order with | CT_constant f, CT_constant t, CT_constant b, Ord_aux (Ord_inc, _) -> let i = ref f in let unrolled = ref [] in @@ -1360,6 +1505,19 @@ let unroll_foreach ctx = function end | aexp -> aexp + let optimize_anf ctx aexp = + aexp + |> c_literals ctx + |> fold_aexp (unroll_static_foreach ctx) + + let specialize_calls = true + let ignore_64 = true + let unroll_loops () = Some !opt_unroll_limit + let struct_value = true + let use_real = true +end + + (**************************************************************************) (* 3. Generating SMT *) (**************************************************************************) @@ -1414,7 +1572,7 @@ let smt_ssanode ctx cfg preds = pis ids None in match mux with - | None -> [] + | None -> assert false | Some mux -> [Define_const (zencode_name id, smt_ctyp ctx ctyp, mux)] @@ -1492,7 +1650,7 @@ let rec rmw_write = function | CL_id _ -> assert false | CL_tuple (clexp, _) -> rmw_write clexp | CL_field (clexp, _) -> rmw_write clexp - | clexp -> assert false + | clexp -> failwith "Could not understand l-expression" let rmw_read = function | CL_rmw (read, _, _) -> zencode_name read @@ -1522,7 +1680,7 @@ let rmw_modify smt = function if UId.compare field field' = 0 then smt else - Fn (zencode_upper_id struct_id ^ "_" ^ zencode_uid field', [Var (rmw_read clexp)]) + Field (zencode_upper_id struct_id ^ "_" ^ zencode_uid field', Var (rmw_read clexp)) in Fn (zencode_upper_id struct_id, List.map set_field fields) | _ -> @@ -1564,7 +1722,7 @@ let smt_instr ctx = else if name = "platform_write_mem" then begin match args with | [wk; addr_size; addr; data_size; data] -> - let mem_event, var = builtin_write_mem ctx wk addr_size addr data_size data in + let mem_event, var = builtin_write_mem l ctx wk addr_size addr data_size data in mem_event @ [define_const ctx id ret_ctyp var] | _ -> Reporting.unreachable l __POS__ "Bad arguments for __write_mem" @@ -1580,7 +1738,7 @@ let smt_instr ctx = else if name = "platform_read_mem" then begin match args with | [rk; addr_size; addr; data_size] -> - let mem_event, var = builtin_read_mem ctx rk addr_size addr data_size ret_ctyp in + let mem_event, var = builtin_read_mem l ctx rk addr_size addr data_size ret_ctyp in mem_event @ [define_const ctx id ret_ctyp var] | _ -> Reporting.unreachable l __POS__ "Bad arguments for __read_mem" @@ -1588,7 +1746,23 @@ let smt_instr ctx = else if name = "platform_barrier" then begin match args with | [bk] -> - let mem_event, var = builtin_barrier ctx bk in + let mem_event, var = builtin_barrier l ctx bk in + mem_event @ [define_const ctx id ret_ctyp var] + | _ -> + Reporting.unreachable l __POS__ "Bad arguments for __barrier" + end + else if name = "platform_cache_maintenance" then + begin match args with + | [cmk; addr_size; addr] -> + let mem_event, var = builtin_cache_maintenance l ctx cmk addr_size addr in + mem_event @ [define_const ctx id ret_ctyp var] + | _ -> + Reporting.unreachable l __POS__ "Bad arguments for __barrier" + end + else if name = "platform_branch_announce" then + begin match args with + | [addr_size; addr] -> + let mem_event, var = builtin_branch_announce l ctx addr_size addr in mem_event @ [define_const ctx id ret_ctyp var] | _ -> Reporting.unreachable l __POS__ "Bad arguments for __barrier" @@ -1601,9 +1775,20 @@ let smt_instr ctx = | _ -> Reporting.unreachable l __POS__ "Bad arguments for __excl_res" end + else if name = "sail_exit" then + (add_event ctx Assertion (Bool_lit false); []) + else if name = "sail_assert" then + begin match args with + | [assertion; _] -> + let smt = smt_cval ctx assertion in + add_event ctx Assertion (Fn ("not", [smt])); + [] + | _ -> + Reporting.unreachable l __POS__ "Bad arguments for assertion" + end else let value = smt_builtin ctx name args ret_ctyp in - [define_const ctx id ret_ctyp value] + [define_const ctx id ret_ctyp (Syntactic (value, List.map (smt_cval ctx) args))] else if extern && string_of_id (fst function_id) = "internal_vector_init" then [declare_const ctx id ret_ctyp] else if extern && string_of_id (fst function_id) = "internal_vector_update" then @@ -1615,15 +1800,6 @@ let smt_instr ctx = | _ -> Reporting.unreachable l __POS__ "Bad arguments for internal_vector_update" end - else if string_of_id (fst function_id) = "sail_assert" then - begin match args with - | [assertion; _] -> - let smt = smt_cval ctx assertion in - add_event ctx Assertion smt; - [] - | _ -> - Reporting.unreachable l __POS__ "Bad arguments for assertion" - end else if string_of_id (fst function_id) = "sail_assume" then begin match args with | [assumption] -> @@ -1643,8 +1819,14 @@ let smt_instr ctx = Reporting.unreachable l __POS__ "Register reference write should be re-written by now" | I_aux (I_init (ctyp, id, cval), _) | I_aux (I_copy (CL_id (id, ctyp), cval), _) -> - [define_const ctx id ctyp - (smt_conversion ctx (cval_ctyp cval) ctyp (smt_cval ctx cval))] + begin match id with + | Name (id, _) when IdSet.mem id ctx.preserved -> + [preserve_const ctx id ctyp + (smt_conversion ctx (cval_ctyp cval) ctyp (smt_cval ctx cval))] + | _ -> + [define_const ctx id ctyp + (smt_conversion ctx (cval_ctyp cval) ctyp (smt_cval ctx cval))] + end | I_aux (I_copy (clexp, cval), _) -> let smt = smt_cval ctx cval in @@ -1721,13 +1903,19 @@ module Make_optimizer(S : Sequence) = struct | Some n -> Hashtbl.replace uses var (n + 1) | None -> Hashtbl.add uses var 1 end - | Enum _ | Read_res _ | Hex _ | Bin _ | Bool_lit _ | String_lit _ | Real_lit _ -> () + | Syntactic (exp, _) -> uses_in_exp exp + | Shared _ | Enum _ | Read_res _ | Bitvec_lit _ | Bool_lit _ | String_lit _ | Real_lit _ -> () | Fn (_, exps) | Ctor (_, exps) -> List.iter uses_in_exp exps + | Field (_, exp) -> + uses_in_exp exp + | Struct (_, fields) -> + List.iter (fun (_, exp) -> uses_in_exp exp) fields | Ite (cond, t, e) -> uses_in_exp cond; uses_in_exp t; uses_in_exp e | Extract (_, _, exp) | Tester (_, exp) | SignExtend (_, exp) -> uses_in_exp exp + | Forall _ -> assert false in let remove_unused () = function @@ -1737,6 +1925,11 @@ module Make_optimizer(S : Sequence) = struct | Some _ -> Stack.push def stack' end + | Declare_fun _ as def -> + Stack.push def stack' + | Preserve_const (_, _, exp) as def -> + uses_in_exp exp; + Stack.push def stack' | Define_const (var, _, exp) as def -> begin match Hashtbl.find_opt uses var with | None -> () @@ -1746,17 +1939,23 @@ module Make_optimizer(S : Sequence) = struct end | (Declare_datatypes _ | Declare_tuple _) as def -> Stack.push def stack' - | Write_mem (_, _, active, wk, addr, _, data, _) as def -> - uses_in_exp active; uses_in_exp wk; uses_in_exp addr; uses_in_exp data; + | Write_mem w as def -> + uses_in_exp w.active; uses_in_exp w.kind; uses_in_exp w.addr; uses_in_exp w.data; Stack.push def stack' | Write_mem_ea (_, _, active, wk, addr, _, data_size, _) as def -> uses_in_exp active; uses_in_exp wk; uses_in_exp addr; uses_in_exp data_size; Stack.push def stack' - | Read_mem (_, _, active, _, rk, addr, _) as def -> - uses_in_exp active; uses_in_exp rk; uses_in_exp addr; + | Read_mem r as def -> + uses_in_exp r.active; uses_in_exp r.kind; uses_in_exp r.addr; + Stack.push def stack' + | Barrier b as def -> + uses_in_exp b.active; uses_in_exp b.kind; Stack.push def stack' - | Barrier (_, _, active, bk) as def -> - uses_in_exp active; uses_in_exp bk; + | Cache_maintenance m as def -> + uses_in_exp m.active; uses_in_exp m.kind; uses_in_exp m.addr; + Stack.push def stack' + | Branch_announce c as def -> + uses_in_exp c.active; uses_in_exp c.addr; Stack.push def stack' | Excl_res (_, _, active) as def -> uses_in_exp active; @@ -1775,10 +1974,14 @@ module Make_optimizer(S : Sequence) = struct let constant_propagate = function | Declare_const _ as def -> S.add def seq + | Declare_fun _ as def -> + S.add def seq + | Preserve_const (var, typ, exp) -> + S.add (Preserve_const (var, typ, simp_smt_exp vars kinds exp)) seq | Define_const (var, typ, exp) -> let exp = simp_smt_exp vars kinds exp in begin match Hashtbl.find_opt uses var, simp_smt_exp vars kinds exp with - | _, (Bin _ | Bool_lit _) -> + | _, (Bitvec_lit _ | Bool_lit _) -> Hashtbl.add vars var exp | _, Var _ when !opt_propagate_vars -> Hashtbl.add vars var exp @@ -1791,20 +1994,30 @@ module Make_optimizer(S : Sequence) = struct S.add (Define_const (var, typ, exp)) seq | None, _ -> assert false end - | Write_mem (name, node, active, wk, addr, addr_ty, data, data_ty) -> - S.add (Write_mem (name, node, simp_smt_exp vars kinds active, simp_smt_exp vars kinds wk, - simp_smt_exp vars kinds addr, addr_ty, simp_smt_exp vars kinds data, data_ty)) + | Write_mem w -> + S.add (Write_mem { w with active = simp_smt_exp vars kinds w.active; + kind = simp_smt_exp vars kinds w.kind; + addr = simp_smt_exp vars kinds w.addr; + data = simp_smt_exp vars kinds w.data }) seq | Write_mem_ea (name, node, active, wk, addr, addr_ty, data_size, data_size_ty) -> S.add (Write_mem_ea (name, node, simp_smt_exp vars kinds active, simp_smt_exp vars kinds wk, simp_smt_exp vars kinds addr, addr_ty, simp_smt_exp vars kinds data_size, data_size_ty)) seq - | Read_mem (name, node, active, typ, rk, addr, addr_typ) -> - S.add (Read_mem (name, node, simp_smt_exp vars kinds active, typ, simp_smt_exp vars kinds rk, - simp_smt_exp vars kinds addr, addr_typ)) + | Read_mem r -> + S.add (Read_mem { r with active = simp_smt_exp vars kinds r.active; + kind = simp_smt_exp vars kinds r.kind; + addr = simp_smt_exp vars kinds r.addr }) seq - | Barrier (name, node, active, bk) -> - S.add (Barrier (name, node, simp_smt_exp vars kinds active, simp_smt_exp vars kinds bk)) seq + | Barrier b -> + S.add (Barrier { b with active = simp_smt_exp vars kinds b.active; kind = simp_smt_exp vars kinds b.kind }) seq + | Cache_maintenance m -> + S.add (Cache_maintenance { m with active = simp_smt_exp vars kinds m.active; + kind = simp_smt_exp vars kinds m.kind; + addr = simp_smt_exp vars kinds m.addr }) + seq + | Branch_announce c -> + S.add (Branch_announce { c with active = simp_smt_exp vars kinds c.active; addr = simp_smt_exp vars kinds c.addr }) seq | Excl_res (name, node, active) -> S.add (Excl_res (name, node, simp_smt_exp vars kinds active)) seq | Assert exp -> @@ -1843,6 +2056,26 @@ let smt_header ctx cdefs = register if it is. We also do a similar thing for *r = x *) let expand_reg_deref env register_map = function + | I_aux (I_funcall (CL_addr (CL_id (id, ctyp)), false, function_id, args), (_, l)) -> + begin match ctyp with + | CT_ref reg_ctyp -> + begin match CTMap.find_opt reg_ctyp register_map with + | Some regs -> + let end_label = label "end_reg_write_" in + let try_reg r = + let next_label = label "next_reg_write_" in + [ijump l (V_call (Neq, [V_lit (VL_ref (string_of_id r), reg_ctyp); V_id (id, ctyp)])) next_label; + ifuncall (CL_id (name r, reg_ctyp)) function_id args; + igoto end_label; + ilabel next_label] + in + iblock (List.concat (List.map try_reg regs) @ [ilabel end_label]) + | None -> + raise (Reporting.err_general l ("Could not find any registers with type " ^ string_of_ctyp reg_ctyp)) + end + | _ -> + raise (Reporting.err_general l "Register reference assignment must take a register reference as an argument") + end | I_aux (I_funcall (clexp, false, function_id, [reg_ref]), (_, l)) as instr -> let open Type_check in begin match (if Env.is_extern (fst function_id) env "smt" then Some (Env.get_extern (fst function_id) env "smt") else None) with @@ -1855,7 +2088,7 @@ let expand_reg_deref env register_map = function let end_label = label "end_reg_deref_" in let try_reg r = let next_label = label "next_reg_deref_" in - [ijump (V_call (Neq, [V_ref (name r, reg_ctyp); reg_ref])) next_label; + [ijump l (V_call (Neq, [V_lit (VL_ref (string_of_id r), reg_ctyp); reg_ref])) next_label; icopy l clexp (V_id (name r, reg_ctyp)); igoto end_label; ilabel next_label] @@ -1877,7 +2110,7 @@ let expand_reg_deref env register_map = function let end_label = label "end_reg_write_" in let try_reg r = let next_label = label "next_reg_write_" in - [ijump (V_call (Neq, [V_ref (name r, reg_ctyp); V_id (id, ctyp)])) next_label; + [ijump l (V_call (Neq, [V_lit (VL_ref (string_of_id r), reg_ctyp); V_id (id, ctyp)])) next_label; icopy l (CL_id (name r, reg_ctyp)) cval; igoto end_label; ilabel next_label] @@ -1927,7 +2160,7 @@ let smt_instr_list name ctx all_cdefs instrs = dump_graph name cfg; List.iter (fun n -> - begin match get_vertex cfg n with + match get_vertex cfg n with | None -> () | Some ((ssa_elems, cfnode), preds, succs) -> let muxers = @@ -1937,13 +2170,12 @@ let smt_instr_list name ctx all_cdefs instrs = let basic_block = smt_cfnode all_cdefs ctx ssa_elems cfnode in push_smt_defs stack muxers; push_smt_defs stack basic_block - end ) visit_order; - stack, cfg + stack, start, cfg let smt_cdef props lets name_file ctx all_cdefs = function - | CDEF_spec (function_id, arg_ctyps, ret_ctyp) when Bindings.mem function_id props -> + | CDEF_spec (function_id, _, arg_ctyps, ret_ctyp) when Bindings.mem function_id props -> begin match find_function [] function_id all_cdefs with | intervening_lets, Some (None, args, instrs) -> let prop_type, prop_args, pragma_l, vs = Bindings.find function_id props in @@ -1967,7 +2199,7 @@ let smt_cdef props lets name_file ctx all_cdefs = function |> remove_pointless_goto in - let stack, _ = smt_instr_list (string_of_id function_id) ctx all_cdefs instrs in + let stack, _, _ = smt_instr_list (string_of_id function_id) ctx all_cdefs instrs in let query = smt_query ctx pragma.query in push_smt_defs stack [Assert (Fn ("not", [query]))]; @@ -2038,25 +2270,20 @@ let rec build_register_map rmap = function | [] -> rmap let compile env ast = - let cdefs = - let open Jib_compile in - let ctx = - initial_ctx - ~convert_typ:ctyp_of_typ - ~optimize_anf:(fun ctx aexp -> fold_aexp (unroll_foreach ctx) (c_literals ctx aexp)) - env - in + let cdefs, jib_ctx = + let module Jibc = Jib_compile.Make(SMT_config) in + let ctx = Jib_compile.(initial_ctx (add_special_functions env)) in let t = Profile.start () in - let cdefs, ctx = compile_ast { ctx with specialize_calls = true; ignore_64 = true; struct_value = true; use_real = true } ast in + let cdefs, ctx = Jibc.compile_ast ctx ast in Profile.finish "Compiling to Jib IR" t; - cdefs + cdefs, ctx in let cdefs = Jib_optimize.unique_per_function_ids cdefs in let rmap = build_register_map CTMap.empty cdefs in - cdefs, { (initial_ctx ()) with tc_env = env; register_map = rmap; ast = ast } + cdefs, jib_ctx, { (initial_ctx ()) with tc_env = jib_ctx.tc_env; register_map = rmap; ast = ast } let serialize_smt_model file env ast = - let cdefs, ctx = compile env ast in + let cdefs, _, ctx = compile env ast in let out_chan = open_out file in Marshal.to_channel out_chan cdefs []; Marshal.to_channel out_chan (Type_check.Env.set_prover None ctx.tc_env) []; @@ -2073,7 +2300,7 @@ let deserialize_smt_model file = let generate_smt props name_file env ast = try - let cdefs, ctx = compile env ast in + let cdefs, _, ctx = compile env ast in smt_cdefs props [] name_file ctx cdefs cdefs with | Type_check.Type_error (_, l, err) -> diff --git a/src/jib/jib_smt.mli b/src/jib/jib_smt.mli index cdaf7e39..616877e4 100644 --- a/src/jib/jib_smt.mli +++ b/src/jib/jib_smt.mli @@ -73,44 +73,57 @@ val opt_default_lbits_index : int ref val opt_default_vector_index : int ref type ctx = { - (** Arbitrary-precision bitvectors are represented as a (BitVec lbits_index, BitVec (2 ^ lbits_index)) pair. *) lbits_index : int; - (** The size we use for integers where we don't know how large they are statically. *) + (** Arbitrary-precision bitvectors are represented as a (BitVec lbits_index, BitVec (2 ^ lbits_index)) pair. *) lint_size : int; + (** The size we use for integers where we don't know how large they are statically. *) + vector_index : int; (** A generic vector, vector('a) becomes Array (BitVec vector_index) 'a. We need to take care that vector_index is large enough for all generic vectors. *) - vector_index : int; - (** A map from each ctyp to a list of registers of that ctyp *) register_map : id list CTMap.t; - (** A set to keep track of all the tuple sizes we need to generate types for *) + (** A map from each ctyp to a list of registers of that ctyp *) tuple_sizes : IntSet.t ref; - (** tc_env is the global type-checking environment *) + (** A set to keep track of all the tuple sizes we need to generate types for *) tc_env : Type_check.Env.t; + (** tc_env is the global type-checking environment *) + pragma_l : Ast.l; (** A location, usually the $counterexample or $property we are generating the SMT for. Used for error messages. *) - pragma_l : Ast.l; - (** Used internally to keep track of function argument names *) arg_stack : (int * string) Stack.t; - (** The fully type-checked ast *) + (** Used internally to keep track of function argument names *) ast : Type_check.tannot defs; + (** The fully type-checked ast *) + shared : ctyp Bindings.t; + (** Shared variables. These variables do not get renamed by + Smtlib.suffix_variables_def, and their SSA number is + omitted. They should therefore only ever be read and never + written. Used by sail-axiomatic for symbolic values in the + initial litmus state. *) + preserved : IdSet.t; + (** icopy instructions to an id in preserved will generated a + define-const (by using Smtlib.Preserved_const) that will not be + simplified away or renamed. It will also not get a SSA + number. Such variables can therefore only ever be written to + once, and never read. They are used by sail-axiomatic to + extract information from the generated SMT. *) + events : smt_exp Stack.t EventMap.t ref; (** For every event type we have a stack of boolean SMT expressions for each occurance of that event. See src/property.ml for the event types *) - events : smt_exp Stack.t EventMap.t ref; + node : int; + pathcond : smt_exp Lazy.t; (** When generating SMT for an instruction pathcond will contain the global path conditional of the containing block/node in the control flow graph *) - node : int; - pathcond : smt_exp Lazy.t; + use_string : bool ref; + use_real : bool ref (** Set if we need to use strings or real numbers in the generated SMT, which then requires set-logic ALL or similar depending on the solver *) - use_string : bool ref; - use_real : bool ref } (** Compile an AST into Jib suitable for SMT generation, and initialise a context. *) -val compile : Type_check.Env.t -> Type_check.tannot defs -> cdef list * ctx +val compile : Type_check.Env.t -> Type_check.tannot defs -> cdef list * Jib_compile.ctx * ctx (* TODO: Currently we internally use mutable stacks and queues to avoid any issues with stack overflows caused by some non @@ -122,7 +135,7 @@ val smt_header : ctx -> cdef list -> smt_def list val smt_query : ctx -> Property.query -> smt_exp -val smt_instr_list : string -> ctx -> cdef list -> instr list -> smt_def Stack.t * (ssa_elem list * cf_node) Jib_ssa.array_graph +val smt_instr_list : string -> ctx -> cdef list -> instr list -> smt_def Stack.t * int * (ssa_elem list * cf_node) Jib_ssa.array_graph module type Sequence = sig type 'a t diff --git a/src/jib/jib_smt_fuzz.ml b/src/jib/jib_smt_fuzz.ml index 846d0178..58665bde 100644 --- a/src/jib/jib_smt_fuzz.ml +++ b/src/jib/jib_smt_fuzz.ml @@ -152,13 +152,13 @@ let rec run frame = exception Skip_iteration of string;; let fuzz_cdef ctx all_cdefs = function - | CDEF_spec (id, arg_ctyps, ret_ctyp) when not (string_of_id id = "and_bool" || string_of_id id = "or_bool") -> + | CDEF_spec (id, _, arg_ctyps, ret_ctyp) when not (string_of_id id = "and_bool" || string_of_id id = "or_bool") -> let open Type_check in let open Interpreter in if Env.is_extern id ctx.tc_env "smt" then ( let extern = Env.get_extern id ctx.tc_env "smt" in let typq, (Typ_aux (aux, _) as typ) = Env.get_val_spec id ctx.tc_env in - let istate = initial_state ctx.ast ctx.tc_env Value.primops in + let istate = initial_state ctx.ast ctx.tc_env !Value.primops in let header = smt_header ctx all_cdefs in prerr_endline (Util.("Fuzz: " |> cyan |> clear) ^ string_of_id id ^ " = \"" ^ extern ^ "\" : " ^ string_of_typ typ); @@ -192,7 +192,7 @@ let fuzz_cdef ctx all_cdefs = function @ [iend ()] in let smt_defs = - try fst (smt_instr_list extern ctx all_cdefs jib) with + try (fun (x, _, _) -> x) (smt_instr_list extern ctx all_cdefs jib) with | _ -> raise (Skip_iteration ("SMT error for: " ^ Util.string_of_list ", " string_of_exp (List.map fst values))) in @@ -253,6 +253,6 @@ let fuzz_cdef ctx all_cdefs = function let fuzz seed env ast = Random.init seed; - let cdefs, ctx = compile env ast in + let cdefs, _, ctx = compile env ast in List.iter (fuzz_cdef ctx cdefs) cdefs diff --git a/src/jib/jib_ssa.ml b/src/jib/jib_ssa.ml index 9c405a48..fe3238a4 100644 --- a/src/jib/jib_ssa.ml +++ b/src/jib/jib_ssa.ml @@ -504,6 +504,7 @@ let rename_variables graph root children = | Name (id, _) -> Name (id, i) | Have_exception _ -> Have_exception i | Current_exception _ -> Current_exception i + | Throw_location _ -> Throw_location i | Return _ -> Return i in @@ -524,9 +525,6 @@ let rename_variables graph root children = | V_id (id, ctyp) -> let i = top_stack id in V_id (ssa_name i id, ctyp) - | V_ref (id, ctyp) -> - let i = top_stack id in - V_ref (ssa_name i id, ctyp) | V_lit (vl, ctyp) -> V_lit (vl, ctyp) | V_call (id, fs) -> V_call (id, List.map fold_cval fs) | V_field (f, field) -> V_field (fold_cval f, field) diff --git a/src/jib/jib_util.ml b/src/jib/jib_util.ml index 13438208..9b06c7be 100644 --- a/src/jib/jib_util.ml +++ b/src/jib/jib_util.ml @@ -83,7 +83,7 @@ let ireset ?loc:(l=Parse_ast.Unknown) ctyp id = let iinit ?loc:(l=Parse_ast.Unknown) ctyp id cval = I_aux (I_init (ctyp, id, cval), (instr_number (), l)) -let iif ?loc:(l=Parse_ast.Unknown) cval then_instrs else_instrs ctyp = +let iif l cval then_instrs else_instrs ctyp = I_aux (I_if (cval, then_instrs, else_instrs, ctyp), (instr_number (), l)) let ifuncall ?loc:(l=Parse_ast.Unknown) clexp id cvals = @@ -113,7 +113,7 @@ let iblock ?loc:(l=Parse_ast.Unknown) instrs = let itry_block ?loc:(l=Parse_ast.Unknown) instrs = I_aux (I_try_block instrs, (instr_number (), l)) -let ithrow ?loc:(l=Parse_ast.Unknown) cval = +let ithrow l cval = I_aux (I_throw cval, (instr_number (), l)) let icomment ?loc:(l=Parse_ast.Unknown) str = @@ -134,7 +134,7 @@ let imatch_failure ?loc:(l=Parse_ast.Unknown) () = let iraw ?loc:(l=Parse_ast.Unknown) str = I_aux (I_raw str, (instr_number (), l)) -let ijump ?loc:(l=Parse_ast.Unknown) cval label = +let ijump l cval label = I_aux (I_jump (cval, label), (instr_number (), l)) module Name = struct @@ -153,6 +153,8 @@ module Name = struct | _, Have_exception _ -> -1 | Current_exception _, _ -> 1 | _, Current_exception _ -> -1 + | Throw_location _, _ -> 1 + | _, Throw_location _ -> -1 end module NameSet = Set.Make(Name) @@ -160,6 +162,7 @@ module NameMap = Map.Make(Name) let current_exception = Current_exception (-1) let have_exception = Have_exception (-1) +let throw_location = Throw_location (-1) let return = Return (-1) let name id = Name (id, -1) @@ -167,8 +170,6 @@ let name id = Name (id, -1) let rec cval_rename from_id to_id = function | V_id (id, ctyp) when Name.compare id from_id = 0 -> V_id (to_id, ctyp) | V_id (id, ctyp) -> V_id (id, ctyp) - | V_ref (id, ctyp) when Name.compare id from_id = 0 -> V_ref (to_id, ctyp) - | V_ref (id, ctyp) -> V_ref (id, ctyp) | V_lit (vl, ctyp) -> V_lit (vl, ctyp) | V_call (call, cvals) -> V_call (call, List.map (cval_rename from_id to_id) cvals) | V_field (f, field) -> V_field (cval_rename from_id to_id f, field) @@ -257,8 +258,7 @@ let rec instr_rename from_id to_id (I_aux (instr, aux)) = (* 1. Instruction pretty printer *) (**************************************************************************) - -let string_of_name ?deref_current_exception:(dce=true) ?zencode:(zencode=true) = +let string_of_name ?deref_current_exception:(dce=false) ?zencode:(zencode=true) = let ssa_num n = if n = -1 then "" else ("/" ^ string_of_int n) in function | Name (id, n) -> @@ -271,6 +271,8 @@ let string_of_name ?deref_current_exception:(dce=true) ?zencode:(zencode=true) = "(*current_exception)" ^ ssa_num n | Current_exception n -> "current_exception" ^ ssa_num n + | Throw_location n -> + "throw_location" ^ ssa_num n let string_of_op = function | Bnot -> "@not" @@ -278,7 +280,6 @@ let string_of_op = function | Bor -> "@or" | List_hd -> "@hd" | List_tl -> "@tl" - | Bit_to_bool -> "@bit_to_bool" | Eq -> "@eq" | Neq -> "@neq" | Bvnot -> "@bvnot" @@ -309,9 +310,9 @@ let string_of_op = function let rec string_of_ctyp = function | CT_lint -> "%i" | CT_fint n -> "%i" ^ string_of_int n - | CT_lbits _ -> "%lb" - | CT_sbits (n, _) -> "%sb" ^ string_of_int n - | CT_fbits (n, _) -> "%fb" ^ string_of_int n + | CT_lbits _ -> "%bv" + | CT_sbits (n, _) -> "%sbv" ^ string_of_int n + | CT_fbits (n, _) -> "%bv" ^ string_of_int n | CT_constant n -> Big_int.to_string n | CT_bit -> "%bit" | CT_unit -> "%unit" @@ -323,6 +324,7 @@ let rec string_of_ctyp = function | CT_enum (id, _) -> "%enum " ^ Util.zencode_string (string_of_id id) | CT_variant (id, _) -> "%union " ^ Util.zencode_string (string_of_id id) | CT_vector (_, ctyp) -> "%vec(" ^ string_of_ctyp ctyp ^ ")" + | CT_fvector (n, _, ctyp) -> "%fvec(" ^ string_of_int n ^ ", " ^ string_of_ctyp ctyp ^ ")" | CT_list ctyp -> "%list(" ^ string_of_ctyp ctyp ^ ")" | CT_ref ctyp -> "&(" ^ string_of_ctyp ctyp ^ ")" | CT_poly -> "*" @@ -352,24 +354,27 @@ and full_string_of_ctyp = function | CT_ref ctyp -> "ref(" ^ full_string_of_ctyp ctyp ^ ")" | ctyp -> string_of_ctyp ctyp -let string_of_value = function - | VL_bits ([], _) -> "empty" +let rec string_of_value = function + | VL_bits ([], _) -> "UINT64_C(0)" | VL_bits (bs, true) -> Sail2_values.show_bitlist bs | VL_bits (bs, false) -> Sail2_values.show_bitlist (List.rev bs) | VL_int i -> Big_int.to_string i | VL_bool true -> "true" | VL_bool false -> "false" - | VL_null -> "NULL" | VL_unit -> "()" | VL_bit Sail2_values.B0 -> "bitzero" | VL_bit Sail2_values.B1 -> "bitone" - | VL_bit Sail2_values.BU -> "bitundef" + | VL_bit Sail2_values.BU -> failwith "Undefined bit found in value" | VL_real str -> str | VL_string str -> "\"" ^ str ^ "\"" + | VL_empty_list -> "NULL" + | VL_enum element -> Util.zencode_string element + | VL_ref r -> "&" ^ Util.zencode_string r + | VL_undefined -> "undefined" let rec string_of_cval = function | V_id (id, ctyp) -> string_of_name id - | V_ref (id, _) -> "&" ^ string_of_name id + | V_lit (VL_undefined, ctyp) -> string_of_value VL_undefined ^ " : " ^ string_of_ctyp ctyp | V_lit (vl, ctyp) -> string_of_value vl | V_call (op, cvals) -> Printf.sprintf "%s(%s)" (string_of_op op) (Util.string_of_list ", " string_of_cval cvals) @@ -377,16 +382,10 @@ let rec string_of_cval = function Printf.sprintf "%s.%s" (string_of_cval f) (string_of_uid field) | V_tuple_member (f, _, n) -> Printf.sprintf "%s.ztup%d" (string_of_cval f) n - | V_ctor_kind (f, ctor, [], _) -> - string_of_cval f ^ " is " ^ Util.zencode_string (string_of_id ctor) | V_ctor_kind (f, ctor, unifiers, _) -> - string_of_cval f ^ " is " ^ Util.zencode_string (string_of_id ctor ^ "_" ^ Util.string_of_list "_" string_of_ctyp unifiers) - | V_ctor_unwrap (ctor, f, [], _) -> - Printf.sprintf "%s as %s" (string_of_cval f) (string_of_id ctor) + string_of_cval f ^ " is " ^ string_of_uid (ctor, unifiers) | V_ctor_unwrap (ctor, f, unifiers, _) -> - Printf.sprintf "%s as %s" - (string_of_cval f) - (Util.zencode_string (string_of_id ctor ^ "_" ^ Util.string_of_list "_" string_of_ctyp unifiers)) + string_of_cval f ^ " as " ^ string_of_uid (ctor, unifiers) | V_struct (fields, _) -> Printf.sprintf "{%s}" (Util.string_of_list ", " (fun (field, cval) -> string_of_uid field ^ " = " ^ string_of_cval cval) fields) @@ -398,6 +397,7 @@ let rec map_ctyp f = function | CT_tup ctyps -> f (CT_tup (List.map (map_ctyp f) ctyps)) | CT_ref ctyp -> f (CT_ref (map_ctyp f ctyp)) | CT_vector (direction, ctyp) -> f (CT_vector (direction, map_ctyp f ctyp)) + | CT_fvector (n, direction, ctyp) -> f (CT_fvector (n, direction, map_ctyp f ctyp)) | CT_list ctyp -> f (CT_list (map_ctyp f ctyp)) | CT_struct (id, ctors) -> f (CT_struct (id, List.map (fun ((id, ctyps), ctyp) -> (id, List.map (map_ctyp f) ctyps), map_ctyp f ctyp) ctors)) @@ -423,6 +423,7 @@ let rec ctyp_equal ctyp1 ctyp2 = | CT_string, CT_string -> true | CT_real, CT_real -> true | CT_vector (d1, ctyp1), CT_vector (d2, ctyp2) -> d1 = d2 && ctyp_equal ctyp1 ctyp2 + | CT_fvector (n1, d1, ctyp1), CT_fvector (n2, d2, ctyp2) -> n1 = n2 && d1 = d2 && ctyp_equal ctyp1 ctyp2 | CT_list ctyp1, CT_list ctyp2 -> ctyp_equal ctyp1 ctyp2 | CT_ref ctyp1, CT_ref ctyp2 -> ctyp_equal ctyp1 ctyp2 | CT_poly, CT_poly -> true @@ -492,6 +493,11 @@ let rec ctyp_compare ctyp1 ctyp2 = | CT_vector _, _ -> 1 | _, CT_vector _ -> -1 + | CT_fvector (n1, d1, ctyp1), CT_fvector (n2, d2, ctyp2) -> + lex_ord (compare n1 n2) (lex_ord (ctyp_compare ctyp1 ctyp2) (compare d1 d2)) + | CT_fvector _, _ -> 1 + | _, CT_fvector _ -> -1 + | ctyp1, ctyp2 -> String.compare (full_string_of_ctyp ctyp1) (full_string_of_ctyp ctyp2) module CT = struct @@ -564,6 +570,7 @@ let rec ctyp_suprema = function | CT_struct (id, ctors) -> CT_struct (id, ctors) | CT_variant (id, ctors) -> CT_variant (id, ctors) | CT_vector (d, ctyp) -> CT_vector (d, ctyp_suprema ctyp) + | CT_fvector (n, d, ctyp) -> CT_fvector (n, d, ctyp_suprema ctyp) | CT_list ctyp -> CT_list (ctyp_suprema ctyp) | CT_ref ctyp -> CT_ref (ctyp_suprema ctyp) | CT_poly -> CT_poly @@ -573,7 +580,7 @@ let rec ctyp_ids = function | CT_struct (id, ctors) | CT_variant (id, ctors) -> IdSet.add id (List.fold_left (fun ids (_, ctyp) -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctors) | CT_tup ctyps -> List.fold_left (fun ids ctyp -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctyps - | CT_vector (_, ctyp) | CT_list ctyp | CT_ref ctyp -> ctyp_ids ctyp + | CT_vector (_, ctyp) | CT_fvector (_, _, ctyp) | CT_list ctyp | CT_ref ctyp -> ctyp_ids ctyp | CT_lint | CT_fint _ | CT_constant _ | CT_lbits _ | CT_fbits _ | CT_sbits _ | CT_unit | CT_bool | CT_real | CT_bit | CT_string | CT_poly -> IdSet.empty @@ -588,11 +595,11 @@ let rec is_polymorphic = function | CT_tup ctyps -> List.exists is_polymorphic ctyps | CT_enum _ -> false | CT_struct (_, ctors) | CT_variant (_, ctors) -> List.exists (fun (_, ctyp) -> is_polymorphic ctyp) ctors - | CT_vector (_, ctyp) | CT_list ctyp | CT_ref ctyp -> is_polymorphic ctyp + | CT_fvector (_, _, ctyp) | CT_vector (_, ctyp) | CT_list ctyp | CT_ref ctyp -> is_polymorphic ctyp | CT_poly -> true let rec cval_deps = function - | V_id (id, _) | V_ref (id, _) -> NameSet.singleton id + | V_id (id, _) -> NameSet.singleton id | V_lit _ -> NameSet.empty | V_field (cval, _) | V_poly (cval, _) | V_tuple_member (cval, _, _) -> cval_deps cval | V_call (_, cvals) -> List.fold_left NameSet.union NameSet.empty (List.map cval_deps cvals) @@ -666,7 +673,6 @@ let rec map_clexp_ctyp f = function let rec map_cval_ctyp f = function | V_id (id, ctyp) -> V_id (id, f ctyp) - | V_ref (id, ctyp) -> V_ref (id, f ctyp) | V_lit (vl, ctyp) -> V_lit (vl, f ctyp) | V_ctor_kind (cval, id, unifiers, ctyp) -> V_ctor_kind (map_cval_ctyp f cval, id, List.map f unifiers, f ctyp) @@ -734,7 +740,7 @@ let rec concatmap_instr f (I_aux (instr, aux)) = I_try_block (List.concat (List.map (concatmap_instr f) instrs)) in f (I_aux (instr, aux)) - + (** Iterate over each instruction within an instruction, bottom-up *) let rec iter_instr f (I_aux (instr, aux)) = match instr with @@ -754,7 +760,7 @@ let cdef_map_instr f = function | CDEF_fundef (id, heap_return, args, instrs) -> CDEF_fundef (id, heap_return, args, List.map (map_instr f) instrs) | CDEF_startup (id, instrs) -> CDEF_startup (id, List.map (map_instr f) instrs) | CDEF_finish (id, instrs) -> CDEF_finish (id, List.map (map_instr f) instrs) - | CDEF_spec (id, ctyps, ctyp) -> CDEF_spec (id, ctyps, ctyp) + | CDEF_spec (id, extern, ctyps, ctyp) -> CDEF_spec (id, extern, ctyps, ctyp) | CDEF_type tdef -> CDEF_type tdef (** Map over each instruction in a cdef using concatmap_instr *) @@ -769,7 +775,7 @@ let cdef_concatmap_instr f = function CDEF_startup (id, List.concat (List.map (concatmap_instr f) instrs)) | CDEF_finish (id, instrs) -> CDEF_finish (id, List.concat (List.map (concatmap_instr f) instrs)) - | CDEF_spec (id, ctyps, ctyp) -> CDEF_spec (id, ctyps, ctyp) + | CDEF_spec (id, extern, ctyps, ctyp) -> CDEF_spec (id, extern, ctyps, ctyp) | CDEF_type tdef -> CDEF_type tdef let ctype_def_map_ctyp f = function @@ -784,7 +790,7 @@ let cdef_map_ctyp f = function | CDEF_fundef (id, heap_return, args, instrs) -> CDEF_fundef (id, heap_return, args, List.map (map_instr_ctyp f) instrs) | CDEF_startup (id, instrs) -> CDEF_startup (id, List.map (map_instr_ctyp f) instrs) | CDEF_finish (id, instrs) -> CDEF_finish (id, List.map (map_instr_ctyp f) instrs) - | CDEF_spec (id, ctyps, ctyp) -> CDEF_spec (id, List.map f ctyps, f ctyp) + | CDEF_spec (id, extern, ctyps, ctyp) -> CDEF_spec (id, extern, List.map f ctyps, f ctyp) | CDEF_type tdef -> CDEF_type (ctype_def_map_ctyp f tdef) (* Map over all sequences of instructions contained within an instruction *) @@ -838,7 +844,6 @@ let label str = let rec infer_call op vs = match op, vs with - | Bit_to_bool, _ -> CT_bool | Bnot, _ -> CT_bool | Band, _ -> CT_bool | Bor, _ -> CT_bool @@ -900,7 +905,6 @@ let rec infer_call op vs = and cval_ctyp = function | V_id (_, ctyp) -> ctyp - | V_ref (_, ctyp) -> CT_ref ctyp | V_lit (vl, ctyp) -> ctyp | V_ctor_kind _ -> CT_bool | V_ctor_unwrap (ctor, cval, unifiers, ctyp) -> ctyp @@ -984,7 +988,7 @@ let ctype_def_ctyps = function let cdef_ctyps = function | CDEF_reg_dec (_, ctyp, instrs) -> CTSet.add ctyp (instrs_ctyps instrs) - | CDEF_spec (_, ctyps, ctyp) -> + | CDEF_spec (_, _, ctyps, ctyp) -> CTSet.add ctyp (List.fold_left (fun m ctyp -> CTSet.add ctyp m) CTSet.empty ctyps) | CDEF_fundef (_, _, _, instrs) | CDEF_startup (_, instrs) | CDEF_finish (_, instrs) -> instrs_ctyps instrs diff --git a/src/libsail.mllib b/src/libsail.mllib index 2d1f568f..f05809bb 100644 --- a/src/libsail.mllib +++ b/src/libsail.mllib @@ -14,13 +14,14 @@ Graph Initial_check Interactive Interpreter -Isail Jib Jib_compile Jib_optimize Jib_ssa Jib_smt Jib_util +Jib_interactive +Jib_ir Latex Lexer Manifest @@ -32,11 +33,6 @@ Parse_ast Parser Parser_combinators Pattern_completeness -PPrint -PPrintCombinators -PPrintEngine -PPrintRenderer -PPrintOCaml Pretty_print Pretty_print_common Pretty_print_coq @@ -48,7 +44,6 @@ Property Reporting Rewriter Rewrites -Sail Sail2_values Sail_lib Scattered diff --git a/src/monomorphise.ml b/src/monomorphise.ml index 5168d16a..e328cce1 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -219,7 +219,7 @@ let rec contains_exist (Typ_aux (ty,l)) = | Typ_var _ -> false | Typ_fn (t1,t2,_) -> List.exists contains_exist t1 || contains_exist t2 - | Typ_bidir (t1, t2) -> contains_exist t1 || contains_exist t2 + | Typ_bidir (t1, t2, _) -> contains_exist t1 || contains_exist t2 | Typ_tup ts -> List.exists contains_exist ts | Typ_app (_,args) -> List.exists contains_exist_arg args | Typ_exist _ -> true @@ -252,12 +252,11 @@ let rec size_nvars_nexp (Nexp_aux (ne,_)) = let split_src_type all_errors env id ty (TypQ_aux (q,ql)) = let cannot l msg default = let open Reporting in - let error = Err_general (l, msg) in match all_errors with - | None -> raise (Fatal_error error) + | None -> raise (err_general l msg) | Some flag -> begin flag := false; - print_error error; + print_err l "Error" msg; default end in @@ -659,14 +658,12 @@ let split_defs target all_errors splits env defs = let renew_id (Id_aux (id,l)) = Id_aux (id,new_l) in let cannot msg = let open Reporting in - let error = - Err_general (pat_l, - ("Cannot split type " ^ string_of_typ typ ^ " for variable " ^ v ^ ": " ^ msg)) - in if all_errors + let error_msg = "Cannot split type " ^ string_of_typ typ ^ " for variable " ^ v ^ ": " ^ msg in + if all_errors then (no_errors_happened := false; - print_error error; + print_err pat_l "" error_msg; [P_aux (P_id var,(pat_l,annot)),[],[],KBindings.empty]) - else raise (Fatal_error error) + else raise (err_general pat_l error_msg) in match ty with | Typ_id (Id_aux (Id "bool",_)) | Typ_app (Id_aux (Id "atom_bool", _), [_]) -> @@ -951,13 +948,11 @@ let split_defs target all_errors splits env defs = let size = List.length lst in if size > size_set_limit then let open Reporting in - let error = - Err_general (l, "Case split is too large (" ^ string_of_int size ^ - " > limit " ^ string_of_int size_set_limit ^ ")") - in if all_errors - then (no_errors_happened := false; - print_error error; false) - else raise (Fatal_error error) + let error_msg = "Case split is too large (" ^ string_of_int size ^ " > limit " ^ string_of_int size_set_limit ^ ")" in + if all_errors + then (no_errors_happened := false; + print_err l "" error_msg; false) + else raise (err_general l error_msg) else true in @@ -1927,9 +1922,7 @@ let refine_dependency env (E_aux (e,(l,annot)) as exp) pexps = with | Some pats -> if l = Parse_ast.Unknown then - (Reporting.print_error - (Reporting.Err_general - (l, "No location for pattern match: " ^ string_of_exp exp)); + (Reporting.print_err l "" ("No location for pattern match: " ^ string_of_exp exp); None) else Some (Have (ArgSplits.singleton (id,loc) (Partial (pats,l)), @@ -3270,15 +3263,15 @@ let ids_in_exp exp = lEXP_cast = (fun (_,id) -> IdSet.singleton id) } exp -let make_bitvector_env_casts env quant_kids (kid,i) exp = - let mk_cast var typ exp = (make_bitvector_cast_let "bitvector_cast_in" env env quant_kids typ (subst_kids_typ (KBindings.singleton kid (nconstant i)) typ)) var exp in +let make_bitvector_env_casts top_env env quant_kids insts exp = + let mk_cast var typ exp = (make_bitvector_cast_let "bitvector_cast_in" env top_env quant_kids typ (subst_kids_typ insts typ)) var exp in let mk_assign_in var typ = - make_bitvector_cast_assign "bitvector_cast_in" env env quant_kids typ - (subst_kids_typ (KBindings.singleton kid (nconstant i)) typ) var + make_bitvector_cast_assign "bitvector_cast_in" env top_env quant_kids typ + (subst_kids_typ insts typ) var in let mk_assign_out var typ = - make_bitvector_cast_assign "bitvector_cast_out" env env quant_kids - (subst_kids_typ (KBindings.singleton kid (nconstant i)) typ) typ var + make_bitvector_cast_assign "bitvector_cast_out" top_env env quant_kids + (subst_kids_typ insts typ) typ var in let locals = Env.get_locals env in let used_ids = ids_in_exp exp in @@ -3412,13 +3405,13 @@ let add_bitvector_casts (Defs defs) = (* We used to just substitute kid, but fill_in_type also catches other kids defined by it *) let src_typ = fill_in_type (Env.add_constraint (nc_eq (nvar kid) (nconstant i)) env) result_typ in make_bitvector_cast_exp "bitvector_cast_out" env quant_kids src_typ result_typ - (make_bitvector_env_casts env quant_kids (kid,i) body) + (make_bitvector_env_casts env (env_of body) quant_kids (KBindings.singleton kid (nconstant i)) body) | P_aux (P_id var,_), Some guard -> (match extract_value_from_guard var guard with | Some i -> let src_typ = fill_in_type (Env.add_constraint (nc_eq (nvar kid) (nconstant i)) env) result_typ in make_bitvector_cast_exp "bitvector_cast_out" env quant_kids src_typ result_typ - (make_bitvector_env_casts env quant_kids (kid,i) body) + (make_bitvector_env_casts env (env_of body) quant_kids (KBindings.singleton kid (nconstant i)) body) | None -> body) | _ -> body @@ -3432,10 +3425,9 @@ let add_bitvector_casts (Defs defs) = let env = env_of_annot ann in let result_typ = Env.base_typ_of env (typ_of_annot ann) in let insts = extract e1 in - let e2' = List.fold_left (fun body inst -> - make_bitvector_env_casts env quant_kids inst body) e2 insts in let insts = List.fold_left (fun insts (kid,i) -> KBindings.add kid (nconstant i) insts) KBindings.empty insts in + let e2' = make_bitvector_env_casts env (env_of e2) quant_kids insts e2 in let src_typ = subst_kids_typ insts result_typ in let e2' = make_bitvector_cast_exp "bitvector_cast_out" env quant_kids src_typ result_typ e2' in (* Ask the type checker if only one value remains for any of kids in @@ -3444,13 +3436,10 @@ let add_bitvector_casts (Defs defs) = let insts3 = KBindings.fold (fun kid _ i3 -> match Type_check.solve_unique env3 (nvar kid) with | None -> i3 - | Some c -> (kid, c)::i3) - insts [] + | Some c -> KBindings.add kid (nconstant c) i3) + insts KBindings.empty in - let e3' = List.fold_left (fun body inst -> - make_bitvector_env_casts env quant_kids inst body) e3 insts3 in - let insts3 = List.fold_left (fun insts (kid,i) -> - KBindings.add kid (nconstant i) insts) KBindings.empty insts3 in + let e3' = make_bitvector_env_casts env (env_of e3) quant_kids insts3 e3 in let src_typ3 = subst_kids_typ insts3 result_typ in let e3' = make_bitvector_cast_exp "bitvector_cast_out" env quant_kids src_typ3 result_typ e3' in E_aux (E_if (e1,e2',e3'), ann) @@ -3469,10 +3458,9 @@ let add_bitvector_casts (Defs defs) = let t' = aux t in let et = E_aux (E_block t',ann) in let env = env_of h in - let et = List.fold_left (fun body inst -> - make_bitvector_env_casts env quant_kids inst body) et insts in let insts = List.fold_left (fun insts (kid,i) -> KBindings.add kid (nconstant i) insts) KBindings.empty insts in + let et = make_bitvector_env_casts env (env_of et) quant_kids insts et in let src_typ = subst_kids_typ insts result_typ in let et = make_bitvector_cast_exp "bitvector_cast_out" env quant_kids src_typ result_typ et in @@ -3542,10 +3530,10 @@ let replace_nexp_in_typ env typ orig new_nexp = let f1 = List.exists fst arg' in let f2, res = aux res in f1 || f2, Typ_aux (Typ_fn (List.map snd arg', res, eff),l) - | Typ_bidir (t1, t2) -> + | Typ_bidir (t1, t2, eff) -> let f1, t1 = aux t1 in let f2, t2 = aux t2 in - f1 || f2, Typ_aux (Typ_bidir (t1, t2), l) + f1 || f2, Typ_aux (Typ_bidir (t1, t2, eff), l) | Typ_tup typs -> let fs, typs = List.split (List.map aux typs) in List.exists (fun x -> x) fs, Typ_aux (Typ_tup typs,l) diff --git a/src/myocamlbuild.ml b/src/myocamlbuild.ml index ae45857d..1949d66a 100644 --- a/src/myocamlbuild.ml +++ b/src/myocamlbuild.ml @@ -82,7 +82,6 @@ dispatch begin function (* Bisect_ppx_plugin.handle_coverage (); *) (* ocaml_lib "lem_interp/interp"; *) - ocaml_lib ~extern:false ~dir:"pprint/src" ~tag_name:"use_pprint" "pprint/src/PPrintLib"; rule "lem -> ml" ~prod: "%.ml" diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index 8899695f..98a43ebc 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -118,7 +118,7 @@ let rec ocaml_string_typ (Typ_aux (typ_aux, l)) arg = parens (separate space [string "fun"; parens (separate (comma ^^ space) args); string "->"; body]) ^^ space ^^ arg | Typ_fn (typ1, typ2, _) -> string "\"FN\"" - | Typ_bidir (t1, t2) -> string "\"BIDIR\"" + | Typ_bidir (t1, t2, _) -> string "\"BIDIR\"" | Typ_var kid -> string "\"VAR\"" | Typ_exist _ -> assert false | Typ_internal_unknown -> raise (Reporting.err_unreachable l __POS__ "escaped Typ_internal_unknown") @@ -144,7 +144,7 @@ let rec ocaml_typ ctx (Typ_aux (typ_aux, l)) = | Typ_app (id, typs) -> parens (separate_map (string ", ") (ocaml_typ_arg ctx) typs) ^^ space ^^ ocaml_typ_id ctx id | Typ_tup typs -> parens (separate_map (string " * ") (ocaml_typ ctx) typs) | Typ_fn (typs, typ, _) -> separate space [ocaml_typ ctx (Typ_aux (Typ_tup typs, l)); string "->"; ocaml_typ ctx typ] - | Typ_bidir (t1, t2) -> raise (Reporting.err_general l "Ocaml doesn't support bidir types") + | Typ_bidir _ -> raise (Reporting.err_general l "Ocaml doesn't support bidir types") | Typ_var kid -> zencode_kid kid | Typ_exist _ -> assert false | Typ_internal_unknown -> raise (Reporting.err_unreachable l __POS__ "escaped Typ_internal_unknown") diff --git a/src/parse_ast.ml b/src/parse_ast.ml index 3147b7f4..6cb3f84d 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -154,12 +154,12 @@ atyp_aux = (* expressions of all kinds, to be translated to types, nats, orders | ATyp_minus of atyp * atyp (* subtraction *) | ATyp_exp of atyp (* exponential *) | ATyp_neg of atyp (* Internal (but not M as I want a datatype constructor) negative nexp *) - | ATyp_inc (* increasing (little-endian) *) - | ATyp_dec (* decreasing (big-endian) *) + | ATyp_inc (* increasing *) + | ATyp_dec (* decreasing *) | ATyp_default_ord (* default order for increasing or decreasing signficant bits *) | ATyp_set of (base_effect) list (* effect set *) - | ATyp_fn of atyp * atyp * atyp (* Function type (first-order only in user code), last atyp is an effect *) - | ATyp_bidir of atyp * atyp (* Function type (first-order only in user code), last atyp is an effect *) + | ATyp_fn of atyp * atyp * atyp (* Function type, last atyp is an effect *) + | ATyp_bidir of atyp * atyp * atyp (* Mapping type, last atyp is an effect *) | ATyp_wild | ATyp_tup of (atyp) list (* Tuple type *) | ATyp_app of id * (atyp) list (* type constructor application *) diff --git a/src/parser.mly b/src/parser.mly index 0b09468c..6a579b7a 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -657,9 +657,13 @@ typschm: | Forall typquant Dot typ MinusGt typ Effect effect_set { (fun s e -> mk_typschm $2 (mk_typ (ATyp_fn ($4, $6, $8)) s e) s e) $startpos $endpos } | typ Bidir typ - { (fun s e -> mk_typschm mk_typqn (mk_typ (ATyp_bidir ($1, $3)) s e) s e) $startpos $endpos } + { (fun s e -> mk_typschm mk_typqn (mk_typ (ATyp_bidir ($1, $3, mk_typ (ATyp_set []) s e)) s e) s e) $startpos $endpos } | Forall typquant Dot typ Bidir typ - { (fun s e -> mk_typschm $2 (mk_typ (ATyp_bidir ($4, $6)) s e) s e) $startpos $endpos } + { (fun s e -> mk_typschm $2 (mk_typ (ATyp_bidir ($4, $6, mk_typ (ATyp_set []) s e)) s e) s e) $startpos $endpos } + | typ Bidir typ Effect effect_set + { (fun s e -> mk_typschm mk_typqn (mk_typ (ATyp_bidir ($1, $3, $5)) s e) s e) $startpos $endpos } + | Forall typquant Dot typ Bidir typ Effect effect_set + { (fun s e -> mk_typschm $2 (mk_typ (ATyp_bidir ($4, $6, $8)) s e) s e) $startpos $endpos } typschm_eof: | typschm Eof diff --git a/src/pprint/AUTHORS b/src/pprint/AUTHORS deleted file mode 100644 index 6060ac93..00000000 --- a/src/pprint/AUTHORS +++ /dev/null @@ -1,3 +0,0 @@ -PPrint was written by François Pottier and Nicolas Pouillard, with -contributions by Yann Régis-Gianas, Gabriel Scherer, and Jonathan -Protzenko. diff --git a/src/pprint/CHANGES b/src/pprint/CHANGES deleted file mode 100644 index 69747a41..00000000 --- a/src/pprint/CHANGES +++ /dev/null @@ -1,27 +0,0 @@ -2014/04/11 -Changed the behavior of [align], which was not consistent with its documentation. -[align] now sets the indentation level to the current column. In particular, this -means that [align (align d)] is equivalent to [align d], which was not the case -previously. Thanks to Dmitry Grebeniuk for reporting this issue. - -2014/04/03 -The library is now extensible (in principle). A [custom] document constructor -allows the user to define her own documents, as long as they fit the manner -in which the current rendering engine works. - -The [compact] rendering engine is now tail-recursive too. - -2014/03/21 -Minor optimisation in the smart constructor [group]. - -2014/03/13 -New (simpler) pretty-printing engine. The representation of documents in -memory is slightly larger; document construction is perhaps slightly slower, -while rendering is significantly faster. (Construction dominates rendering.) -The rendering speed is now guaranteed to be independent of the width -parameter. The price to pay for this simplification is that the primitive -document constructors [column] and [nesting] are no longer supported. The -API is otherwise unchanged. - -2013/01/31 -First official release of PPrint. diff --git a/src/pprint/LICENSE b/src/pprint/LICENSE deleted file mode 100644 index d6eb151e..00000000 --- a/src/pprint/LICENSE +++ /dev/null @@ -1,517 +0,0 @@ - -CeCILL-C FREE SOFTWARE LICENSE AGREEMENT - - - Notice - -This Agreement is a Free Software license agreement that is the result -of discussions between its authors in order to ensure compliance with -the two main principles guiding its drafting: - - * firstly, compliance with the principles governing the distribution - of Free Software: access to source code, broad rights granted to - users, - * secondly, the election of a governing law, French law, with which - it is conformant, both as regards the law of torts and - intellectual property law, and the protection that it offers to - both authors and holders of the economic rights over software. - -The authors of the CeCILL-C (for Ce[a] C[nrs] I[nria] L[ogiciel] L[ibre]) -license are: - -Commissariat à l'Energie Atomique - CEA, a public scientific, technical -and industrial research establishment, having its principal place of -business at 25 rue Leblanc, immeuble Le Ponant D, 75015 Paris, France. - -Centre National de la Recherche Scientifique - CNRS, a public scientific -and technological establishment, having its principal place of business -at 3 rue Michel-Ange, 75794 Paris cedex 16, France. - -Institut National de Recherche en Informatique et en Automatique - -INRIA, a public scientific and technological establishment, having its -principal place of business at Domaine de Voluceau, Rocquencourt, BP -105, 78153 Le Chesnay cedex, France. - - - Preamble - -The purpose of this Free Software license agreement is to grant users -the right to modify and re-use the software governed by this license. - -The exercising of this right is conditional upon the obligation to make -available to the community the modifications made to the source code of -the software so as to contribute to its evolution. - -In consideration of access to the source code and the rights to copy, -modify and redistribute granted by the license, users are provided only -with a limited warranty and the software's author, the holder of the -economic rights, and the successive licensors only have limited liability. - -In this respect, the risks associated with loading, using, modifying -and/or developing or reproducing the software by the user are brought to -the user's attention, given its Free Software status, which may make it -complicated to use, with the result that its use is reserved for -developers and experienced professionals having in-depth computer -knowledge. Users are therefore encouraged to load and test the -suitability of the software as regards their requirements in conditions -enabling the security of their systems and/or data to be ensured and, -more generally, to use and operate it in the same conditions of -security. This Agreement may be freely reproduced and published, -provided it is not altered, and that no provisions are either added or -removed herefrom. - -This Agreement may apply to any or all software for which the holder of -the economic rights decides to submit the use thereof to its provisions. - - - Article 1 - DEFINITIONS - -For the purpose of this Agreement, when the following expressions -commence with a capital letter, they shall have the following meaning: - -Agreement: means this license agreement, and its possible subsequent -versions and annexes. - -Software: means the software in its Object Code and/or Source Code form -and, where applicable, its documentation, "as is" when the Licensee -accepts the Agreement. - -Initial Software: means the Software in its Source Code and possibly its -Object Code form and, where applicable, its documentation, "as is" when -it is first distributed under the terms and conditions of the Agreement. - -Modified Software: means the Software modified by at least one -Integrated Contribution. - -Source Code: means all the Software's instructions and program lines to -which access is required so as to modify the Software. - -Object Code: means the binary files originating from the compilation of -the Source Code. - -Holder: means the holder(s) of the economic rights over the Initial -Software. - -Licensee: means the Software user(s) having accepted the Agreement. - -Contributor: means a Licensee having made at least one Integrated -Contribution. - -Licensor: means the Holder, or any other individual or legal entity, who -distributes the Software under the Agreement. - -Integrated Contribution: means any or all modifications, corrections, -translations, adaptations and/or new functions integrated into the -Source Code by any or all Contributors. - -Related Module: means a set of sources files including their -documentation that, without modification to the Source Code, enables -supplementary functions or services in addition to those offered by the -Software. - -Derivative Software: means any combination of the Software, modified or -not, and of a Related Module. - -Parties: mean both the Licensee and the Licensor. - -These expressions may be used both in singular and plural form. - - - Article 2 - PURPOSE - -The purpose of the Agreement is the grant by the Licensor to the -Licensee of a non-exclusive, transferable and worldwide license for the -Software as set forth in Article 5 hereinafter for the whole term of the -protection granted by the rights over said Software. - - - Article 3 - ACCEPTANCE - -3.1 The Licensee shall be deemed as having accepted the terms and -conditions of this Agreement upon the occurrence of the first of the -following events: - - * (i) loading the Software by any or all means, notably, by - downloading from a remote server, or by loading from a physical - medium; - * (ii) the first time the Licensee exercises any of the rights - granted hereunder. - -3.2 One copy of the Agreement, containing a notice relating to the -characteristics of the Software, to the limited warranty, and to the -fact that its use is restricted to experienced users has been provided -to the Licensee prior to its acceptance as set forth in Article 3.1 -hereinabove, and the Licensee hereby acknowledges that it has read and -understood it. - - - Article 4 - EFFECTIVE DATE AND TERM - - - 4.1 EFFECTIVE DATE - -The Agreement shall become effective on the date when it is accepted by -the Licensee as set forth in Article 3.1. - - - 4.2 TERM - -The Agreement shall remain in force for the entire legal term of -protection of the economic rights over the Software. - - - Article 5 - SCOPE OF RIGHTS GRANTED - -The Licensor hereby grants to the Licensee, who accepts, the following -rights over the Software for any or all use, and for the term of the -Agreement, on the basis of the terms and conditions set forth hereinafter. - -Besides, if the Licensor owns or comes to own one or more patents -protecting all or part of the functions of the Software or of its -components, the Licensor undertakes not to enforce the rights granted by -these patents against successive Licensees using, exploiting or -modifying the Software. If these patents are transferred, the Licensor -undertakes to have the transferees subscribe to the obligations set -forth in this paragraph. - - - 5.1 RIGHT OF USE - -The Licensee is authorized to use the Software, without any limitation -as to its fields of application, with it being hereinafter specified -that this comprises: - - 1. permanent or temporary reproduction of all or part of the Software - by any or all means and in any or all form. - - 2. loading, displaying, running, or storing the Software on any or - all medium. - - 3. entitlement to observe, study or test its operation so as to - determine the ideas and principles behind any or all constituent - elements of said Software. This shall apply when the Licensee - carries out any or all loading, displaying, running, transmission - or storage operation as regards the Software, that it is entitled - to carry out hereunder. - - - 5.2 RIGHT OF MODIFICATION - -The right of modification includes the right to translate, adapt, -arrange, or make any or all modifications to the Software, and the right -to reproduce the resulting software. It includes, in particular, the -right to create a Derivative Software. - -The Licensee is authorized to make any or all modification to the -Software provided that it includes an explicit notice that it is the -author of said modification and indicates the date of the creation thereof. - - - 5.3 RIGHT OF DISTRIBUTION - -In particular, the right of distribution includes the right to publish, -transmit and communicate the Software to the general public on any or -all medium, and by any or all means, and the right to market, either in -consideration of a fee, or free of charge, one or more copies of the -Software by any means. - -The Licensee is further authorized to distribute copies of the modified -or unmodified Software to third parties according to the terms and -conditions set forth hereinafter. - - - 5.3.1 DISTRIBUTION OF SOFTWARE WITHOUT MODIFICATION - -The Licensee is authorized to distribute true copies of the Software in -Source Code or Object Code form, provided that said distribution -complies with all the provisions of the Agreement and is accompanied by: - - 1. a copy of the Agreement, - - 2. a notice relating to the limitation of both the Licensor's - warranty and liability as set forth in Articles 8 and 9, - -and that, in the event that only the Object Code of the Software is -redistributed, the Licensee allows effective access to the full Source -Code of the Software at a minimum during the entire period of its -distribution of the Software, it being understood that the additional -cost of acquiring the Source Code shall not exceed the cost of -transferring the data. - - - 5.3.2 DISTRIBUTION OF MODIFIED SOFTWARE - -When the Licensee makes an Integrated Contribution to the Software, the -terms and conditions for the distribution of the resulting Modified -Software become subject to all the provisions of this Agreement. - -The Licensee is authorized to distribute the Modified Software, in -source code or object code form, provided that said distribution -complies with all the provisions of the Agreement and is accompanied by: - - 1. a copy of the Agreement, - - 2. a notice relating to the limitation of both the Licensor's - warranty and liability as set forth in Articles 8 and 9, - -and that, in the event that only the object code of the Modified -Software is redistributed, the Licensee allows effective access to the -full source code of the Modified Software at a minimum during the entire -period of its distribution of the Modified Software, it being understood -that the additional cost of acquiring the source code shall not exceed -the cost of transferring the data. - - - 5.3.3 DISTRIBUTION OF DERIVATIVE SOFTWARE - -When the Licensee creates Derivative Software, this Derivative Software -may be distributed under a license agreement other than this Agreement, -subject to compliance with the requirement to include a notice -concerning the rights over the Software as defined in Article 6.4. -In the event the creation of the Derivative Software required modification -of the Source Code, the Licensee undertakes that: - - 1. the resulting Modified Software will be governed by this Agreement, - 2. the Integrated Contributions in the resulting Modified Software - will be clearly identified and documented, - 3. the Licensee will allow effective access to the source code of the - Modified Software, at a minimum during the entire period of - distribution of the Derivative Software, such that such - modifications may be carried over in a subsequent version of the - Software; it being understood that the additional cost of - purchasing the source code of the Modified Software shall not - exceed the cost of transferring the data. - - - 5.3.4 COMPATIBILITY WITH THE CeCILL LICENSE - -When a Modified Software contains an Integrated Contribution subject to -the CeCILL license agreement, or when a Derivative Software contains a -Related Module subject to the CeCILL license agreement, the provisions -set forth in the third item of Article 6.4 are optional. - - - Article 6 - INTELLECTUAL PROPERTY - - - 6.1 OVER THE INITIAL SOFTWARE - -The Holder owns the economic rights over the Initial Software. Any or -all use of the Initial Software is subject to compliance with the terms -and conditions under which the Holder has elected to distribute its work -and no one shall be entitled to modify the terms and conditions for the -distribution of said Initial Software. - -The Holder undertakes that the Initial Software will remain ruled at -least by this Agreement, for the duration set forth in Article 4.2. - - - 6.2 OVER THE INTEGRATED CONTRIBUTIONS - -The Licensee who develops an Integrated Contribution is the owner of the -intellectual property rights over this Contribution as defined by -applicable law. - - - 6.3 OVER THE RELATED MODULES - -The Licensee who develops a Related Module is the owner of the -intellectual property rights over this Related Module as defined by -applicable law and is free to choose the type of agreement that shall -govern its distribution under the conditions defined in Article 5.3.3. - - - 6.4 NOTICE OF RIGHTS - -The Licensee expressly undertakes: - - 1. not to remove, or modify, in any manner, the intellectual property - notices attached to the Software; - - 2. to reproduce said notices, in an identical manner, in the copies - of the Software modified or not; - - 3. to ensure that use of the Software, its intellectual property - notices and the fact that it is governed by the Agreement is - indicated in a text that is easily accessible, specifically from - the interface of any Derivative Software. - -The Licensee undertakes not to directly or indirectly infringe the -intellectual property rights of the Holder and/or Contributors on the -Software and to take, where applicable, vis-à -vis its staff, any and all -measures required to ensure respect of said intellectual property rights -of the Holder and/or Contributors. - - - Article 7 - RELATED SERVICES - -7.1 Under no circumstances shall the Agreement oblige the Licensor to -provide technical assistance or maintenance services for the Software. - -However, the Licensor is entitled to offer this type of services. The -terms and conditions of such technical assistance, and/or such -maintenance, shall be set forth in a separate instrument. Only the -Licensor offering said maintenance and/or technical assistance services -shall incur liability therefor. - -7.2 Similarly, any Licensor is entitled to offer to its licensees, under -its sole responsibility, a warranty, that shall only be binding upon -itself, for the redistribution of the Software and/or the Modified -Software, under terms and conditions that it is free to decide. Said -warranty, and the financial terms and conditions of its application, -shall be subject of a separate instrument executed between the Licensor -and the Licensee. - - - Article 8 - LIABILITY - -8.1 Subject to the provisions of Article 8.2, the Licensee shall be -entitled to claim compensation for any direct loss it may have suffered -from the Software as a result of a fault on the part of the relevant -Licensor, subject to providing evidence thereof. - -8.2 The Licensor's liability is limited to the commitments made under -this Agreement and shall not be incurred as a result of in particular: -(i) loss due the Licensee's total or partial failure to fulfill its -obligations, (ii) direct or consequential loss that is suffered by the -Licensee due to the use or performance of the Software, and (iii) more -generally, any consequential loss. In particular the Parties expressly -agree that any or all pecuniary or business loss (i.e. loss of data, -loss of profits, operating loss, loss of customers or orders, -opportunity cost, any disturbance to business activities) or any or all -legal proceedings instituted against the Licensee by a third party, -shall constitute consequential loss and shall not provide entitlement to -any or all compensation from the Licensor. - - - Article 9 - WARRANTY - -9.1 The Licensee acknowledges that the scientific and technical -state-of-the-art when the Software was distributed did not enable all -possible uses to be tested and verified, nor for the presence of -possible defects to be detected. In this respect, the Licensee's -attention has been drawn to the risks associated with loading, using, -modifying and/or developing and reproducing the Software which are -reserved for experienced users. - -The Licensee shall be responsible for verifying, by any or all means, -the suitability of the product for its requirements, its good working -order, and for ensuring that it shall not cause damage to either persons -or properties. - -9.2 The Licensor hereby represents, in good faith, that it is entitled -to grant all the rights over the Software (including in particular the -rights set forth in Article 5). - -9.3 The Licensee acknowledges that the Software is supplied "as is" by -the Licensor without any other express or tacit warranty, other than -that provided for in Article 9.2 and, in particular, without any warranty -as to its commercial value, its secured, safe, innovative or relevant -nature. - -Specifically, the Licensor does not warrant that the Software is free -from any error, that it will operate without interruption, that it will -be compatible with the Licensee's own equipment and software -configuration, nor that it will meet the Licensee's requirements. - -9.4 The Licensor does not either expressly or tacitly warrant that the -Software does not infringe any third party intellectual property right -relating to a patent, software or any other property right. Therefore, -the Licensor disclaims any and all liability towards the Licensee -arising out of any or all proceedings for infringement that may be -instituted in respect of the use, modification and redistribution of the -Software. Nevertheless, should such proceedings be instituted against -the Licensee, the Licensor shall provide it with technical and legal -assistance for its defense. Such technical and legal assistance shall be -decided on a case-by-case basis between the relevant Licensor and the -Licensee pursuant to a memorandum of understanding. The Licensor -disclaims any and all liability as regards the Licensee's use of the -name of the Software. No warranty is given as regards the existence of -prior rights over the name of the Software or as regards the existence -of a trademark. - - - Article 10 - TERMINATION - -10.1 In the event of a breach by the Licensee of its obligations -hereunder, the Licensor may automatically terminate this Agreement -thirty (30) days after notice has been sent to the Licensee and has -remained ineffective. - -10.2 A Licensee whose Agreement is terminated shall no longer be -authorized to use, modify or distribute the Software. However, any -licenses that it may have granted prior to termination of the Agreement -shall remain valid subject to their having been granted in compliance -with the terms and conditions hereof. - - - Article 11 - MISCELLANEOUS - - - 11.1 EXCUSABLE EVENTS - -Neither Party shall be liable for any or all delay, or failure to -perform the Agreement, that may be attributable to an event of force -majeure, an act of God or an outside cause, such as defective -functioning or interruptions of the electricity or telecommunications -networks, network paralysis following a virus attack, intervention by -government authorities, natural disasters, water damage, earthquakes, -fire, explosions, strikes and labor unrest, war, etc. - -11.2 Any failure by either Party, on one or more occasions, to invoke -one or more of the provisions hereof, shall under no circumstances be -interpreted as being a waiver by the interested Party of its right to -invoke said provision(s) subsequently. - -11.3 The Agreement cancels and replaces any or all previous agreements, -whether written or oral, between the Parties and having the same -purpose, and constitutes the entirety of the agreement between said -Parties concerning said purpose. No supplement or modification to the -terms and conditions hereof shall be effective as between the Parties -unless it is made in writing and signed by their duly authorized -representatives. - -11.4 In the event that one or more of the provisions hereof were to -conflict with a current or future applicable act or legislative text, -said act or legislative text shall prevail, and the Parties shall make -the necessary amendments so as to comply with said act or legislative -text. All other provisions shall remain effective. Similarly, invalidity -of a provision of the Agreement, for any reason whatsoever, shall not -cause the Agreement as a whole to be invalid. - - - 11.5 LANGUAGE - -The Agreement is drafted in both French and English and both versions -are deemed authentic. - - - Article 12 - NEW VERSIONS OF THE AGREEMENT - -12.1 Any person is authorized to duplicate and distribute copies of this -Agreement. - -12.2 So as to ensure coherence, the wording of this Agreement is -protected and may only be modified by the authors of the License, who -reserve the right to periodically publish updates or new versions of the -Agreement, each with a separate number. These subsequent versions may -address new issues encountered by Free Software. - -12.3 Any Software distributed under a given version of the Agreement may -only be subsequently distributed under the same version of the Agreement -or a subsequent version. - - - Article 13 - GOVERNING LAW AND JURISDICTION - -13.1 The Agreement is governed by French law. The Parties agree to -endeavor to seek an amicable solution to any disagreements or disputes -that may arise during the performance of the Agreement. - -13.2 Failing an amicable solution within two (2) months as from their -occurrence, and unless emergency proceedings are necessary, the -disagreements or disputes shall be referred to the Paris Courts having -jurisdiction, by the more diligent Party. - - -Version 1.0 dated 2006-09-05. diff --git a/src/pprint/README b/src/pprint/README deleted file mode 100644 index 7146250a..00000000 --- a/src/pprint/README +++ /dev/null @@ -1,13 +0,0 @@ -This is an adaptation of Daan Leijen's "PPrint" library, which itself is based -on the ideas developed by Philip Wadler in "A Prettier Printer". For more -information about Wadler's and Leijen's work, please consult the following -references: - - http://www.cs.uu.nl/~daan/pprint.html - http://homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf - -To install PPrint, type "make -C src install". ocamlfind is required. - -The documentation for PPrint is built by "make doc" and is found in the -file doc/index.html. - diff --git a/src/pprint/src/META b/src/pprint/src/META deleted file mode 100755 index 4a966166..00000000 --- a/src/pprint/src/META +++ /dev/null @@ -1,5 +0,0 @@ -requires = "" -description = "The PPrint pretty-printing library" -archive(byte) = "PPrintLib.cma" -archive(native) = "PPrintLib.cmxa" -version = "20171003" diff --git a/src/pprint/src/Makefile b/src/pprint/src/Makefile deleted file mode 100644 index 3bfa12df..00000000 --- a/src/pprint/src/Makefile +++ /dev/null @@ -1,46 +0,0 @@ -.PHONY: all install uninstall reinstall clean doc test bench - -OCAMLBUILD := ocamlbuild -use-ocamlfind -classic-display -OCAMLFIND := ocamlfind -DOCDIR := doc -MAIN := PPrintTest -TO_BUILD := PPrintLib.cma PPrintLib.cmxa - -all: - $(OCAMLBUILD) $(TO_BUILD) - -install: all - $(OCAMLFIND) install pprint META \ - $(patsubst %,_build/%,$(TO_BUILD)) \ - _build/PPrintLib.a _build/*.cmx _build/*.cmi - -# [make uninstall] attempts to uninstall, but succeeds even if uninstallation -# fails (probably because the package was not installed in the first place). -uninstall: - ocamlfind remove pprint || true - -reinstall: uninstall - @ $(MAKE) install - -clean: - rm -f *~ - rm -rf doc - $(OCAMLBUILD) -clean - -doc: all - @rm -rf $(DOCDIR) - @mkdir $(DOCDIR) - ocamlfind ocamldoc \ - -html \ - -I _build \ - -d $(DOCDIR) \ - -charset utf8 \ - PPrintRenderer.ml PPrintEngine.mli PPrintCombinators.mli PPrintOCaml.mli PPrint.ml - -test: all - $(OCAMLBUILD) $(MAIN).native - ./$(MAIN).native - -bench: all - $(OCAMLBUILD) -tag use_unix PPrintBench.native - time ./PPrintBench.native diff --git a/src/pprint/src/PPrint.ml b/src/pprint/src/PPrint.ml deleted file mode 100644 index 46d732b1..00000000 --- a/src/pprint/src/PPrint.ml +++ /dev/null @@ -1,18 +0,0 @@ -(**************************************************************************) -(* *) -(* PPrint *) -(* *) -(* François Pottier, Inria Paris *) -(* Nicolas Pouillard *) -(* *) -(* Copyright 2007-2017 Inria. All rights reserved. This file is *) -(* distributed under the terms of the GNU Library General Public *) -(* License, with an exception, as described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** A package of all of the above. *) - -include PPrintEngine -include PPrintCombinators -module OCaml = PPrintOCaml diff --git a/src/pprint/src/PPrintCombinators.ml b/src/pprint/src/PPrintCombinators.ml deleted file mode 100644 index 70499878..00000000 --- a/src/pprint/src/PPrintCombinators.ml +++ /dev/null @@ -1,311 +0,0 @@ -(**************************************************************************) -(* *) -(* PPrint *) -(* *) -(* François Pottier, Inria Paris *) -(* Nicolas Pouillard *) -(* *) -(* Copyright 2007-2017 Inria. All rights reserved. This file is *) -(* distributed under the terms of the GNU Library General Public *) -(* License, with an exception, as described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open PPrintEngine - -(* ------------------------------------------------------------------------- *) - -(* Predefined single-character documents. *) - -let lparen = char '(' -let rparen = char ')' -let langle = char '<' -let rangle = char '>' -let lbrace = char '{' -let rbrace = char '}' -let lbracket = char '[' -let rbracket = char ']' -let squote = char '\'' -let dquote = char '"' -let bquote = char '`' -let semi = char ';' -let colon = char ':' -let comma = char ',' -let space = char ' ' -let dot = char '.' -let sharp = char '#' -let slash = char '/' -let backslash = char '\\' -let equals = char '=' -let qmark = char '?' -let tilde = char '~' -let at = char '@' -let percent = char '%' -let dollar = char '$' -let caret = char '^' -let ampersand = char '&' -let star = char '*' -let plus = char '+' -let minus = char '-' -let underscore = char '_' -let bang = char '!' -let bar = char '|' - -(* ------------------------------------------------------------------------- *) - -(* Repetition. *) - -let twice doc = - doc ^^ doc - -let repeat n doc = - let rec loop n doc accu = - if n = 0 then - accu - else - loop (n - 1) doc (doc ^^ accu) - in - loop n doc empty - -(* ------------------------------------------------------------------------- *) - -(* Delimiters. *) - -let precede l x = l ^^ x -let terminate r x = x ^^ r -let enclose l r x = l ^^ x ^^ r - -let squotes = enclose squote squote -let dquotes = enclose dquote dquote -let bquotes = enclose bquote bquote -let braces = enclose lbrace rbrace -let parens = enclose lparen rparen -let angles = enclose langle rangle -let brackets = enclose lbracket rbracket - -(* ------------------------------------------------------------------------- *) - -(* Some functions on lists. *) - -(* A variant of [fold_left] that keeps track of the element index. *) - -let foldli (f : int -> 'b -> 'a -> 'b) (accu : 'b) (xs : 'a list) : 'b = - let r = ref 0 in - List.fold_left (fun accu x -> - let i = !r in - r := i + 1; - f i accu x - ) accu xs - -(* ------------------------------------------------------------------------- *) - -(* Working with lists of documents. *) - -let concat docs = - (* We take advantage of the fact that [^^] operates in constant - time, regardless of the size of its arguments. The document - that is constructed is essentially a reversed list (i.e., a - tree that is biased towards the left). This is not a problem; - when pretty-printing this document, the engine will descend - along the left branch, pushing the nodes onto its stack as - it goes down, effectively reversing the list again. *) - List.fold_left (^^) empty docs - -let separate sep docs = - foldli (fun i accu doc -> - if i = 0 then - doc - else - accu ^^ sep ^^ doc - ) empty docs - -let concat_map f xs = - List.fold_left (fun accu x -> - accu ^^ f x - ) empty xs - -let separate_map sep f xs = - foldli (fun i accu x -> - if i = 0 then - f x - else - accu ^^ sep ^^ f x - ) empty xs - -let separate2 sep last_sep docs = - let n = List.length docs in - foldli (fun i accu doc -> - if i = 0 then - doc - else - accu ^^ (if i < n - 1 then sep else last_sep) ^^ doc - ) empty docs - -let optional f = function - | None -> - empty - | Some x -> - f x - -(* ------------------------------------------------------------------------- *) - -(* Text. *) - -(* This variant of [String.index_from] returns an option. *) - -let index_from s i c = - try - Some (String.index_from s i c) - with Not_found -> - None - -(* [lines s] chops the string [s] into a list of lines, which are turned - into documents. *) - -let lines s = - let rec chop accu i = - match index_from s i '\n' with - | Some j -> - let accu = substring s i (j - i) :: accu in - chop accu (j + 1) - | None -> - substring s i (String.length s - i) :: accu - in - List.rev (chop [] 0) - -let arbitrary_string s = - separate (break 1) (lines s) - -(* [split ok s] splits the string [s] at every occurrence of a character - that satisfies the predicate [ok]. The substrings thus obtained are - turned into documents, and a list of documents is returned. No information - is lost: the concatenation of the documents yields the original string. - This code is not UTF-8 aware. *) - -let split ok s = - let n = String.length s in - let rec index_from i = - if i = n then - None - else if ok s.[i] then - Some i - else - index_from (i + 1) - in - let rec chop accu i = - match index_from i with - | Some j -> - let accu = substring s i (j - i) :: accu in - let accu = char s.[j] :: accu in - chop accu (j + 1) - | None -> - substring s i (String.length s - i) :: accu - in - List.rev (chop [] 0) - -(* [words s] chops the string [s] into a list of words, which are turned - into documents. *) - -let words s = - let n = String.length s in - (* A two-state finite automaton. *) - (* In this state, we have skipped at least one blank character. *) - let rec skipping accu i = - if i = n then - (* There was whitespace at the end. Drop it. *) - accu - else match s.[i] with - | ' ' - | '\t' - | '\n' - | '\r' -> - (* Skip more whitespace. *) - skipping accu (i + 1) - | _ -> - (* Begin a new word. *) - word accu i (i + 1) - (* In this state, we have skipped at least one non-blank character. *) - and word accu i j = - if j = n then - (* Final word. *) - substring s i (j - i) :: accu - else match s.[j] with - | ' ' - | '\t' - | '\n' - | '\r' -> - (* A new word has been identified. *) - let accu = substring s i (j - i) :: accu in - skipping accu (j + 1) - | _ -> - (* Continue inside the current word. *) - word accu i (j + 1) - in - List.rev (skipping [] 0) - -let flow_map sep f docs = - foldli (fun i accu doc -> - if i = 0 then - f doc - else - accu ^^ - (* This idiom allows beginning a new line if [doc] does not - fit on the current line. *) - group (sep ^^ f doc) - ) empty docs - -let flow sep docs = - flow_map sep (fun x -> x) docs - -let url s = - flow (break 0) (split (function '/' | '.' -> true | _ -> false) s) - -(* ------------------------------------------------------------------------- *) - -(* Alignment and indentation. *) - -let hang i d = - align (nest i d) - -let ( !^ ) = string - -let ( ^/^ ) x y = - x ^^ break 1 ^^ y - -let prefix n b x y = - group (x ^^ nest n (break b ^^ y)) - -let (^//^) = - prefix 2 1 - -let jump n b y = - group (nest n (break b ^^ y)) - -(* Deprecated. -let ( ^@^ ) x y = group (x ^/^ y) -let ( ^@@^ ) x y = group (nest 2 (x ^/^ y)) -*) - -let infix n b op x y = - prefix n b (x ^^ blank b ^^ op) y - -let surround n b opening contents closing = - group (opening ^^ nest n ( break b ^^ contents) ^^ break b ^^ closing ) - -let soft_surround n b opening contents closing = - group (opening ^^ nest n (group (break b) ^^ contents) ^^ group (break b ^^ closing)) - -let surround_separate n b void opening sep closing docs = - match docs with - | [] -> - void - | _ :: _ -> - surround n b opening (separate sep docs) closing - -let surround_separate_map n b void opening sep closing f xs = - match xs with - | [] -> - void - | _ :: _ -> - surround n b opening (separate_map sep f xs) closing - diff --git a/src/pprint/src/PPrintCombinators.mli b/src/pprint/src/PPrintCombinators.mli deleted file mode 100644 index c538cb35..00000000 --- a/src/pprint/src/PPrintCombinators.mli +++ /dev/null @@ -1,236 +0,0 @@ -(**************************************************************************) -(* *) -(* PPrint *) -(* *) -(* François Pottier, Inria Paris *) -(* Nicolas Pouillard *) -(* *) -(* Copyright 2007-2017 Inria. All rights reserved. This file is *) -(* distributed under the terms of the GNU Library General Public *) -(* License, with an exception, as described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open PPrintEngine - -(** A set of high-level combinators for building documents. *) - -(** {1 Single characters} *) - -(** The following constant documents consist of a single character. *) - -val lparen: document -val rparen: document -val langle: document -val rangle: document -val lbrace: document -val rbrace: document -val lbracket: document -val rbracket: document -val squote: document -val dquote: document -val bquote: document -val semi: document -val colon: document -val comma: document -val space: document -val dot: document -val sharp: document -val slash: document -val backslash: document -val equals: document -val qmark: document -val tilde: document -val at: document -val percent: document -val dollar: document -val caret: document -val ampersand: document -val star: document -val plus: document -val minus: document -val underscore: document -val bang: document -val bar: document - -(** {1 Delimiters} *) - -(** [precede l x] is [l ^^ x]. *) -val precede: document -> document -> document - -(** [terminate r x] is [x ^^ r]. *) -val terminate: document -> document -> document - -(** [enclose l r x] is [l ^^ x ^^ r]. *) -val enclose: document -> document -> document -> document - -(** The following combinators enclose a document within a pair of delimiters. - They are partial applications of [enclose]. No whitespace or line break is - introduced. *) - -val squotes: document -> document -val dquotes: document -> document -val bquotes: document -> document -val braces: document -> document -val parens: document -> document -val angles: document -> document -val brackets: document -> document - -(** {1 Repetition} *) - -(** [twice doc] is the document obtained by concatenating two copies of - the document [doc]. *) -val twice: document -> document - -(** [repeat n doc] is the document obtained by concatenating [n] copies of - the document [doc]. *) -val repeat: int -> document -> document - -(** {1 Lists and options} *) - -(** [concat docs] is the concatenation of the documents in the list [docs]. *) -val concat: document list -> document - -(** [separate sep docs] is the concatenation of the documents in the list - [docs]. The separator [sep] is inserted between every two adjacent - documents. *) -val separate: document -> document list -> document - -(** [concat_map f xs] is equivalent to [concat (List.map f xs)]. *) -val concat_map: ('a -> document) -> 'a list -> document - -(** [separate_map sep f xs] is equivalent to [separate sep (List.map f xs)]. *) -val separate_map: document -> ('a -> document) -> 'a list -> document - -(** [separate2 sep last_sep docs] is the concatenation of the documents in the - list [docs]. The separator [sep] is inserted between every two adjacent - documents, except between the last two documents, where the separator - [last_sep] is used instead. *) -val separate2: document -> document -> document list -> document - -(** [optional f None] is the empty document. [optional f (Some x)] is - the document [f x]. *) -val optional: ('a -> document) -> 'a option -> document - -(** {1 Text} *) - -(** [lines s] is the list of documents obtained by splitting [s] at newline - characters, and turning each line into a document via [substring]. This - code is not UTF-8 aware. *) -val lines: string -> document list - -(** [arbitrary_string s] is equivalent to [separate (break 1) (lines s)]. - It is analogous to [string s], but is valid even if the string [s] - contains newline characters. *) -val arbitrary_string: string -> document - -(** [words s] is the list of documents obtained by splitting [s] at whitespace - characters, and turning each word into a document via [substring]. All - whitespace is discarded. This code is not UTF-8 aware. *) -val words: string -> document list - -(** [split ok s] splits the string [s] before and after every occurrence of a - character that satisfies the predicate [ok]. The substrings thus obtained - are turned into documents, and a list of documents is returned. No - information is lost: the concatenation of the documents yields the - original string. This code is not UTF-8 aware. *) -val split: (char -> bool) -> string -> document list - -(** [flow sep docs] separates the documents in the list [docs] with the - separator [sep] and arranges for a new line to begin whenever a document - does not fit on the current line. This is useful for typesetting - free-flowing, ragged-right text. A typical choice of [sep] is [break b], - where [b] is the number of spaces that must be inserted between two - consecutive words (when displayed on the same line). *) -val flow: document -> document list -> document - -(** [flow_map sep f docs] is equivalent to [flow sep (List.map f docs)]. *) -val flow_map: document -> ('a -> document) -> 'a list -> document - -(** [url s] is a possible way of displaying the URL [s]. A potential line - break is inserted immediately before and immediately after every slash - and dot character. *) -val url: string -> document - -(** {1 Alignment and indentation} *) - -(* [hang n doc] is analogous to [align], but additionally indents - all lines, except the first one, by [n]. Thus, the text in the - box forms a hanging indent. *) -val hang: int -> document -> document - -(** [prefix n b left right] has the following flat layout: {[ -left right -]} -and the following non-flat layout: -{[ -left - right -]} -The parameter [n] controls the nesting of [right] (when not flat). -The parameter [b] controls the number of spaces between [left] and [right] -(when flat). - *) -val prefix: int -> int -> document -> document -> document - -(** [jump n b right] is equivalent to [prefix n b empty right]. *) -val jump: int -> int -> document -> document - -(** [infix n b middle left right] has the following flat layout: {[ -left middle right -]} -and the following non-flat layout: {[ -left middle - right -]} -The parameter [n] controls the nesting of [right] (when not flat). -The parameter [b] controls the number of spaces between [left] and [middle] -(always) and between [middle] and [right] (when flat). -*) -val infix: int -> int -> document -> document -> document -> document - -(** [surround n b opening contents closing] has the following flat layout: {[ -opening contents closing -]} -and the following non-flat layout: {[ -opening - contents -closing -]} -The parameter [n] controls the nesting of [contents] (when not flat). -The parameter [b] controls the number of spaces between [opening] and [contents] -and between [contents] and [closing] (when flat). -*) -val surround: int -> int -> document -> document -> document -> document - -(** [soft_surround] is analogous to [surround], but involves more than one - group, so it offers possibilities other than the completely flat layout - (where [opening], [contents], and [closing] appear on a single line) and - the completely developed layout (where [opening], [contents], and - [closing] appear on separate lines). It tries to place the beginning of - [contents] on the same line as [opening], and to place [closing] on the - same line as the end of [contents], if possible. -*) -val soft_surround: int -> int -> document -> document -> document -> document - -(** [surround_separate n b void opening sep closing docs] is equivalent to - [surround n b opening (separate sep docs) closing], except when the - list [docs] is empty, in which case it reduces to [void]. *) -val surround_separate: int -> int -> document -> document -> document -> document -> document list -> document - -(** [surround_separate_map n b void opening sep closing f xs] is equivalent to - [surround_separate n b void opening sep closing (List.map f xs)]. *) -val surround_separate_map: int -> int -> document -> document -> document -> document -> ('a -> document) -> 'a list -> document - -(** {1 Short-hands} *) - -(** [!^s] is a short-hand for [string s]. *) -val ( !^ ) : string -> document - -(** [x ^/^ y] separates [x] and [y] with a breakable space. - It is a short-hand for [x ^^ break 1 ^^ y]. *) -val ( ^/^ ) : document -> document -> document - -(** [x ^//^ y] is a short-hand for [prefix 2 1 x y]. *) -val ( ^//^ ) : document -> document -> document - diff --git a/src/pprint/src/PPrintEngine.ml b/src/pprint/src/PPrintEngine.ml deleted file mode 100644 index 2a78363d..00000000 --- a/src/pprint/src/PPrintEngine.ml +++ /dev/null @@ -1,642 +0,0 @@ -(**************************************************************************) -(* *) -(* PPrint *) -(* *) -(* François Pottier, Inria Paris *) -(* Nicolas Pouillard *) -(* *) -(* Copyright 2007-2017 Inria. All rights reserved. This file is *) -(* distributed under the terms of the GNU Library General Public *) -(* License, with an exception, as described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* ------------------------------------------------------------------------- *) - -(* A type of integers with infinity. *) - -type requirement = - int (* with infinity *) - -(* Infinity is encoded as [max_int]. *) - -let infinity : requirement = - max_int - -(* Addition of integers with infinity. *) - -let (++) (x : requirement) (y : requirement) : requirement = - if x = infinity || y = infinity then - infinity - else - x + y - -(* Comparison between an integer with infinity and a normal integer. *) - -let (<==) (x : requirement) (y : int) = - x <= y - -(* ------------------------------------------------------------------------- *) - -(* A uniform interface for output channels. *) - -class type output = object - - (** [char c] sends the character [c] to the output channel. *) - method char: char -> unit - - (** [substring s ofs len] sends the substring of [s] delimited by the - offset [ofs] and the length [len] to the output channel. *) - method substring: string -> int (* offset *) -> int (* length *) -> unit - -end - -(* Three kinds of output channels are wrapped so as to satisfy the above - interface: OCaml output channels, OCaml memory buffers, and OCaml - formatters. *) - -class channel_output channel = object - method char = output_char channel - method substring = output_substring channel - (* We used to use [output], but, as of OCaml 4.02 and with -safe-string - enabled, the type of [output] has changed: this function now expects - an argument of type [bytes]. The new function [output_substring] must - be used instead. Furthermore, as of OCaml 4.06, -safe-string is enabled - by default. In summary, we require OCaml 4.02, use [output_substring], - and enable -safe-string. *) -end - -class buffer_output buffer = object - method char = Buffer.add_char buffer - method substring = Buffer.add_substring buffer -end - -class formatter_output fmt = object - method char = Format.pp_print_char fmt - method substring = fst (Format.pp_get_formatter_output_functions fmt ()) -end - -(* ------------------------------------------------------------------------- *) - -(** The rendering engine maintains the following internal state. Its structure - is subject to change in future versions of the library. Nevertheless, it is - exposed to the user who wishes to define custom documents. *) - -type state = { - - width: int; - (** The line width. This parameter is fixed throughout the execution of - the renderer. *) - - ribbon: int; - (** The ribbon width. This parameter is fixed throughout the execution of - the renderer. *) - - mutable last_indent: int; - (** The number of blanks that were printed at the beginning of the current - line. This field is updated (only) by the function [emit_hardline]. It - is used (only) to determine whether the ribbon width constraint is - respected. *) - - mutable column: int; - (** The current column. This field must be updated whenever something is - sent to the output channel. It is used (only) to determine whether the - width constraint is respected. *) - - } - -(* ------------------------------------------------------------------------- *) - -(* [initial rfrac width] creates a fresh initial state. *) - -let initial rfrac width = { - width = width; - ribbon = max 0 (min width (truncate (float_of_int width *. rfrac))); - last_indent = 0; - column = 0 -} - -(* ------------------------------------------------------------------------- *) - -(** A custom document is defined by implementing the following methods. *) - -class type custom = object - - (** A custom document must publish the width (i.e., the number of columns) - that it would like to occupy if it is printed on a single line (that is, - in flattening mode). The special value [infinity] means that this - document cannot be printed on a single line; this value causes any - groups that contain this document to be dissolved. This method should - in principle work in constant time. *) - method requirement: requirement - - (** The method [pretty] is used by the main rendering algorithm. It has - access to the output channel and to the algorithm's internal state, as - described above. In addition, it receives the current indentation level - and the current flattening mode (on or off). If flattening mode is on, - then the document must be printed on a single line, in a manner that is - consistent with the requirement that was published ahead of time. If - flattening mode is off, then there is no such obligation. The state must - be updated in a manner that is consistent with what is sent to the - output channel. *) - method pretty: output -> state -> int -> bool -> unit - - (** The method [compact] is used by the compact rendering algorithm. It has - access to the output channel only. *) - method compact: output -> unit - -end - -(* ------------------------------------------------------------------------- *) - -(* Here is the algebraic data type of documents. It is analogous to Daan - Leijen's version, but the binary constructor [Union] is replaced with - the unary constructor [Group], and the constant [Line] is replaced with - more general constructions, namely [IfFlat], which provides alternative - forms depending on the current flattening mode, and [HardLine], which - represents a newline character, and causes a failure in flattening mode. *) - -type document = - - (* [Empty] is the empty document. *) - - | Empty - - (* [Char c] is a document that consists of the single character [c]. We - enforce the invariant that [c] is not a newline character. *) - - | Char of char - - (* [String s] is a document that consists of just the string [s]. We - assume, but do not check, that this string does not contain a newline - character. [String] is a special case of [FancyString], which takes up - less space in memory. *) - - | String of string - - (* [FancyString (s, ofs, len, apparent_length)] is a (portion of a) string - that may contain fancy characters: color escape characters, UTF-8 or - multi-byte characters, etc. Thus, the apparent length (which corresponds - to what will be visible on screen) differs from the length (which is a - number of bytes, and is reported by [String.length]). We assume, but do - not check, that fancystrings do not contain a newline character. *) - - | FancyString of string * int * int * int - - (* [Blank n] is a document that consists of [n] blank characters. *) - - | Blank of int - - (* When in flattening mode, [IfFlat (d1, d2)] turns into the document - [d1]. When not in flattening mode, it turns into the document [d2]. *) - - | IfFlat of document * document - - (* When in flattening mode, [HardLine] causes a failure, which requires - backtracking all the way until the stack is empty. When not in flattening - mode, it represents a newline character, followed with an appropriate - number of indentation. A common way of using [HardLine] is to only use it - directly within the right branch of an [IfFlat] construct. *) - - | HardLine - - (* The following constructors store their space requirement. This is the - document's apparent length, if printed in flattening mode. This - information is computed in a bottom-up manner when the document is - constructed. *) - - (* In other words, the space requirement is the number of columns that the - document needs in order to fit on a single line. We express this value in - the set of `integers extended with infinity', and use the value - [infinity] to indicate that the document cannot be printed on a single - line. *) - - (* Storing this information at [Group] nodes is crucial, as it allows us to - avoid backtracking and buffering. *) - - (* Storing this information at other nodes allows the function [requirement] - to operate in constant time. This means that the bottom-up computation of - requirements takes linear time. *) - - (* [Cat (req, doc1, doc2)] is the concatenation of the documents [doc1] and - [doc2]. The space requirement [req] is the sum of the requirements of - [doc1] and [doc2]. *) - - | Cat of requirement * document * document - - (* [Nest (req, j, doc)] is the document [doc], in which the indentation - level has been increased by [j], that is, in which [j] blanks have been - inserted after every newline character. The space requirement [req] is - the same as the requirement of [doc]. *) - - | Nest of requirement * int * document - - (* [Group (req, doc)] represents an alternative: it is either a flattened - form of [doc], in which occurrences of [Group] disappear and occurrences - of [IfFlat] resolve to their left branch, or [doc] itself. The space - requirement [req] is the same as the requirement of [doc]. *) - - | Group of requirement * document - - (* [Align (req, doc)] increases the indentation level to reach the current - column. Thus, the document [doc] is rendered within a box whose upper - left corner is the current position. The space requirement [req] is the - same as the requirement of [doc]. *) - - | Align of requirement * document - - (* [Custom (req, f)] is a document whose appearance is user-defined. *) - - | Custom of custom - -(* ------------------------------------------------------------------------- *) - -(* Retrieving or computing the space requirement of a document. *) - -let rec requirement = function - | Empty -> - 0 - | Char _ -> - 1 - | String s -> - String.length s - | FancyString (_, _, _, len) - | Blank len -> - len - | IfFlat (doc1, _) -> - (* In flattening mode, the requirement of [ifflat x y] is just the - requirement of its flat version, [x]. *) - (* The smart constructor [ifflat] ensures that [IfFlat] is never nested - in the left-hand side of [IfFlat], so this recursive call is not a - problem; the function [requirement] has constant time complexity. *) - requirement doc1 - | HardLine -> - (* A hard line cannot be printed in flattening mode. *) - infinity - | Cat (req, _, _) - | Nest (req, _, _) - | Group (req, _) - | Align (req, _) -> - (* These nodes store their requirement -- which is computed when the - node is constructed -- so as to allow us to answer in constant time - here. *) - req - | Custom c -> - c#requirement - -(* ------------------------------------------------------------------------- *) - -(* The above algebraic data type is not exposed to the user. Instead, we - expose the following functions. These functions construct a raw document - and compute its requirement, so as to obtain a document. *) - -let empty = - Empty - -let char c = - assert (c <> '\n'); - Char c - -let space = - char ' ' - -let string s = - String s - -let fancysubstring s ofs len apparent_length = - if len = 0 then - empty - else - FancyString (s, ofs, len, apparent_length) - -let substring s ofs len = - fancysubstring s ofs len len - -let fancystring s apparent_length = - fancysubstring s 0 (String.length s) apparent_length - -(* The following function was stolen from [Batteries]. *) -let utf8_length s = - let rec length_aux s c i = - if i >= String.length s then c else - let n = Char.code (String.unsafe_get s i) in - let k = - if n < 0x80 then 1 else - if n < 0xe0 then 2 else - if n < 0xf0 then 3 else 4 - in - length_aux s (c + 1) (i + k) - in - length_aux s 0 0 - -let utf8string s = - fancystring s (utf8_length s) - -let hardline = - HardLine - -let blank n = - match n with - | 0 -> - empty - | 1 -> - space - | _ -> - Blank n - -let ifflat doc1 doc2 = - (* Avoid nesting [IfFlat] in the left-hand side of [IfFlat], as this - is redundant. *) - match doc1 with - | IfFlat (doc1, _) - | doc1 -> - IfFlat (doc1, doc2) - -let internal_break i = - ifflat (blank i) hardline - -let break0 = - internal_break 0 - -let break1 = - internal_break 1 - -let break i = - match i with - | 0 -> - break0 - | 1 -> - break1 - | _ -> - internal_break i - -let (^^) x y = - match x, y with - | Empty, _ -> - y - | _, Empty -> - x - | _, _ -> - Cat (requirement x ++ requirement y, x, y) - -let nest i x = - assert (i >= 0); - Nest (requirement x, i, x) - -let group x = - let req = requirement x in - (* Minor optimisation: an infinite requirement dissolves a group. *) - if req = infinity then - x - else - Group (req, x) - -let align x = - Align (requirement x, x) - -let custom c = - (* Sanity check. *) - assert (c#requirement >= 0); - Custom c - -(* ------------------------------------------------------------------------- *) - -(* Printing blank space (indentation characters). *) - -let blank_length = - 80 - -let blank_buffer = - String.make blank_length ' ' - -let rec blanks output n = - if n <= 0 then - () - else if n <= blank_length then - output#substring blank_buffer 0 n - else begin - output#substring blank_buffer 0 blank_length; - blanks output (n - blank_length) - end - -(* ------------------------------------------------------------------------- *) - -(* This function expresses the following invariant: if we are in flattening - mode, then we must be within bounds, i.e. the width and ribbon width - constraints must be respected. *) - -let ok state flatten : bool = - not flatten || - state.column <= state.width && state.column <= state.last_indent + state.ribbon - -(* ------------------------------------------------------------------------- *) - -(* The pretty rendering engine. *) - -(* The renderer is supposed to behave exactly like Daan Leijen's, although its - implementation is quite radically different, and simpler. Our documents are - constructed eagerly, as opposed to lazily. This means that we pay a large - space overhead, but in return, we get the ability of computing information - bottom-up, as described above, which allows to render documents without - backtracking or buffering. *) - -(* The [state] record is never copied; it is just threaded through. In - addition to it, the parameters [indent] and [flatten] influence the - manner in which the document is rendered. *) - -(* The code is written in tail-recursive style, so as to avoid running out of - stack space if the document is very deep. Its explicit continuation can be - viewed as a sequence of pending calls to [pretty]. *) - -type cont = - | KNil - | KCons of int * bool * document * cont - -let rec pretty - (output : output) - (state : state) - (indent : int) - (flatten : bool) - (doc : document) - (cont : cont) -: unit = - match doc with - - | Empty -> - continue output state cont - - | Char c -> - output#char c; - state.column <- state.column + 1; - (* assert (ok state flatten); *) - continue output state cont - - | String s -> - let len = String.length s in - output#substring s 0 len; - state.column <- state.column + len; - (* assert (ok state flatten); *) - continue output state cont - - | FancyString (s, ofs, len, apparent_length) -> - output#substring s ofs len; - state.column <- state.column + apparent_length; - (* assert (ok state flatten); *) - continue output state cont - - | Blank n -> - blanks output n; - state.column <- state.column + n; - (* assert (ok state flatten); *) - continue output state cont - - | HardLine -> - (* We cannot be in flattening mode, because a hard line has an [infinity] - requirement, and we attempt to render a group in flattening mode only - if this group's requirement is met. *) - assert (not flatten); - (* Emit a hardline. *) - output#char '\n'; - blanks output indent; - state.column <- indent; - state.last_indent <- indent; - (* Continue. *) - continue output state cont - - | IfFlat (doc1, doc2) -> - (* Pick an appropriate sub-document, based on the current flattening - mode. *) - pretty output state indent flatten (if flatten then doc1 else doc2) cont - - | Cat (_, doc1, doc2) -> - (* Push the second document onto the continuation. *) - pretty output state indent flatten doc1 (KCons (indent, flatten, doc2, cont)) - - | Nest (_, j, doc) -> - pretty output state (indent + j) flatten doc cont - - | Group (req, doc) -> - (* If we already are in flattening mode, stay in flattening mode; we - are committed to it. If we are not already in flattening mode, we - have a choice of entering flattening mode. We enter this mode only - if we know that this group fits on this line without violating the - width or ribbon width constraints. Thus, we never backtrack. *) - let flatten = - flatten || - let column = state.column ++ req in - column <== state.width && column <== state.last_indent + state.ribbon - in - pretty output state indent flatten doc cont - - | Align (_, doc) -> - (* The effect of this combinator is to set [indent] to [state.column]. - Usually [indent] is equal to [state.last_indent], hence setting it - to [state.column] increases it. However, if [nest] has been used - since the current line began, then this could cause [indent] to - decrease. *) - (* assert (state.column > state.last_indent); *) - pretty output state state.column flatten doc cont - - | Custom c -> - (* Invoke the document's custom rendering function. *) - c#pretty output state indent flatten; - (* Sanity check. *) - assert (ok state flatten); - (* Continue. *) - continue output state cont - -and continue output state = function - | KNil -> - () - | KCons (indent, flatten, doc, cont) -> - pretty output state indent flatten doc cont - -(* Publish a version of [pretty] that does not take an explicit continuation. - This function may be used by authors of custom documents. We do not expose - the internal [pretty] -- the one that takes a continuation -- because we - wish to simplify the user's life. The price to pay is that calls that go - through a custom document cannot be tail calls. *) - -let pretty output state indent flatten doc = - pretty output state indent flatten doc KNil - -(* ------------------------------------------------------------------------- *) - -(* The compact rendering algorithm. *) - -let rec compact output doc cont = - match doc with - | Empty -> - continue output cont - | Char c -> - output#char c; - continue output cont - | String s -> - let len = String.length s in - output#substring s 0 len; - continue output cont - | FancyString (s, ofs, len, apparent_length) -> - output#substring s ofs len; - continue output cont - | Blank n -> - blanks output n; - continue output cont - | HardLine -> - output#char '\n'; - continue output cont - | Cat (_, doc1, doc2) -> - compact output doc1 (doc2 :: cont) - | IfFlat (doc, _) - | Nest (_, _, doc) - | Group (_, doc) - | Align (_, doc) -> - compact output doc cont - | Custom c -> - (* Invoke the document's custom rendering function. *) - c#compact output; - continue output cont - -and continue output cont = - match cont with - | [] -> - () - | doc :: cont -> - compact output doc cont - -let compact output doc = - compact output doc [] - -(* ------------------------------------------------------------------------- *) - -(* We now instantiate the renderers for the three kinds of output channels. *) - -(* This is just boilerplate. *) - -module MakeRenderer (X : sig - type channel - val output: channel -> output -end) = struct - type channel = X.channel - type dummy = document - type document = dummy - let pretty rfrac width channel doc = pretty (X.output channel) (initial rfrac width) 0 false doc - let compact channel doc = compact (X.output channel) doc -end - -module ToChannel = - MakeRenderer(struct - type channel = out_channel - let output = new channel_output - end) - -module ToBuffer = - MakeRenderer(struct - type channel = Buffer.t - let output = new buffer_output - end) - -module ToFormatter = - MakeRenderer(struct - type channel = Format.formatter - let output = new formatter_output - end) diff --git a/src/pprint/src/PPrintEngine.mli b/src/pprint/src/PPrintEngine.mli deleted file mode 100644 index eda61a6c..00000000 --- a/src/pprint/src/PPrintEngine.mli +++ /dev/null @@ -1,226 +0,0 @@ -(**************************************************************************) -(* *) -(* PPrint *) -(* *) -(* François Pottier, Inria Paris *) -(* Nicolas Pouillard *) -(* *) -(* Copyright 2007-2017 Inria. All rights reserved. This file is *) -(* distributed under the terms of the GNU Library General Public *) -(* License, with an exception, as described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** A pretty-printing engine and a set of basic document combinators. *) - -(** {1 Building documents} *) - -(** Documents must be built in memory before they are rendered. This may seem - costly, but it is a simple approach, and works well. *) - -(** The following operations form a set of basic (low-level) combinators for - building documents. On top of these combinators, higher-level combinators - can be defined: see {!PPrintCombinators}. *) - -(** This is the abstract type of documents. *) -type document - -(** The following basic (low-level) combinators allow constructing documents. *) - -(** [empty] is the empty document. *) -val empty: document - -(** [char c] is a document that consists of the single character [c]. This - character must not be a newline. *) -val char: char -> document - -(** [string s] is a document that consists of the string [s]. This string must - not contain a newline. *) -val string: string -> document - -(** [substring s ofs len] is a document that consists of the portion of the - string [s] delimited by the offset [ofs] and the length [len]. This - portion must not contain a newline. *) -val substring: string -> int -> int -> document - -(** [fancystring s apparent_length] is a document that consists of the string - [s]. This string must not contain a newline. The string may contain fancy - characters: color escape characters, UTF-8 or multi-byte characters, - etc. Thus, its apparent length (which measures how many columns the text - will take up on screen) differs from its length in bytes. *) -val fancystring: string -> int -> document - -(** [fancysubstring s ofs len apparent_length] is a document that consists of - the portion of the string [s] delimited by the offset [ofs] and the length - [len]. This portion must contain a newline. The string may contain fancy - characters. *) -val fancysubstring : string -> int -> int -> int -> document - -(** [utf8string s] is a document that consists of the UTF-8-encoded string [s]. - This string must not contain a newline. *) -val utf8string: string -> document - -(** [hardline] is a forced newline document. This document forces all enclosing - groups to be printed in non-flattening mode. In other words, any enclosing - groups are dissolved. *) -val hardline: document - -(** [blank n] is a document that consists of [n] blank characters. *) -val blank: int -> document - -(** [break n] is a document which consists of either [n] blank characters, - when forced to display on a single line, or a single newline character, - otherwise. Note that there is no choice at this point: choices are encoded - by the [group] combinator. *) -val break: int -> document - -(** [doc1 ^^ doc2] is the concatenation of the documents [doc1] and [doc2]. *) -val (^^): document -> document -> document - -(** [nest j doc] is the document [doc], in which the indentation level has - been increased by [j], that is, in which [j] blanks have been inserted - after every newline character. Read this again: indentation is inserted - after every newline character. No indentation is inserted at the beginning - of the document. *) -val nest: int -> document -> document - -(** [group doc] encodes a choice. If possible, then the entire document [group - doc] is rendered on a single line. Otherwise, the group is dissolved, and - [doc] is rendered. There might be further groups within [doc], whose - presence will lead to further choices being explored. *) -val group: document -> document - -(** [ifflat doc1 doc2] is rendered as [doc1] if part of a group that can be - successfully flattened, and is rendered as [doc2] otherwise. Use this - operation with caution. Because the pretty-printer is free to choose - between [doc1] and [doc2], these documents should be semantically - equivalent. *) -val ifflat: document -> document -> document - -(** [align doc] is the document [doc], in which the indentation level has been - set to the current column. Thus, [doc] is rendered within a box whose - upper left corner is the current position. *) -val align: document -> document - -(** {1 Rendering documents} *) - -(** This renderer sends its output into an output channel. *) -module ToChannel : PPrintRenderer.RENDERER - with type channel = out_channel - and type document = document - -(** This renderer sends its output into a memory buffer. *) -module ToBuffer : PPrintRenderer.RENDERER - with type channel = Buffer.t - and type document = document - -(** This renderer sends its output into a formatter channel. *) -module ToFormatter : PPrintRenderer.RENDERER - with type channel = Format.formatter - and type document = document - -(** {1 Defining custom documents} *) - -(** A width requirement is expressed as an integer, where the value [max_int] - is reserved and represents infinity. *) - -type requirement = int -val infinity : requirement - -(** An output channel is represented abstractly as an object equipped with - methods for displaying one character and for displaying a substring. *) - -class type output = object - - (** [char c] sends the character [c] to the output channel. *) - method char: char -> unit - - (** [substring s ofs len] sends the substring of [s] delimited by the - offset [ofs] and the length [len] to the output channel. *) - method substring: string -> int (* offset *) -> int (* length *) -> unit - -end - -(** The rendering engine maintains the following internal state. Its structure - is subject to change in future versions of the library. Nevertheless, it is - exposed to the user who wishes to define custom documents. *) - -type state = { - - width: int; - (** The line width. This parameter is fixed throughout the execution of - the renderer. *) - - ribbon: int; - (** The ribbon width. This parameter is fixed throughout the execution of - the renderer. *) - - mutable last_indent: int; - (** The number of blanks that were printed at the beginning of the current - line. This field is updated (only) by the function [emit_hardline]. It - is used (only) to determine whether the ribbon width constraint is - respected. *) - - mutable column: int; - (** The current column. This field must be updated whenever something is - sent to the output channel. It is used (only) to determine whether the - width constraint is respected. *) - - } - -(** A custom document is defined by implementing the following methods. *) - -class type custom = object - - (** A custom document must publish the width (i.e., the number of columns) - that it would like to occupy if it is printed on a single line (that is, - in flattening mode). The special value [infinity] means that this - document cannot be printed on a single line; this value causes any - groups that contain this document to be dissolved. This method should - in principle work in constant time. *) - method requirement: requirement - - (** The method [pretty] is used by the main rendering algorithm. It has - access to the output channel and to the algorithm's internal state, as - described above. In addition, it receives the current indentation level - and the current flattening mode (on or off). If flattening mode is on, - then the document must be printed on a single line, in a manner that is - consistent with the requirement that was published ahead of time. If - flattening mode is off, then there is no such obligation. The state must - be updated in a manner that is consistent with what is sent to the - output channel. *) - method pretty: output -> state -> int -> bool -> unit - - (** The method [compact] is used by the compact rendering algorithm. It has - access to the output channel only. *) - method compact: output -> unit - -end - -(** The function [custom] constructs a custom document. In other words, it - converts an object of type [custom] to a document. *) -val custom: custom -> document - -(** The key functions of the library are exposed, in the hope that they may be - useful to authors of custom (leaf and non-leaf) documents. In the case of - a leaf document, they can help perform certain basic functions; for - instance, applying the function [pretty] to the document [hardline] is a - simple way of printing a hardline, while respecting the indentation - parameters and updating the state in a correct manner. Similarly, applying - [pretty] to the document [blank n] is a simple way of printing [n] spaces. - In the case of a non-leaf document (i.e., one which contains - sub-documents), these functions are essential: they allow computing the - width requirement of a sub-document and displaying a sub-document. *) - -(** [requirement doc] computes the width requirement of the document [doc]. - It works in constant time. *) -val requirement: document -> requirement - -(** [pretty output state indent flatten doc] prints the document [doc]. See - the documentation of the method [pretty]. *) -val pretty: output -> state -> int -> bool -> document -> unit - -(** [compact output doc] prints the document [doc]. See the documentation of - the method [compact]. *) -val compact: output -> document -> unit - diff --git a/src/pprint/src/PPrintLib.mllib b/src/pprint/src/PPrintLib.mllib deleted file mode 100644 index e5de6978..00000000 --- a/src/pprint/src/PPrintLib.mllib +++ /dev/null @@ -1,5 +0,0 @@ -PPrint -PPrintCombinators -PPrintEngine -PPrintOCaml -PPrintRenderer diff --git a/src/pprint/src/PPrintOCaml.ml b/src/pprint/src/PPrintOCaml.ml deleted file mode 100644 index bee5f2a3..00000000 --- a/src/pprint/src/PPrintOCaml.ml +++ /dev/null @@ -1,158 +0,0 @@ -(**************************************************************************) -(* *) -(* PPrint *) -(* *) -(* François Pottier, Inria Paris *) -(* Nicolas Pouillard *) -(* *) -(* Copyright 2007-2017 Inria. All rights reserved. This file is *) -(* distributed under the terms of the GNU Library General Public *) -(* License, with an exception, as described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Printf -open PPrintEngine -open PPrintCombinators - -type constructor = string -type type_name = string -type record_field = string -type tag = int - -(* ------------------------------------------------------------------------- *) - -(* This internal [sprintf]-like function produces a document. We use [string], - as opposed to [arbitrary_string], because the strings that we produce will - never contain a newline character. *) - -let dsprintf format = - ksprintf string format - -(* ------------------------------------------------------------------------- *) - -(* Nicolas prefers using this code as opposed to just [sprintf "%g"] or - [sprintf "%f"]. The latter print [inf] and [-inf], whereas OCaml - understands [infinity] and [neg_infinity]. [sprintf "%g"] does not add a - trailing dot when the number happens to be an integral number. [sprintf - "%F"] seems to lose precision and ignores the precision modifier. *) - -let valid_float_lexeme (s : string) : string = - let l = String.length s in - let rec loop i = - if i >= l then - (* If we reach the end of the string and have found only characters in - the set '0' .. '9' and '-', then this string will be considered as an - integer literal by OCaml. Adding a trailing dot makes it a float - literal. *) - s ^ "." - else - match s.[i] with - | '0' .. '9' | '-' -> loop (i + 1) - | _ -> s - in loop 0 - -(* This function constructs a string representation of a floating point - number. This representation is supposed to be accepted by OCaml as a - valid floating point literal. *) - -let float_representation (f : float) : string = - match classify_float f with - | FP_nan -> - "nan" - | FP_infinite -> - if f < 0.0 then "neg_infinity" else "infinity" - | _ -> - (* Try increasing precisions and validate. *) - let s = sprintf "%.12g" f in - if f = float_of_string s then valid_float_lexeme s else - let s = sprintf "%.15g" f in - if f = float_of_string s then valid_float_lexeme s else - sprintf "%.18g" f - -(* ------------------------------------------------------------------------- *) - -(* A few constants and combinators, used below. *) - -let some = - string "Some" - -let none = - string "None" - -let lbracketbar = - string "[|" - -let rbracketbar = - string "|]" - -let seq1 opening separator closing = - surround_separate 2 0 (opening ^^ closing) opening (separator ^^ break 1) closing - -let seq2 opening separator closing = - surround_separate_map 2 1 (opening ^^ closing) opening (separator ^^ break 1) closing - -(* ------------------------------------------------------------------------- *) - -(* The following functions are printers for many types of OCaml values. *) - -(* There is no protection against cyclic values. *) - -type representation = - document - -let tuple = - seq1 lparen comma rparen - -let variant _ cons _ args = - match args with - | [] -> - !^cons - | _ :: _ -> - !^cons ^^ tuple args - -let record _ fields = - seq2 lbrace semi rbrace (fun (k, v) -> infix 2 1 equals !^k v) fields - -let option f = function - | None -> - none - | Some x -> - some ^^ tuple [f x] - -let list f xs = - seq2 lbracket semi rbracket f xs - -let array f xs = - seq2 lbracketbar semi rbracketbar f (Array.to_list xs) - -let ref f x = - record "ref" ["contents", f !x] - -let float f = - string (float_representation f) - -let int = - dsprintf "%d" - -let int32 = - dsprintf "%ld" - -let int64 = - dsprintf "%Ld" - -let nativeint = - dsprintf "%nd" - -let char = - dsprintf "%C" - -let bool = - dsprintf "%B" - -let string = - dsprintf "%S" - -let unknown tyname _ = - dsprintf "<abstr:%s>" tyname - diff --git a/src/pprint/src/PPrintOCaml.mli b/src/pprint/src/PPrintOCaml.mli deleted file mode 100644 index 119bca23..00000000 --- a/src/pprint/src/PPrintOCaml.mli +++ /dev/null @@ -1,90 +0,0 @@ -(**************************************************************************) -(* *) -(* PPrint *) -(* *) -(* François Pottier, Inria Paris *) -(* Nicolas Pouillard *) -(* *) -(* Copyright 2007-2017 Inria. All rights reserved. This file is *) -(* distributed under the terms of the GNU Library General Public *) -(* License, with an exception, as described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** A set of functions that construct representations of OCaml values. *) - -(** The string representations produced by these functions are supposed to be - accepted by the OCaml parser as valid values. *) - -(** The signature of this module is compatible with that expected by - the [camlp4] generator [Camlp4RepresentationGenerator]. *) - -(** These functions do {i not} distinguish between mutable and immutable - values. They do {i not} recognize sharing, and do {i not} incorporate a - protection against cyclic values. *) - -type constructor = string -type type_name = string -type record_field = string -type tag = int - -(** A representation of a value is a [PPrint] document. *) -type representation = - PPrintEngine.document - -(** [variant _ dc _ args] is a description of a constructed value whose data - constructor is [dc] and whose arguments are [args]. The other two - parameters are presently unused. *) -val variant : type_name -> constructor -> tag -> representation list -> representation - -(** [record _ fields] is a description of a record value whose fields are - [fields]. The other parameter is presently unused. *) -val record : type_name -> (record_field * representation) list -> representation - -(** [tuple args] is a description of a tuple value whose components are [args]. *) -val tuple : representation list -> representation - -(** [string s] is a representation of the string [s]. *) -val string : string -> representation - -(** [int i] is a representation of the integer [i]. *) -val int : int -> representation - -(** [int32 i] is a representation of the 32-bit integer [i]. *) -val int32 : int32 -> representation - -(** [int64 i] is a representation of the 64-bit integer [i]. *) -val int64 : int64 -> representation - -(** [nativeint i] is a representation of the native integer [i]. *) -val nativeint : nativeint -> representation - -(** [float f] is a representation of the floating-point number [f]. *) -val float : float -> representation - -(** [char c] is a representation of the character [c]. *) -val char : char -> representation - -(** [bool b] is a representation of the Boolenan value [b]. *) -val bool : bool -> representation - -(** [option f o] is a representation of the option [o], where the - representation of the element, if present, is computed by the function - [f]. *) -val option : ('a -> representation) -> 'a option -> representation - -(** [list f xs] is a representation of the list [xs], where the representation - of each element is computed by the function [f]. *) -val list : ('a -> representation) -> 'a list -> representation - -(** [array f xs] is a representation of the array [xs], where the - representation of each element is computed by the function [f]. *) -val array : ('a -> representation) -> 'a array -> representation - -(** [ref r] is a representation of the reference [r], where the - representation of the content is computed by the function [f]. *) -val ref : ('a -> representation) -> 'a ref -> representation - -(** [unknown t _] is a representation of an unknown value of type [t]. *) -val unknown : type_name -> 'a -> representation - diff --git a/src/pprint/src/PPrintRenderer.ml b/src/pprint/src/PPrintRenderer.ml deleted file mode 100644 index 3449d6c3..00000000 --- a/src/pprint/src/PPrintRenderer.ml +++ /dev/null @@ -1,37 +0,0 @@ -(**************************************************************************) -(* *) -(* PPrint *) -(* *) -(* François Pottier, Inria Paris *) -(* Nicolas Pouillard *) -(* *) -(* Copyright 2007-2017 Inria. All rights reserved. This file is *) -(* distributed under the terms of the GNU Library General Public *) -(* License, with an exception, as described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** A common signature for the multiple document renderers proposed by {!PPrintEngine}. *) - -module type RENDERER = sig - - (** Output channels. *) - type channel - - (** Documents. *) - type document - - (** [pretty rfrac width channel document] pretty-prints the document - [document] into the output channel [channel]. The parameter [width] is - the maximum number of characters per line. The parameter [rfrac] is the - ribbon width, a fraction relative to [width]. The ribbon width is the - maximum number of non-indentation characters per line. *) - val pretty: float -> int -> channel -> document -> unit - - (** [compact channel document] prints the document [document] to the output - channel [channel]. No indentation is used. All newline instructions are - respected, that is, no groups are flattened. *) - val compact: channel -> document -> unit - -end - diff --git a/src/pprint/src/PPrintTest.ml b/src/pprint/src/PPrintTest.ml deleted file mode 100644 index 37444127..00000000 --- a/src/pprint/src/PPrintTest.ml +++ /dev/null @@ -1,64 +0,0 @@ -(**************************************************************************) -(* *) -(* PPrint *) -(* *) -(* François Pottier, Inria Paris *) -(* Nicolas Pouillard *) -(* *) -(* Copyright 2007-2017 Inria. All rights reserved. This file is *) -(* distributed under the terms of the GNU Library General Public *) -(* License, with an exception, as described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open PPrint - -(* This is a test file. It is not, strictly speaking, part of the library. *) - -let paragraph (s : string) = - flow (break 1) (words s) - -let document = - prefix 2 1 - (string "TITLE:") - (string "PPrint") - ^^ - hardline - ^^ - prefix 2 1 - (string "AUTHORS:") - (utf8string "François Pottier and Nicolas Pouillard") - ^^ - hardline - ^^ - prefix 2 1 - (string "ABSTRACT:") - ( - paragraph "This is an adaptation of Daan Leijen's \"PPrint\" library, - which itself is based on the ideas developed by Philip Wadler in - \"A Prettier Printer\". For more information about Wadler's and Leijen's work, - please consult the following references:" - ^^ - nest 2 ( - twice (break 1) - ^^ - separate_map (break 1) (fun s -> nest 2 (url s)) [ - "http://www.cs.uu.nl/~daan/pprint.html"; - "http://homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf"; - ] - ) - ^^ - twice (break 1) - ^^ - paragraph "To install PPrint, type \"make -C src install\". ocamlfind is required." - ^^ - twice (break 1) - ^^ - paragraph "The documentation for PPrint is built by \"make doc\" and is found in the file doc/index.html." - ) - ^^ - hardline - -let () = - ToChannel.pretty 0.5 80 stdout document; - flush stdout diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 3a37d9ff..17dba718 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -93,7 +93,7 @@ type context = { kid_renames : kid KBindings.t; (* Plain tyvar -> tyvar renames, used to avoid variable/type variable name clashes *) (* Note that as well as these kid renames, we also attempt to replace entire - n_constraints with equivalent variables in doc_nc_prop and doc_nc_exp. *) + n_constraints with equivalent variables in doc_nc_exp. *) kid_id_renames : (id option) KBindings.t; (* tyvar -> argument renames *) kid_id_renames_rev : kid Bindings.t; (* reverse of kid_id_renames *) bound_nvars : KidSet.t; @@ -388,16 +388,12 @@ match nc1, nc2 with | _,_ -> mk_nc (NC_app (mk_id "iff",[arg_bool nc1; arg_bool nc2])) (* n_constraint functions are currently just Z3 functions *) -let doc_nc_fn_prop id = - match string_of_id id with - | "not" -> string "not" - | _ -> doc_id_type id - -(* n_constraint functions are currently just Z3 functions *) -let doc_nc_fn id = - match string_of_id id with - | "not" -> string "negb" - | s -> string s +let doc_nc_fn (Id_aux (id,_) as full_id) = + match id with + | Id "not" -> string "negb" + | Operator "-->" -> string "implb" + | Id "iff" -> string "Bool.eqb" + | _ -> doc_id full_id let merge_kid_count = KBindings.union (fun _ m n -> Some (m+n)) @@ -622,7 +618,7 @@ let rec doc_typ_fns ctx env = | Bool_boring -> string "bool" | Bool_complex (_,_,atom_nc) -> (* simplify won't introduce new kopts *) let var = mk_kid "_bool" in (* TODO collision avoid *) - let nc = nice_iff (nc_var var) atom_nc in + let nc = nice_iff atom_nc (nc_var var) in braces (separate space [doc_var ctx var; colon; string "bool"; ampersand; @@ -676,7 +672,7 @@ let rec doc_typ_fns ctx env = let length_constraint_pp = if KidSet.is_empty (KidSet.inter kid_set (nexp_frees m)) then None - else Some (separate space [len_pp; doc_var ctx var; equals; doc_nexp ctx m]) + else Some (separate space [len_pp; doc_var ctx var; string "=?"; doc_nexp ctx m]) in braces (separate space [doc_var ctx var; colon; tpp; @@ -694,7 +690,7 @@ let rec doc_typ_fns ctx env = let length_constraint_pp = if KidSet.is_empty (KidSet.inter kid_set (nexp_frees m)) then None - else Some (separate space [len_pp; doc_var ctx var; equals; doc_nexp ctx m]) + else Some (separate space [len_pp; doc_var ctx var; string "=?"; doc_nexp ctx m]) in braces (separate space [doc_var ctx var; colon; tpp; @@ -705,7 +701,7 @@ let rec doc_typ_fns ctx env = | Bool_boring -> string "bool" | Bool_complex (kopts,nc,atom_nc) -> let var = mk_kid "_bool" in (* TODO collision avoid *) - let nc = nice_and (nice_iff (nc_var var) atom_nc) nc in + let nc = nice_and (nice_iff atom_nc (nc_var var)) nc in braces (separate space [doc_var ctx var; colon; string "bool"; ampersand; @@ -773,94 +769,26 @@ let rec doc_typ_fns ctx env = | A_typ t -> app_typ true t | A_nexp n -> doc_nexp ctx n | A_order o -> empty - | A_bool nc -> doc_nc_prop ~prop_vars ~top:false ctx env nc + | A_bool nc -> parens (doc_nc_exp ctx env nc) in typ', atomic_typ, doc_typ_arg and doc_typ ctx env = let f,_,_ = doc_typ_fns ctx env in f and doc_atomic_typ ctx env = let _,f,_ = doc_typ_fns ctx env in f and doc_typ_arg ctx env = let _,_,f = doc_typ_fns ctx env in f -and doc_arithfact ?(prop_vars=false) ctxt env ?(exists = []) ?extra nc = - let prop = doc_nc_prop ~prop_vars ctxt env nc in +and doc_arithfact ctxt env ?(exists = []) ?extra nc = + let prop = doc_nc_exp ctxt env nc in let prop = match extra with | None -> prop - | Some pp -> separate space [pp; string "/\\"; parens prop] - in - let prop = - match exists with - | [] -> prop - | _ -> separate space ([string "exists"]@(List.map (doc_var ctxt) exists)@[comma; prop]) + | Some pp -> separate space [parens pp; string "&&"; parens prop] in - string "ArithFact" ^^ space ^^ parens prop - -(* Follows Coq precedence levels *) -and doc_nc_prop ?(top = true) ?(prop_vars = false) ctx env nc = - let locals = Env.get_locals env |> Bindings.bindings in - let nc = Env.expand_constraint_synonyms env nc in - let doc_nc_var varpp = - if prop_vars then varpp else doc_op equals varpp (string "true") - in - let nc_id_map = - List.fold_left - (fun m (v,(_,Typ_aux (typ,_))) -> - match typ with - | Typ_app (id, [A_aux (A_bool nc,_)]) when string_of_id id = "atom_bool" -> - (flatten_nc nc, v)::m - | _ -> m) [] locals - in - let rec newnc f nc = - let ncs = flatten_nc nc in - let candidates = - Util.map_filter (fun (ncs',id) -> Util.option_map (fun x -> x,id) (list_contains NC.compare ncs ncs')) nc_id_map - in - match List.sort (fun (l,_) (l',_) -> compare l l') candidates with - | ([],id)::_ -> parens (doc_nc_var (doc_id id)) - | ((h::t),id)::_ -> parens (doc_op (string "/\\") (parens (doc_nc_var (doc_id id))) (l80 (List.fold_left nc_and h t))) - | [] -> f nc - and l85 (NC_aux (nc,_) as nc_full) = - match nc with - | NC_or (nc1, nc2) -> doc_op (string "\\/") (newnc l80 nc1) (newnc l85 nc2) - | _ -> l80 nc_full - and l80 (NC_aux (nc,_) as nc_full) = - match nc with - | NC_and (nc1, nc2) -> doc_op (string "/\\") (newnc l70 nc1) (newnc l80 nc2) - | _ -> l70 nc_full - and l70 (NC_aux (nc,_) as nc_full) = - match nc with - | NC_equal (ne1, ne2) -> doc_op equals (doc_nexp ctx ne1) (doc_nexp ctx ne2) - | NC_var kid -> doc_nc_var (doc_nexp ctx (nvar kid)) - | NC_bounded_ge (ne1, ne2) -> doc_op (string ">=") (doc_nexp ctx ne1) (doc_nexp ctx ne2) - | NC_bounded_gt (ne1, ne2) -> doc_op (string ">") (doc_nexp ctx ne1) (doc_nexp ctx ne2) - | NC_bounded_le (ne1, ne2) -> doc_op (string "<=") (doc_nexp ctx ne1) (doc_nexp ctx ne2) - | NC_bounded_lt (ne1, ne2) -> doc_op (string "<") (doc_nexp ctx ne1) (doc_nexp ctx ne2) - | NC_not_equal (ne1, ne2) -> doc_op (string "<>") (doc_nexp ctx ne1) (doc_nexp ctx ne2) - | _ -> l10 nc_full - and l10 (NC_aux (nc,_) as nc_full) = - match nc with - | NC_set (kid, is) -> - separate space [string "In"; doc_var ctx kid; - brackets (separate (string "; ") - (List.map (fun i -> string (Nat_big_num.to_string i)) is))] - | NC_app (f,args) -> separate space (doc_nc_fn_prop f::List.map (doc_typ_arg ~prop_vars ctx env) args) - | _ -> l0 nc_full - and l0 (NC_aux (nc,_) as nc_full) = - match nc with - | NC_true -> string "True" - | NC_false -> string "False" - | NC_set _ - | NC_app _ - | NC_var _ - | NC_or _ - | NC_and _ - | NC_equal _ - | NC_bounded_ge _ - | NC_bounded_gt _ - | NC_bounded_le _ - | NC_bounded_lt _ - | NC_not_equal _ -> parens (l85 nc_full) - in if top then newnc l85 nc else newnc l0 nc + let prop = prop in + match exists with + | [] -> string "ArithFact" ^^ space ^^ parens prop + | _ -> string "ArithFactP" ^^ space ^^ + parens (separate space ([string "exists"]@(List.map (doc_var ctxt) exists)@[comma; prop; equals; string "true"])) (* Follows Coq precedence levels *) -let rec doc_nc_exp ctx env nc = +and doc_nc_exp ctx env nc = let locals = Env.get_locals env |> Bindings.bindings in let nc = Env.expand_constraint_synonyms env nc in let nc_id_map = @@ -871,6 +799,9 @@ let rec doc_nc_exp ctx env nc = (flatten_nc nc, v)::m | _ -> m) [] locals in + (* Look for variables in the environment which exactly express the nc, and use + them instead. As well as often being shorter, this avoids unbound type + variables added by Sail's type checker. *) let rec newnc f nc = let ncs = flatten_nc nc in let candidates = @@ -903,10 +834,16 @@ let rec doc_nc_exp ctx env nc = separate space [string "member_Z_list"; doc_var ctx kid; brackets (separate (string "; ") (List.map (fun i -> string (Nat_big_num.to_string i)) is))] + | NC_app (f,args) -> separate space (doc_nc_fn f::List.map doc_typ_arg_exp args) + | _ -> l0 nc_full + and l0 (NC_aux (nc,_) as nc_full) = + match nc with | NC_true -> string "true" | NC_false -> string "false" - | NC_app (f,args) -> separate space (doc_nc_fn f::List.map (doc_typ_arg_exp ctx env) args) | NC_var kid -> doc_nexp ctx (nvar kid) + | NC_not_equal _ + | NC_set _ + | NC_app _ | NC_equal _ | NC_bounded_ge _ | NC_bounded_gt _ @@ -914,13 +851,13 @@ let rec doc_nc_exp ctx env nc = | NC_bounded_lt _ | NC_or _ | NC_and _ -> parens (l70 nc_full) - in newnc l70 nc -and doc_typ_arg_exp ctx env (A_aux (arg,l)) = - match arg with - | A_nexp nexp -> doc_nexp ctx nexp - | A_bool nc -> doc_nc_exp ctx env nc - | A_order _ | A_typ _ -> + and doc_typ_arg_exp (A_aux (arg,l)) = + match arg with + | A_nexp nexp -> doc_nexp ctx nexp + | A_bool nc -> newnc l0 nc + | A_order _ | A_typ _ -> raise (Reporting.err_unreachable l __POS__ "Tried to pass Type or Order kind to SMT function") + in newnc l70 nc (* Check for variables in types that would be pretty-printed and are not bound in the val spec of the function. *) @@ -971,8 +908,9 @@ let doc_lit (L_aux(lit,l)) = let s = Big_int.to_string i in let ipp = utf8string s in if Big_int.less i Big_int.zero then parens ipp else ipp - | L_hex n -> failwith "Shouldn't happen" (*"(num_to_vec " ^ ("0x" ^ n) ^ ")" (*shouldn't happen*)*) - | L_bin n -> failwith "Shouldn't happen" (*"(num_to_vec " ^ ("0b" ^ n) ^ ")" (*shouldn't happen*)*) + (* Not a typo, the bbv hex notation uses the letter O *) + | L_hex n -> utf8string ("Ox\"" ^ n ^ "\"") + | L_bin n -> utf8string ("'b\"" ^ n ^ "\"") | L_undef -> utf8string "(Fail \"undefined value of unsupported type\")" | L_string s -> utf8string ("\"" ^ (coq_escape_string s) ^ "\"") @@ -1024,7 +962,7 @@ let doc_quant_item_constr ?(prop_vars=false) ctx env delimit (QI_aux (qi,_)) = match qi with | QI_id _ -> None | QI_constant _ -> None - | QI_constraint nc -> Some (bquote ^^ braces (doc_arithfact ~prop_vars ctx env nc)) + | QI_constraint nc -> Some (bquote ^^ braces (doc_arithfact ctx env nc)) (* At the moment these are all anonymous - when used we rely on Coq to fill them in. *) @@ -1187,8 +1125,9 @@ let rec doc_pat ctxt apat_needed exists_as_pairs (P_aux (p,(l,annot)) as pat, ty | _::_::_, [Typ_aux (Typ_tup typs,_)] -> typs | _,_ -> arg_typs in - let ppp = doc_unop (doc_id_ctor id) - (parens (separate_map comma (doc_pat ctxt true true) (List.combine pats arg_typs))) in + let pats_pp = separate_map comma (doc_pat ctxt true true) (List.combine pats arg_typs) in + let pats_pp = match pats with [_] -> pats_pp | _ -> parens pats_pp in + let ppp = doc_unop (doc_id_ctor id) pats_pp in if apat_needed then parens ppp else ppp end | P_app(id, []) -> doc_id_ctor id @@ -1877,7 +1816,11 @@ let doc_exp, doc_let = in let epp = if is_ctor - then group (hang 2 (call ^^ break 1 ^^ parens (flow (comma ^^ break 1) (List.map2 (doc_arg false) args arg_typs)))) + then + let argspp = match args, arg_typs with + | [arg], [arg_typ] -> doc_arg true arg arg_typ + | _, _ -> parens (flow (comma ^^ break 1) (List.map2 (doc_arg false) args arg_typs)) + in group (hang 2 (call ^^ break 1 ^^ argspp)) else let argspp = List.map2 (doc_arg true) args arg_typs in let all = @@ -2333,7 +2276,8 @@ let doc_exp, doc_let = "unsupported internal expression encountered while pretty-printing") and if_exp ctxt (elseif : bool) c t e = let if_pp = string (if elseif then "else if" else "if") in - let c_pp = top_exp ctxt true c in + let use_sumbool = condition_produces_constraint ctxt c in + let c_pp = top_exp ctxt use_sumbool c in let t_pp = top_exp ctxt false t in let else_pp = match e with | E_aux (E_if (c', t', e'), _) @@ -2347,8 +2291,8 @@ let doc_exp, doc_let = in (prefix 2 1 (soft_surround 2 1 if_pp - ((if condition_produces_constraint ctxt c then string "sumbool_of_bool" ^^ space else empty) - ^^ parens c_pp) (string "then")) + (if use_sumbool then string "sumbool_of_bool" ^/^ c_pp else c_pp) + (string "then")) t_pp) ^^ break 1 ^^ else_pp @@ -2366,7 +2310,9 @@ let doc_exp, doc_let = prefix 2 1 (separate space [string "let"; doc_id id; colon; doc_typ ctxt (env_of e) typ; coloneq]) (top_exp ctxt false e) - | LB_val(P_aux (P_typ (typ,P_aux (P_id id,_)),_),e) + | (LB_val(P_aux (P_typ (_,P_aux (P_id id,_)),_),e) + | LB_val(P_aux (P_var (P_aux (P_id id,_),_),_), e) + | LB_val(P_aux (P_typ (_,P_aux (P_var (P_aux (P_id id,_),_),_)),_), e)) when (* is auto decomposed *) not (is_enum (env_of e) id) -> prefix 2 1 @@ -2515,9 +2461,9 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = let idpp = doc_id_type id in doc_op coloneq (separate space [string "Definition"; idpp; - doc_typquant_items ~prop_vars:true empty_ctxt Env.empty parens typq; - colon; string "Prop"]) - (doc_nc_prop ~prop_vars:true empty_ctxt Env.empty nc) ^^ dot ^^ hardline ^^ + doc_typquant_items empty_ctxt Env.empty parens typq; + colon; string "bool"]) + (doc_nc_exp empty_ctxt Env.empty nc) ^^ dot ^^ hardline ^^ separate space [string "Hint Unfold"; idpp; colon; string "sail."] ^^ twice hardline | TD_abbrev _ -> empty (* TODO? *) @@ -2538,24 +2484,31 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = mk_typ (Typ_app (id, targs)) | TypQ_aux (TypQ_no_forall, _) -> mk_id_typ id in let fs_doc = group (separate_map (break 1) f_pp fs) in + let type_id_pp = doc_id_type id in + let match_parameters = + let (kopts,_) = quant_split typq in + match kopts with + | [] -> empty + | _ -> space ^^ separate_map space (fun _ -> underscore) kopts + in let doc_update_field (_,fid) = let idpp = fname fid in - let otherfield (_,fid') = - if Id.compare fid fid' == 0 then None else - let idpp = fname fid' in - Some (separate space [idpp; string ":="; idpp; string "r"]) + let pp_field alt i (_,fid') = + if Id.compare fid fid' == 0 then string alt else + let id = "f" ^ string_of_int i in + string id in match fs with | [_] -> string "Notation \"{[ r 'with' '" ^^ idpp ^^ string "' := e ]}\" :=" ^//^ string "{| " ^^ idpp ^^ string " := e |} (only parsing)." | _ -> - string "Notation \"{[ r 'with' '" ^^ idpp ^^ string "' := e ]}\" := {|" ^//^ - idpp ^^ string " := e;" ^/^ separate (semi ^^ break 1) (Util.map_filter otherfield fs) ^/^ - string "|}" ^^ dot + string "Notation \"{[ r 'with' '" ^^ idpp ^^ string "' := e ]}\" :=" ^//^ + string "match r with Build_" ^^ type_id_pp ^^ match_parameters ^^ space ^^ separate space (List.mapi (pp_field "_") fs) ^^ string " =>" ^//^ + string "Build_" ^^ type_id_pp ^^ match_parameters ^^ space ^^ separate space (List.mapi (pp_field "e") fs) ^//^ + string "end" ^^ dot in let updates_pp = separate hardline (List.map doc_update_field fs) in - let id_pp = doc_id_type id in let numfields = List.length fs in let intros_pp s = string " intros [" ^^ @@ -2564,8 +2517,8 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = in let eq_pp = if IdSet.mem id generic_eq_types then - string "Instance Decidable_eq_" ^^ id_pp ^^ space ^^ colon ^/^ - string "forall (x y : " ^^ id_pp ^^ string "), Decidable (x = y)." ^^ + string "Instance Decidable_eq_" ^^ type_id_pp ^^ space ^^ colon ^/^ + string "forall (x y : " ^^ type_id_pp ^^ string "), Decidable (x = y)." ^^ hardline ^^ intros_pp "x" ^^ intros_pp "y" ^^ separate hardline (list_init numfields (fun n -> @@ -2576,9 +2529,9 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = string "Defined." ^^ twice hardline else empty in - let reset_implicits_pp = doc_reset_implicits id_pp typq in + let reset_implicits_pp = doc_reset_implicits type_id_pp typq in doc_op coloneq - (separate space [string "Record"; id_pp; doc_typquant_items empty_ctxt Env.empty braces typq]) + (separate space [string "Record"; type_id_pp; doc_typquant_items empty_ctxt Env.empty braces typq]) ((*doc_typquant typq*) (braces (space ^^ align fs_doc ^^ space))) ^^ dot ^^ hardline ^^ reset_implicits_pp ^^ hardline ^^ eq_pp ^^ updates_pp ^^ twice hardline @@ -2743,7 +2696,7 @@ let rec atom_constraint ctxt (pat, typ) = None | _ -> Some (bquote ^^ braces (string "ArithFact" ^^ space ^^ - parens (doc_op equals (doc_id id) (doc_nexp ctxt nexp))))) + parens (doc_op (string "=?") (doc_id id) (doc_nexp ctxt nexp))))) | P_aux (P_typ (_,p),_), _ -> atom_constraint ctxt (p, typ) | _ -> None @@ -3205,7 +3158,7 @@ let doc_axiom_typschm typ_env l (tqs,typ) = let v = fresh_var () in parens (v ^^ string " : Z") ^/^ bquote ^^ braces (string "ArithFact " ^^ - parens (v ^^ string " = " ^^ string (Big_int.to_string n))) + parens (v ^^ string " =? " ^^ string (Big_int.to_string n))) | _ -> match Type_check.destruct_atom_bool typ_env typ with | Some (NC_aux (NC_var kid,_)) when KidSet.mem kid args -> @@ -3377,6 +3330,7 @@ try hardline; string "Open Scope string."; hardline; string "Open Scope bool."; hardline; + string "Open Scope Z."; hardline; hardline; hardline; separate empty (List.map doc_def defs); diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index d399ec29..993934f5 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -415,22 +415,24 @@ let doc_tannot_lem ctxt env eff typ = let min_int32 = Big_int.of_int64 (Int64.of_int32 Int32.min_int) let max_int32 = Big_int.of_int64 (Int64.of_int32 Int32.max_int) -let doc_lit_lem (L_aux(lit,l)) = +let rec doc_lit_lem (L_aux(lit,l)) = match lit with | L_unit -> utf8string "()" | L_zero -> utf8string "B0" | L_one -> utf8string "B1" | L_false -> utf8string "false" | L_true -> utf8string "true" - | L_num i when Big_int.less_equal min_int32 i && Big_int.less_equal i max_int32 -> + | L_num i -> let ipp = Big_int.to_string i in utf8string ( if Big_int.less i Big_int.zero then "((0"^ipp^"):ii)" else "("^ipp^":ii)") - | L_num i -> - utf8string (Printf.sprintf "(integerOfString \"%s\")" (Big_int.to_string i)) - | L_hex n -> failwith "Shouldn't happen" (*"(num_to_vec " ^ ("0x" ^ n) ^ ")" (*shouldn't happen*)*) - | L_bin n -> failwith "Shouldn't happen" (*"(num_to_vec " ^ ("0b" ^ n) ^ ")" (*shouldn't happen*)*) + | L_hex n when !opt_mwords -> utf8string ("0x" ^ n) + | L_bin n when !opt_mwords -> utf8string ("0b" ^ n) + | L_hex _ | L_bin _ -> + vector_string_to_bit_list (L_aux(lit,l)) + |> flow_map (semi ^^ break 0) doc_lit_lem + |> group |> align |> brackets | L_undef -> utf8string "(return (failwith \"undefined value of unsupported type\"))" | L_string s -> utf8string ("\"" ^ (String.escaped s) ^ "\"") @@ -872,8 +874,14 @@ let doc_exp_lem, doc_let_lem = else if Env.is_register id env && is_regtyp (typ_of full_exp) env then doc_id_lem (append_id id "_ref") else if is_ctor env id then doc_id_lem_ctor id else doc_id_lem id - | E_lit lit -> doc_lit_lem lit - | E_cast(typ,e) -> expV aexp_needed e + | E_lit lit -> + let env = env_of full_exp in + let typ = Env.expand_synonyms env (typ_of full_exp) in + let eff = effect_of full_exp in + if typ_needs_printed typ + then parens (doc_lit_lem lit ^^ doc_tannot_lem ctxt env (effectful eff) typ) + else doc_lit_lem lit + | E_cast (typ,e) -> expV aexp_needed e (*parens (expN e ^^ doc_tannot_lem ctxt (env_of full_exp) (effectful (effect_of full_exp)) typ)*) | E_tuple exps -> parens (align (group (separate_map (comma ^^ break 1) expN exps))) | E_record fexps -> diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index b3675263..7e98f4e3 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -170,6 +170,8 @@ let rec doc_nc nc = in atomic_nc (constraint_simp nc) +and doc_effects effs = braces (separate (comma ^^ space) (List.map (fun be -> string (string_of_base_effect be)) effs)) + and doc_typ ?(simple=false) (Typ_aux (typ_aux, l)) = match typ_aux with | Typ_id id -> doc_id id @@ -194,13 +196,14 @@ and doc_typ ?(simple=false) (Typ_aux (typ_aux, l)) = | Typ_fn (typs, typ, Effect_aux (Effect_set [], _)) -> separate space [doc_arg_typs typs; string "->"; doc_typ typ] | Typ_fn (typs, typ, Effect_aux (Effect_set effs, _)) -> - let ocaml_eff = braces (separate (comma ^^ space) (List.map (fun be -> string (string_of_base_effect be)) effs)) in if simple then separate space [doc_arg_typs typs; string "->"; doc_typ ~simple:simple typ] else - separate space [doc_arg_typs typs; string "->"; doc_typ typ; string "effect"; ocaml_eff] - | Typ_bidir (typ1, typ2) -> + separate space [doc_arg_typs typs; string "->"; doc_typ typ; string "effect"; doc_effects effs] + | Typ_bidir (typ1, typ2, Effect_aux (Effect_set [], _)) -> separate space [doc_typ typ1; string "<->"; doc_typ typ2] + | Typ_bidir (typ1, typ2, Effect_aux (Effect_set effs, _)) -> + separate space [doc_typ typ1; string "<->"; doc_typ typ2; string "effect"; doc_effects effs] | Typ_internal_unknown -> raise (Reporting.err_unreachable l __POS__ "escaped Typ_internal_unknown") and doc_typ_arg (A_aux (ta_aux, _)) = match ta_aux with @@ -502,7 +505,11 @@ and doc_atomic_exp (E_aux (e_aux, _) as exp) = brackets (separate space [doc_exp exp1; string "with"; doc_atomic_exp exp2; equals; doc_exp exp3]) | E_vector_update_subrange (exp1, exp2, exp3, exp4) -> brackets (separate space [doc_exp exp1; string "with"; doc_atomic_exp exp2; string ".."; doc_atomic_exp exp3; equals; doc_exp exp4]) - | E_internal_value v -> string (Value.string_of_value v (* |> Util.green |> Util.clear *)) + | E_internal_value v -> + if !Interactive.opt_interactive then + string (Value.string_of_value v |> Util.green |> Util.clear) + else + string (Value.string_of_value v) | _ -> parens (doc_exp exp) and doc_fexps fexps = separate_map (comma ^^ space) doc_fexp fexps @@ -623,6 +630,12 @@ let doc_field (typ, id) = let doc_union (Tu_aux (Tu_ty_id (typ, id), l)) = separate space [doc_id id; colon; doc_typ typ] +let rec doc_index_range (BF_aux (ir, _)) = + match ir with + | BF_single i -> doc_nexp i + | BF_range (i, j) -> doc_nexp i ^^ string ".." ^^ doc_nexp j + | BF_concat (i, j) -> doc_index_range i ^^ comma ^^ space ^^ doc_index_range j + let doc_typ_arg_kind sep (A_aux (aux, _)) = match aux with | A_nexp _ -> space ^^ string sep ^^ space ^^string "Int" @@ -651,7 +664,10 @@ let doc_typdef (TD_aux(td,_)) = match td with | 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] - | TD_bitfield _ -> string "BITFIELD" (* should be rewritten *) + | TD_bitfield (id, typ, fields) -> + let doc_field (id, range) = separate space [doc_id id; colon; doc_index_range range] in + doc_op equals (separate space [string "bitfield"; doc_id id; colon; doc_typ typ]) + (surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_field fields) rbrace) let doc_spec ?comment:(comment=false) (VS_aux (v, annot)) = let doc_extern ext = diff --git a/src/process_file.ml b/src/process_file.ml index eeb7c0d7..d2a86595 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -56,6 +56,8 @@ let opt_isa_output_dir = ref None let opt_coq_output_dir = ref None let opt_alt_modules_coq = ref ([]:string list) let opt_alt_modules2_coq = ref ([]:string list) +let opt_memo_z3 = ref false +let opt_file_out : string option ref = ref None type out_type = | Lem_out of string list @@ -71,7 +73,6 @@ let get_lexbuf f = lexbuf, in_chan let parse_file ?loc:(l=Parse_ast.Unknown) (f : string) : Parse_ast.defs = - let open Reporting in try let lexbuf, in_chan = get_lexbuf f in begin @@ -82,12 +83,12 @@ let parse_file ?loc:(l=Parse_ast.Unknown) (f : string) : Parse_ast.defs = | Parser.Error -> let pos = Lexing.lexeme_start_p lexbuf in let tok = Lexing.lexeme lexbuf in - raise (Fatal_error (Err_syntax (pos, "current token: " ^ tok))) - | Lexer.LexError(s,p) -> - raise (Fatal_error (Err_lex (p, s))) + raise (Reporting.err_syntax pos ("current token: " ^ tok)) + | Lexer.LexError (s, p) -> + raise (Reporting.err_lex p s) end with - | Sys_error err -> raise (err_general l err) + | Sys_error err -> raise (Reporting.err_general l err) (* Simple preprocessor features for conditional file loading *) module StringSet = Set.Make(String) @@ -239,12 +240,6 @@ let rec preprocess opts = function let preprocess_ast opts (Parse_ast.Defs defs) = Parse_ast.Defs (preprocess opts defs) -let load_file_no_check opts order f = Initial_check.process_ast (preprocess_ast opts (parse_file f)) - -let load_file opts order env f = - let ast = Initial_check.process_ast (preprocess_ast opts (parse_file f)) in - Type_error.check env ast - let opt_just_check = ref false let opt_ddump_tc_ast = ref false let opt_ddump_rewrite_ast = ref None @@ -257,6 +252,33 @@ let check_ast (env : Type_check.Env.t) (defs : unit Ast.defs) : Type_check.tanno let () = if !opt_just_check then exit 0 else () in (ast, env) +let load_files ?check:(check=false) options type_envs files = + if !opt_memo_z3 then Constraint.load_digests () else (); + + let t = Profile.start () in + let parsed = List.map (fun f -> (f, parse_file f)) files in + let ast = + List.fold_right (fun (_, Parse_ast.Defs ast_nodes) (Parse_ast.Defs later_nodes) + -> Parse_ast.Defs (ast_nodes@later_nodes)) parsed (Parse_ast.Defs []) in + let ast = preprocess_ast options ast in + let ast = Initial_check.process_ast ~generate:(not check) ast in + (* The separate loop measures declarations would be awkward to type check, so + move them into the definitions beforehand. *) + let ast = Rewrites.move_loop_measures ast in + Profile.finish "parsing" t; + + let t = Profile.start () in + let (ast, type_envs) = check_ast type_envs ast in + Profile.finish "type checking" t; + + if !opt_memo_z3 then Constraint.save_digests () else (); + + let out_name = match !opt_file_out with + | None when parsed = [] -> "out.sail" + | None -> fst (List.hd parsed) + | Some f -> f ^ ".sail" in + + (out_name, ast, type_envs) let open_output_with_check opt_dir file_name = let (temp_file_name, o) = Filename.open_temp_file "ll_temp" "" in @@ -349,12 +371,12 @@ let output_coq opt_dir filename alt_modules alt_modules2 libs defs = (match alt_modules with | [] -> base_imports_default | _ -> Str.split (Str.regexp "[ \t]+") (String.concat " " alt_modules) - ) in + ) in let alt_modules2_imports = (match alt_modules2 with | [] -> [] | _ -> Str.split (Str.regexp "[ \t]+") (String.concat " " alt_modules2) - ) in + ) in let ((ot,_,_,_) as ext_ot) = open_output_with_check_unformatted opt_dir (filename ^ "_types" ^ ".v") in let ((o,_,_,_) as ext_o) = @@ -414,3 +436,10 @@ let rewrite_ast_initial env = rewrite env [("initial", fun env defs -> Rewriter. let rewrite_ast_target tgt env = rewrite env (Rewrites.rewrite_defs_target tgt) let rewrite_ast_check env = rewrite env Rewrites.rewrite_defs_check + +let descatter type_envs ast = + let ast = Scattered.descatter ast in + let ast, type_envs = rewrite_ast_initial type_envs ast in + (* Recheck after descattering so that the internal type environments + always have complete variant types *) + Type_error.check Type_check.initial_env ast diff --git a/src/process_file.mli b/src/process_file.mli index fa0aeb31..d1fa2cb8 100644 --- a/src/process_file.mli +++ b/src/process_file.mli @@ -61,9 +61,8 @@ val rewrite_ast_initial : Type_check.Env.t -> Type_check.tannot Ast.defs -> Type val rewrite_ast_target : string -> Type_check.Env.t -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs * Type_check.Env.t val rewrite_ast_check : Type_check.Env.t -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs * Type_check.Env.t -val load_file_no_check : (Arg.key * Arg.spec * Arg.doc) list -> Ast.order -> string -> unit Ast.defs -val load_file : (Arg.key * Arg.spec * Arg.doc) list -> Ast.order -> Type_check.Env.t -> string -> Type_check.tannot Ast.defs * Type_check.Env.t - +val opt_file_out : string option ref +val opt_memo_z3 : bool ref val opt_just_check : bool ref val opt_ddump_tc_ast : bool ref val opt_ddump_rewrite_ast : ((string * int) option) ref @@ -90,3 +89,7 @@ val output : files existed before. If it is set to [false] and an output file already exists, the output file is only updated, if its content really changes. *) val always_replace_files : bool ref + +val load_files : ?check:bool -> (Arg.key * Arg.spec * Arg.doc) list -> Type_check.Env.t -> string list -> (string * Type_check.tannot Ast.defs * Type_check.Env.t) + +val descatter : Type_check.Env.t -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs * Type_check.Env.t diff --git a/src/property.ml b/src/property.ml index 955e755d..83594f4f 100644 --- a/src/property.ml +++ b/src/property.ml @@ -132,7 +132,7 @@ type query = | Q_or of query list let default_query = - Q_or [Q_and [Q_all Assertion; Q_all Return; Q_not (Q_exist Match)]; Q_exist Overflow; Q_not (Q_all Assumption)] + Q_or [Q_and [Q_not (Q_exist Assertion); Q_all Return; Q_not (Q_exist Match)]; Q_exist Overflow; Q_not (Q_all Assumption)] module Event = struct type t = event diff --git a/src/reporting.ml b/src/reporting.ml index e89ce396..d5e3003c 100644 --- a/src/reporting.ml +++ b/src/reporting.ml @@ -132,19 +132,19 @@ let print_err l m1 m2 = type error = | Err_general of Parse_ast.l * string - | Err_unreachable of Parse_ast.l * (string * int * int * int) * string + | Err_unreachable of Parse_ast.l * (string * int * int * int) * Printexc.raw_backtrace * string | Err_todo of Parse_ast.l * string | Err_syntax of Lexing.position * string | Err_syntax_loc of Parse_ast.l * string | Err_lex of Lexing.position * string | Err_type of Parse_ast.l * string -let issues = "\n\nPlease report this as an issue on GitHub at https://github.com/rems-project/sail/issues" +let issues = "\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", Loc l, m) - | Err_unreachable (l, (file, line, _, _), m) -> - (Printf.sprintf "Internal error: Unreachable code (at \"%s\" line %d)" file line, Loc l, m ^ issues) + | Err_unreachable (l, (file, line, _, _), backtrace, m) -> + (Printf.sprintf "Internal error: Unreachable code (at \"%s\" line %d)" file line, Loc l, m ^ "\n\n" ^ Printexc.raw_backtrace_to_string backtrace ^ issues) | Err_todo (l, m) -> ("Todo", Loc l, m) | Err_syntax (p, m) -> ("Syntax error", Pos p, m) | Err_syntax_loc (l, m) -> ("Syntax error", Loc l, m) @@ -155,10 +155,14 @@ exception Fatal_error of error (* Abbreviations for the very common cases *) let err_todo l m = Fatal_error (Err_todo (l, m)) -let err_unreachable l ocaml_pos m = Fatal_error (Err_unreachable (l, ocaml_pos, m)) +let err_unreachable l ocaml_pos m = + let backtrace = Printexc.get_callstack 10 in + Fatal_error (Err_unreachable (l, ocaml_pos, backtrace, 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 l m = Fatal_error (Err_type (l, m)) +let err_syntax p m = Fatal_error (Err_syntax (p, m)) let err_syntax_loc l m = Fatal_error (Err_syntax_loc (l, m)) +let err_lex p m = Fatal_error (Err_lex (p, m)) let unreachable l pos msg = raise (err_unreachable l pos msg) diff --git a/src/reporting.mli b/src/reporting.mli index 0bdff5ca..e0744c66 100644 --- a/src/reporting.mli +++ b/src/reporting.mli @@ -74,8 +74,7 @@ val simp_loc : Ast.l -> (Lexing.position * Lexing.position) option val short_loc_to_string : Parse_ast.l -> string (** [print_err fatal print_loc_source l head mes] prints an error / warning message to - std-err. It starts with printing location information stored in [l] - It then prints "head: mes". If [fatal] is set, the program exists with error-code 1 afterwards. + std-err. *) val print_err : Parse_ast.l -> string -> string -> unit @@ -83,13 +82,13 @@ val print_err : Parse_ast.l -> string -> string -> unit (** Errors stop execution and print a message; they typically have a location and message. *) -type error = +type error = private (** General errors, used for multi purpose. If you are unsure, use this one. *) | Err_general of Parse_ast.l * string (** Unreachable errors should never be thrown. It means that some code was excuted that the programmer thought of as unreachable *) - | Err_unreachable of Parse_ast.l * (string * int * int * int) * string + | Err_unreachable of Parse_ast.l * (string * int * int * int) * Printexc.raw_backtrace * string (** [Err_todo] indicates that some feature is unimplemented; it should be built using [err_todo]. *) | Err_todo of Parse_ast.l * string @@ -101,20 +100,13 @@ type error = exception Fatal_error of error -(** [err_todo l m] is an abreviatiation for [Fatal_error (Err_todo (l, m))] *) val err_todo : Parse_ast.l -> string -> exn - -(** [err_general l m] is an abreviatiation for [Fatal_error (Err_general (b, l, m))] *) val err_general : Parse_ast.l -> string -> exn - -(** [err_unreachable l __POS__ m] is an abreviatiation for [Fatal_error (Err_unreachable (l, __POS__, m))] *) val err_unreachable : Parse_ast.l -> (string * int * int * int) -> string -> exn - -(** [err_typ l m] is an abreviatiation for [Fatal_error (Err_type (l, m))] *) val err_typ : Parse_ast.l -> string -> exn - -(** [err_syntax_loc] is an abbreviation for [Fatal_error (Err_syntax_loc (l, m))] *) +val err_syntax : Lexing.position -> string -> exn val err_syntax_loc : Parse_ast.l -> string -> exn +val err_lex : Lexing.position -> string -> exn val unreachable : Parse_ast.l -> (string * int * int * int) -> string -> 'a diff --git a/src/rewrites.ml b/src/rewrites.ml index ad0ed836..863f8115 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -145,40 +145,6 @@ let lexp_is_effectful (LEXP_aux (_, (_, annot))) = match destruct_tannot annot w | Some (_, _, eff) -> effectful_effs eff | _ -> false -let explode s = - let rec exp i l = if i < 0 then l else exp (i - 1) (s.[i] :: l) in - exp (String.length s - 1) [] - -let vector_string_to_bit_list l lit = - - let hexchar_to_binlist = function - | '0' -> ['0';'0';'0';'0'] - | '1' -> ['0';'0';'0';'1'] - | '2' -> ['0';'0';'1';'0'] - | '3' -> ['0';'0';'1';'1'] - | '4' -> ['0';'1';'0';'0'] - | '5' -> ['0';'1';'0';'1'] - | '6' -> ['0';'1';'1';'0'] - | '7' -> ['0';'1';'1';'1'] - | '8' -> ['1';'0';'0';'0'] - | '9' -> ['1';'0';'0';'1'] - | 'A' -> ['1';'0';'1';'0'] - | 'B' -> ['1';'0';'1';'1'] - | 'C' -> ['1';'1';'0';'0'] - | 'D' -> ['1';'1';'0';'1'] - | 'E' -> ['1';'1';'1';'0'] - | 'F' -> ['1';'1';'1';'1'] - | _ -> raise (Reporting.err_unreachable l __POS__ "hexchar_to_binlist given unrecognized character") in - - let s_bin = match lit with - | L_hex s_hex -> List.flatten (List.map hexchar_to_binlist (explode (String.uppercase_ascii s_hex))) - | L_bin s_bin -> explode s_bin - | _ -> raise (Reporting.err_unreachable l __POS__ "s_bin given non vector literal") in - - List.map (function '0' -> L_aux (L_zero, gen_loc l) - | '1' -> L_aux (L_one, gen_loc l) - | _ -> raise (Reporting.err_unreachable (gen_loc l) __POS__ "binary had non-zero or one")) s_bin - let find_used_vars exp = (* Overapproximates the set of used identifiers, but for the use cases below this is acceptable. *) @@ -291,39 +257,26 @@ let rewrite_defs_nexp_ids, rewrite_typ_nexp_ids = DEF_spec (VS_aux (VS_val_spec (typschm, id, exts, b), a)) | DEF_type (TD_aux (TD_abbrev (id, typq, typ_arg), a)) -> DEF_type (TD_aux (TD_abbrev (id, typq, rewrite_typ_arg env typ_arg), a)) + | DEF_type (TD_aux (TD_record (id, typq, fields, b), a)) -> + let fields' = List.map (fun (t, id) -> (rewrite_typ env t, id)) fields in + DEF_type (TD_aux (TD_record (id, typq, fields', b), a)) + | DEF_type (TD_aux (TD_variant (id, typq, constrs, b), a)) -> + let constrs' = + List.map (fun (Tu_aux (Tu_ty_id (t, id), l)) -> + Tu_aux (Tu_ty_id (rewrite_typ env t, id), l)) + constrs + in + DEF_type (TD_aux (TD_variant (id, typq, constrs', b), a)) | d -> Rewriter.rewrite_def rewriters d in (fun env defs -> rewrite_defs_base { rewriters_base with - rewrite_exp = (fun _ -> map_exp_annot rewrite_annot); rewrite_def = rewrite_def env + rewrite_exp = (fun _ -> map_exp_annot rewrite_annot); + rewrite_def = rewrite_def env } defs), rewrite_typ -let rewrite_bitvector_exps env defs = - let e_aux = function - | (E_vector es, ((l, tannot) as a)) when not (is_empty_tannot tannot) -> - let env = env_of_annot (l, tannot) in - let typ = typ_of_annot (l, tannot) in - let eff = effect_of_annot tannot in - if is_bitvector_typ typ then - try - let len = mk_lit_exp (L_num (Big_int.of_int (List.length es))) in - let es = mk_exp (E_list (List.map strip_exp es)) in - let exp = mk_exp (E_app (mk_id "bitvector_of_bitlist", [len; es])) in - check_exp env exp typ - with - | _ -> E_aux (E_vector es, a) - else - E_aux (E_vector es, a) - | (e_aux, a) -> E_aux (e_aux, a) - in - let rewrite_exp _ = fold_exp { id_exp_alg with e_aux = e_aux } in - if IdSet.mem (mk_id "bitvector_of_bitlist") (val_spec_ids defs) then - rewrite_defs_base { rewriters_base with rewrite_exp = rewrite_exp } defs - else defs - - let rewrite_defs_remove_assert defs = let e_assert ((E_aux (eaux, (l, _)) as exp), str) = match eaux with | E_constraint _ -> @@ -1263,7 +1216,7 @@ let rewrite_defs_vector_string_pats_to_bit_list env = match pat with | P_lit (L_aux (lit, l) as l_aux) -> begin match lit with - | L_hex _ | L_bin _ -> P_aux (P_vector (List.map (fun p -> P_aux (P_lit p, (l, mk_tannot env bit_typ no_effect))) (vector_string_to_bit_list l lit)), annot) + | L_hex _ | L_bin _ -> P_aux (P_vector (List.map (fun p -> P_aux (P_lit p, (l, mk_tannot env bit_typ no_effect))) (vector_string_to_bit_list l_aux)), annot) | lit -> P_aux (P_lit l_aux, annot) end | pat -> (P_aux (pat, annot)) @@ -1273,7 +1226,7 @@ let rewrite_defs_vector_string_pats_to_bit_list env = match exp with | E_lit (L_aux (lit, l) as l_aux) -> begin match lit with - | L_hex _ | L_bin _ -> E_aux (E_vector (List.map (fun e -> E_aux (E_lit e, (l, mk_tannot env bit_typ no_effect))) (vector_string_to_bit_list l lit)), annot) + | L_hex _ | L_bin _ -> E_aux (E_vector (List.map (fun e -> E_aux (E_lit e, (l, mk_tannot env bit_typ no_effect))) (vector_string_to_bit_list l_aux)), annot) | lit -> E_aux (E_lit l_aux, annot) end | exp -> (E_aux (exp, annot)) @@ -1287,6 +1240,39 @@ let rewrite_defs_vector_string_pats_to_bit_list env = in rewrite_defs_base { rewriters_base with rewrite_pat = rewrite_pat; rewrite_exp = rewrite_exp } +let rewrite_bit_lists_to_lits env = + (* TODO Make all rewriting passes support bitvector literals instead of + converting back and forth *) + let open Sail2_values in + let bit_of_lit = function + | L_aux (L_zero, _) -> Some B0 + | L_aux (L_one, _) -> Some B1 + | _ -> None + in + let bit_of_exp = function E_aux (E_lit lit, _) -> bit_of_lit lit | _ -> None in + let string_of_chars cs = String.concat "" (List.map (String.make 1) cs) in + let lit_of_bits bits = match hexstring_of_bits bits with + | Some h -> L_hex (string_of_chars h) + | None -> L_bin (string_of_chars (List.map bitU_char bits)) + in + let e_aux (e, (l, annot)) = + let rewrap e = E_aux (e, (l, annot)) in + try + let env = env_of_annot (l, annot) in + let typ = typ_of_annot (l, annot) in + match e with + | E_vector es when is_bitvector_typ typ -> + (match just_list (List.map bit_of_exp es) with + | Some bits -> + check_exp env (mk_exp (E_cast (typ, mk_lit_exp (lit_of_bits bits)))) typ + | None -> rewrap e) + | E_cast (typ', E_aux (E_cast (_, e'), _)) -> rewrap (E_cast (typ', e')) + | _ -> rewrap e + with _ -> rewrap e + in + let rewrite_exp rw = fold_exp { id_exp_alg with e_aux = e_aux; } in + rewrite_defs_base { rewriters_base with rewrite_exp = rewrite_exp } + (* Remove pattern guards by rewriting them to if-expressions within the pattern expression. *) let rewrite_exp_guarded_pats rewriters (E_aux (exp,(l,annot)) as full_exp) = @@ -2030,7 +2016,7 @@ let rewrite_simple_types env (Defs defs) = let rec simple_lit (L_aux (lit_aux, l) as lit) = match lit_aux with | L_bin _ | L_hex _ -> - E_list (List.map (fun b -> E_aux (E_lit b, simple_annot l bit_typ)) (vector_string_to_bit_list l lit_aux)) + E_list (List.map (fun b -> E_aux (E_lit b, simple_annot l bit_typ)) (vector_string_to_bit_list lit)) | _ -> E_lit lit in let simple_def = function @@ -3147,7 +3133,7 @@ let rewrite_defs_mapping_patterns env = let x = Env.get_val_spec mapping_id env in let typ1, typ2 = match x with - | (_, Typ_aux(Typ_bidir(typ1, typ2), _)) -> typ1, typ2 + | (_, Typ_aux(Typ_bidir(typ1, typ2, _), _)) -> typ1, typ2 | (_, typ) -> raise (Reporting.err_unreachable (fst p_annot) __POS__ ("Must be bi-directional mapping: " ^ string_of_typ typ)) in @@ -3950,6 +3936,54 @@ let rewrite_defs_realise_mappings _ (Defs defs) = [realise_single_mpexp (append_placeholder mpexp) (mk_exp (E_app ((mk_id "Some"), [mk_exp (E_tuple [exp; exp_of_mpat strlen])])))] end in + let realise_val_spec = function + | (VS_aux (VS_val_spec (TypSchm_aux (TypSchm_ts (typq, Typ_aux (Typ_bidir (typ1, typ2, eff), l)), _), id, _, _), ((_, (tannot:tannot)) as annot))) -> + let forwards_id = mk_id (string_of_id id ^ "_forwards") in + let forwards_matches_id = mk_id (string_of_id id ^ "_forwards_matches") in + let backwards_id = mk_id (string_of_id id ^ "_backwards") in + let backwards_matches_id = mk_id (string_of_id id ^ "_backwards_matches") in + + let env = env_of_annot annot in + let forwards_typ = Typ_aux (Typ_fn ([typ1], typ2, eff), l) in + let forwards_matches_typ = Typ_aux (Typ_fn ([typ1], bool_typ, eff), l) in + let backwards_typ = Typ_aux (Typ_fn ([typ2], typ1, eff), l) in + let backwards_matches_typ = Typ_aux (Typ_fn ([typ2], bool_typ, eff), l) in + + let forwards_spec = VS_aux (VS_val_spec (mk_typschm typq forwards_typ, forwards_id, [], false), (Parse_ast.Unknown,())) in + let backwards_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_typ, backwards_id, [], false), (Parse_ast.Unknown,())) in + let forwards_matches_spec = VS_aux (VS_val_spec (mk_typschm typq forwards_matches_typ, forwards_matches_id, [], false), (Parse_ast.Unknown,())) in + let backwards_matches_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_matches_typ, backwards_matches_id, [], false), (Parse_ast.Unknown,())) in + + let forwards_spec, env = Type_check.check_val_spec env forwards_spec in + let backwards_spec, env = Type_check.check_val_spec env backwards_spec in + let forwards_matches_spec, env = Type_check.check_val_spec env forwards_matches_spec in + let backwards_matches_spec, env = Type_check.check_val_spec env backwards_matches_spec in + + let prefix_id = mk_id (string_of_id id ^ "_matches_prefix") in + let string_defs = + begin if subtype_check env typ1 string_typ && subtype_check env string_typ typ1 then + let forwards_prefix_typ = Typ_aux (Typ_fn ([typ1], app_typ (mk_id "option") [A_aux (A_typ (tuple_typ [typ2; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in + let forwards_prefix_spec = VS_aux (VS_val_spec (mk_typschm typq forwards_prefix_typ, prefix_id, [], false), (Parse_ast.Unknown,())) in + let forwards_prefix_spec, env = Type_check.check_val_spec env forwards_prefix_spec in + forwards_prefix_spec + else + if subtype_check env typ2 string_typ && subtype_check env string_typ typ2 then + let backwards_prefix_typ = Typ_aux (Typ_fn ([typ2], app_typ (mk_id "option") [A_aux (A_typ (tuple_typ [typ1; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in + let backwards_prefix_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_prefix_typ, prefix_id, [], false), (Parse_ast.Unknown,())) in + let backwards_prefix_spec, env = Type_check.check_val_spec env backwards_prefix_spec in + backwards_prefix_spec + else + [] + end + in + + forwards_spec + @ backwards_spec + @ forwards_matches_spec + @ backwards_matches_spec + @ string_defs + | vs -> [DEF_spec vs] + in let realise_mapdef (MD_aux (MD_mapping (id, _, mapcls), ((l, (tannot:tannot)) as annot))) = let forwards_id = mk_id (string_of_id id ^ "_forwards") in let forwards_matches_id = mk_id (string_of_id id ^ "_forwards_matches") in @@ -3964,24 +3998,14 @@ let rewrite_defs_realise_mappings _ (Defs defs) = | _ -> 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 + let (typ1, typ2, eff, l) = match bidir_typ with + | Typ_aux (Typ_bidir (typ1, typ2, eff), l) -> typ1, typ2, eff, l | _ -> 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 - let backwards_typ = Typ_aux (Typ_fn ([typ2], typ1, no_effect), l) in - let backwards_matches_typ = Typ_aux (Typ_fn ([typ2], bool_typ, no_effect), l) in - - let forwards_spec = VS_aux (VS_val_spec (mk_typschm typq forwards_typ, forwards_id, [], false), (Parse_ast.Unknown,())) in - let backwards_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_typ, backwards_id, [], false), (Parse_ast.Unknown,())) in - let forwards_matches_spec = VS_aux (VS_val_spec (mk_typschm typq forwards_matches_typ, forwards_matches_id, [], false), (Parse_ast.Unknown,())) in - let backwards_matches_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_matches_typ, backwards_matches_id, [], false), (Parse_ast.Unknown,())) in - - let forwards_spec, env = Type_check.check_val_spec env forwards_spec in - let backwards_spec, env = Type_check.check_val_spec env backwards_spec in - let forwards_matches_spec, env = Type_check.check_val_spec env forwards_matches_spec in - let backwards_matches_spec, env = Type_check.check_val_spec env backwards_matches_spec in + let forwards_typ = Typ_aux (Typ_fn ([typ1], typ2, eff), l) in + let forwards_matches_typ = Typ_aux (Typ_fn ([typ1], bool_typ, eff), l) in + let backwards_typ = Typ_aux (Typ_fn ([typ2], typ1, eff), l) in + let backwards_matches_typ = Typ_aux (Typ_fn ([typ2], bool_typ, eff), l) in let no_tannot = (Typ_annot_opt_aux (Typ_annot_opt_none, Parse_ast.Unknown)) in let forwards_match = mk_exp (E_case (arg_exp, ((List.map (fun mapcl -> strip_mapcl mapcl |> realise_mapcl true forwards_id) mapcls) |> List.flatten))) in @@ -4010,40 +4034,34 @@ let rewrite_defs_realise_mappings _ (Defs defs) = let string_defs = begin if subtype_check env typ1 string_typ && subtype_check env string_typ typ1 then let forwards_prefix_typ = Typ_aux (Typ_fn ([typ1], app_typ (mk_id "option") [A_aux (A_typ (tuple_typ [typ2; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in - let forwards_prefix_spec = VS_aux (VS_val_spec (mk_typschm typq forwards_prefix_typ, prefix_id, [], false), (Parse_ast.Unknown,())) in - let forwards_prefix_spec, env = Type_check.check_val_spec env forwards_prefix_spec in let forwards_prefix_match = mk_exp (E_case (arg_exp, ((List.map (fun mapcl -> strip_mapcl mapcl |> realise_prefix_mapcl true prefix_id) mapcls) |> List.flatten) @ [prefix_wildcard])) in let forwards_prefix_fun = (FD_aux (FD_function (non_rec, no_tannot, effect_none, [mk_funcl prefix_id arg_pat forwards_prefix_match]), (l, ()))) in typ_debug (lazy (Printf.sprintf "forwards prefix matches for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef forwards_prefix_fun |> Pretty_print_sail.to_string))); let forwards_prefix_fun, _ = Type_check.check_fundef env forwards_prefix_fun in - forwards_prefix_spec @ forwards_prefix_fun + forwards_prefix_fun else if subtype_check env typ2 string_typ && subtype_check env string_typ typ2 then let backwards_prefix_typ = Typ_aux (Typ_fn ([typ2], app_typ (mk_id "option") [A_aux (A_typ (tuple_typ [typ1; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in - let backwards_prefix_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_prefix_typ, prefix_id, [], false), (Parse_ast.Unknown,())) in - let backwards_prefix_spec, env = Type_check.check_val_spec env backwards_prefix_spec in let backwards_prefix_match = mk_exp (E_case (arg_exp, ((List.map (fun mapcl -> strip_mapcl mapcl |> realise_prefix_mapcl false prefix_id) mapcls) |> List.flatten) @ [prefix_wildcard])) in let backwards_prefix_fun = (FD_aux (FD_function (non_rec, no_tannot, effect_none, [mk_funcl prefix_id arg_pat backwards_prefix_match]), (l, ()))) in typ_debug (lazy (Printf.sprintf "backwards prefix matches for mapping %s: %s\n%!" (string_of_id id) (Pretty_print_sail.doc_fundef backwards_prefix_fun |> Pretty_print_sail.to_string))); let backwards_prefix_fun, _ = Type_check.check_fundef env backwards_prefix_fun in - backwards_prefix_spec @ backwards_prefix_fun + backwards_prefix_fun else [] end in + let has_def id = IdSet.mem id (ids_of_defs (Defs defs)) in - forwards_spec - @ forwards_fun - @ backwards_spec - @ backwards_fun - @ forwards_matches_spec - @ forwards_matches_fun - @ backwards_matches_spec - @ backwards_matches_fun - @ string_defs + (if has_def forwards_id then [] else forwards_fun) + @ (if has_def backwards_id then [] else backwards_fun) + @ (if has_def forwards_matches_id then [] else forwards_matches_fun) + @ (if has_def backwards_matches_id then [] else backwards_matches_fun) + @ (if has_def prefix_id then [] else string_defs) in let rewrite_def def = match def with + | DEF_spec spec -> realise_val_spec spec | DEF_mapdef mdef -> realise_mapdef mdef | d -> [d] in @@ -4653,13 +4671,30 @@ let recheck_defs_without_effects env defs = let () = opt_no_effects := old in result -let remove_mapping_valspecs env (Defs defs) = - let allowed_def def = - match def with - | DEF_spec (VS_aux (VS_val_spec (TypSchm_aux (TypSchm_ts (_, Typ_aux (Typ_bidir _, _)), _), _, _, _), _)) -> false - | _ -> true +(* In realise_mappings we may have duplicated a user-supplied val spec, which + causes problems for some targets. Keep the first one, except use the externs + from the last one, as subsequent redefinitions override earlier ones. *) +let remove_duplicate_valspecs env (Defs defs) = + let last_externs = + List.fold_left + (fun last_externs def -> + match def with + | DEF_spec (VS_aux (VS_val_spec (_, id, externs, _), _)) -> + Bindings.add id externs last_externs + | _ -> last_externs) Bindings.empty defs in - Defs (List.filter allowed_def defs) + let (_, rev_defs) = + List.fold_left + (fun (set, defs) def -> + match def with + | DEF_spec (VS_aux (VS_val_spec (typschm, id, _, cast), l)) -> + if IdSet.mem id set then (set, defs) + else + let externs = Bindings.find id last_externs in + let vs = VS_aux (VS_val_spec (typschm, id, externs, cast), l) in + (IdSet.add id set, (DEF_spec vs)::defs) + | _ -> (set, def::defs)) (IdSet.empty, []) defs + in Defs (List.rev rev_defs) (* Move loop termination measures into loop AST nodes. This is used before @@ -4807,7 +4842,7 @@ let all_rewrites = [ ("recheck_defs_without_effects", Checking_rewriter recheck_defs_without_effects); ("optimize_recheck_defs", Basic_rewriter (fun _ -> Optimize.recheck)); ("realise_mappings", Basic_rewriter rewrite_defs_realise_mappings); - ("remove_mapping_valspecs", Basic_rewriter remove_mapping_valspecs); + ("remove_duplicate_valspecs", Basic_rewriter remove_duplicate_valspecs); ("toplevel_string_append", Basic_rewriter rewrite_defs_toplevel_string_append); ("pat_string_append", Basic_rewriter rewrite_defs_pat_string_append); ("mapping_builtins", Basic_rewriter rewrite_defs_mapping_patterns); @@ -4831,7 +4866,7 @@ let all_rewrites = [ ("remove_bitvector_pats", Basic_rewriter rewrite_defs_remove_bitvector_pats); ("remove_numeral_pats", Basic_rewriter rewrite_defs_remove_numeral_pats); ("guarded_pats", Basic_rewriter rewrite_defs_guarded_pats); - ("bitvector_exps", Basic_rewriter rewrite_bitvector_exps); + ("bit_lists_to_lits", Basic_rewriter rewrite_bit_lists_to_lits); ("exp_lift_assign", Basic_rewriter rewrite_defs_exp_lift_assign); ("early_return", Basic_rewriter rewrite_defs_early_return); ("nexp_ids", Basic_rewriter rewrite_defs_nexp_ids); @@ -4850,14 +4885,14 @@ let all_rewrites = [ ("simple_types", Basic_rewriter rewrite_simple_types); ("overload_cast", Basic_rewriter rewrite_overload_cast); ("top_sort_defs", Basic_rewriter (fun _ -> top_sort_defs)); - ("constant_fold", String_rewriter (fun target -> Basic_rewriter (fun _ -> Constant_fold.rewrite_constant_function_calls target))); + ("constant_fold", String_rewriter (fun target -> Basic_rewriter (fun _ -> Constant_fold.(rewrite_constant_function_calls no_fixed target)))); ("split", String_rewriter (fun str -> Basic_rewriter (rewrite_split_fun_ctor_pats str))); ("properties", Basic_rewriter (fun _ -> Property.rewrite)); ] let rewrites_lem = [ ("realise_mappings", []); - ("remove_mapping_valspecs", []); + ("remove_duplicate_valspecs", []); ("toplevel_string_append", []); ("pat_string_append", []); ("mapping_builtins", []); @@ -4881,7 +4916,6 @@ let rewrites_lem = [ ("remove_numeral_pats", []); ("pattern_literals", [Literal_arg "lem"]); ("guarded_pats", []); - ("bitvector_exps", []); (* ("register_ref_writes", rewrite_register_ref_writes); *) ("nexp_ids", []); ("fix_val_specs", []); @@ -4902,12 +4936,13 @@ let rewrites_lem = [ ("remove_superfluous_letbinds", []); ("remove_superfluous_returns", []); ("merge_function_clauses", []); + ("bit_lists_to_lits", []); ("recheck_defs", []) ] let rewrites_coq = [ ("realise_mappings", []); - ("remove_mapping_valspecs", []); + ("remove_duplicate_valspecs", []); ("toplevel_string_append", []); ("pat_string_append", []); ("mapping_builtins", []); @@ -4923,7 +4958,6 @@ let rewrites_coq = [ ("remove_numeral_pats", []); ("pattern_literals", [Literal_arg "lem"]); ("guarded_pats", []); - ("bitvector_exps", []); (* ("register_ref_writes", rewrite_register_ref_writes); *) ("nexp_ids", []); ("fix_val_specs", []); @@ -4953,6 +4987,7 @@ let rewrites_coq = [ ("internal_lets", []); ("remove_superfluous_letbinds", []); ("remove_superfluous_returns", []); + ("bit_lists_to_lits", []); ("recheck_defs", []) ] diff --git a/src/sail.ml b/src/sail.ml index e792e652..ea642470 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -53,12 +53,10 @@ open Process_file module Big_int = Nat_big_num let lib = ref ([] : string list) -let opt_file_out : string option ref = ref None let opt_interactive_script : string option ref = ref None let opt_print_version = ref false let opt_target = ref None let opt_tofrominterp_output_dir : string option ref = ref None -let opt_memo_z3 = ref false let opt_sanity = ref false let opt_includes_c = ref ([]:string list) let opt_specialize_c = ref false @@ -110,6 +108,9 @@ let options = Arg.align ([ " output an OCaml translated version of the input"); ( "-ocaml-nobuild", Arg.Set Ocaml_backend.opt_ocaml_nobuild, + ""); + ( "-ocaml_nobuild", + Arg.Set Ocaml_backend.opt_ocaml_nobuild, " do not build generated OCaml"); ( "-ocaml_trace", Arg.Tuple [set_target "ocaml"; Arg.Set Initial_check.opt_undefined_gen; Arg.Set Ocaml_backend.opt_trace_ocaml], @@ -119,6 +120,9 @@ let options = Arg.align ([ " set a custom directory to build generated OCaml"); ( "-ocaml-coverage", Arg.Set Ocaml_backend.opt_ocaml_coverage, + ""); + ( "-ocaml_coverage", + Arg.Set Ocaml_backend.opt_ocaml_coverage, " build OCaml with bisect_ppx coverage reporting (requires opam packages bisect_ppx-ocamlbuild and bisect_ppx)."); ( "-ocaml_generators", Arg.String (fun s -> opt_ocaml_generators := s::!opt_ocaml_generators), @@ -145,10 +149,10 @@ let options = Arg.align ([ set_target "ir", " print intermediate representation"); ( "-smt", - set_target "smt", + Arg.Tuple [set_target "smt"; Arg.Clear Jib_compile.opt_track_throw], " print SMT translated version of input"); ( "-smt_auto", - Arg.Tuple [set_target "smt"; Arg.Set Jib_smt.opt_auto], + Arg.Tuple [set_target "smt"; Arg.Clear Jib_compile.opt_track_throw; Arg.Set Jib_smt.opt_auto], " generate SMT and automatically call the solver (implies -smt)"); ( "-smt_ignore_overflow", Arg.Set Jib_smt.opt_ignore_overflow, @@ -301,9 +305,15 @@ let options = Arg.align ([ ( "-undefined_gen", Arg.Set Initial_check.opt_undefined_gen, " generate undefined_type functions for types in the specification"); + ( "-grouped_regstate", + Arg.Set State.opt_type_grouped_regstate, + " group registers with same type together in generated register state record"); ( "-enum_casts", Arg.Set Initial_check.opt_enum_casts, " allow enumerations to be automatically casted to numeric range types"); + ( "-new_bitfields", + Arg.Set Type_check.opt_new_bitfields, + " use new bitfield syntax"); ( "-non_lexical_flow", Arg.Set Nl_flow.opt_nl_flow, " allow non-lexical flow typing"); @@ -397,43 +407,6 @@ let _ = opt_file_arguments := (!opt_file_arguments) @ [s]) usage_msg -let load_files ?check:(check=false) type_envs files = - if !opt_memo_z3 then Constraint.load_digests () else (); - - let t = Profile.start () in - let parsed = List.map (fun f -> (f, parse_file f)) files in - let ast = - List.fold_right (fun (_, Parse_ast.Defs ast_nodes) (Parse_ast.Defs later_nodes) - -> Parse_ast.Defs (ast_nodes@later_nodes)) parsed (Parse_ast.Defs []) in - let ast = Process_file.preprocess_ast options ast in - let ast = Initial_check.process_ast ~generate:(not check) ast in - (* The separate loop measures declarations would be awkward to type check, so - move them into the definitions beforehand. *) - let ast = Rewrites.move_loop_measures ast in - Profile.finish "parsing" t; - - let t = Profile.start () in - let (ast, type_envs) = check_ast type_envs ast in - Profile.finish "type checking" t; - - if !opt_memo_z3 then Constraint.save_digests () else (); - - if check then - ("out.sail", ast, type_envs) - else - let ast = Scattered.descatter ast in - let ast, type_envs = rewrite_ast_initial type_envs ast in - (* Recheck after descattering so that the internal type environments always - have complete variant types *) - let ast, type_envs = Type_error.check Type_check.initial_env ast in - - let out_name = match !opt_file_out with - | None when parsed = [] -> "out.sail" - | None -> fst (List.hd parsed) - | Some f -> f ^ ".sail" in - - (out_name, ast, type_envs) - let prover_regstate tgt ast type_envs = match tgt with | Some "coq" -> @@ -513,7 +486,7 @@ let target name out_name ast type_envs = | Some "smt" when !opt_smt_serialize -> let ast_smt, type_envs = Specialize.(specialize typ_ord_specialization type_envs ast) in let ast_smt, type_envs = Specialize.(specialize_passes 2 int_specialization_with_externs type_envs ast_smt) in - let jib, ctx = Jib_smt.compile type_envs ast_smt in + let jib, _, ctx = Jib_smt.compile type_envs ast_smt in let name_file = match !opt_file_out with | Some f -> f ^ ".smt_model" @@ -576,7 +549,8 @@ let main () = print_endline version else begin - let out_name, ast, type_envs = load_files Type_check.initial_env !opt_file_arguments in + let out_name, ast, type_envs = load_files options Type_check.initial_env !opt_file_arguments in + let ast, type_envs = descatter type_envs ast in let ast, type_envs = List.fold_right (fun file (ast,_) -> Splice.splice ast file) (!opt_splice) (ast, type_envs) diff --git a/src/sail_lib.ml b/src/sail_lib.ml index 164bcefa..03994657 100644 --- a/src/sail_lib.ml +++ b/src/sail_lib.ml @@ -17,6 +17,14 @@ let opt_trace = ref false let trace_depth = ref 0 let random = ref false + +let opt_cycle_limit = ref 0 +let cycle_count = ref 0 + +let cycle_limit_reached () = + cycle_count := !cycle_count + 1; + !opt_cycle_limit != 0 && !cycle_count >= !opt_cycle_limit + let sail_call (type t) (f : _ -> t) = let module M = struct exception Return of t end @@ -274,9 +282,7 @@ let rec replicate_bits (bits, n) = let identity x = x - - -(* +(* Returns list of n bits of integer m starting from offset o >= 0 (bits numbered from least significant). Uses twos-complement representation for m<0 and pads most significant bits in sign-extended way. Most significant bit is head of returned list. @@ -529,7 +535,7 @@ let fast_read_ram (data_size, addr) = !vector let tag_ram = (ref Mem.empty : (bool Mem.t) ref);; - + let write_tag_bool (addr, tag) = let addri = uint addr in tag_ram := Mem.add addri tag !tag_ram @@ -551,7 +557,6 @@ let lor_int (n, m) = Big_int.bitwise_or n m let land_int (n, m) = Big_int.bitwise_and n m let lxor_int (n, m) = Big_int.bitwise_xor n m - let debug (str1, n, str2, v) = prerr_endline (str1 ^ Big_int.to_string n ^ str2 ^ string_of_bits v) let eq_string (str1, str2) = String.compare str1 str2 == 0 diff --git a/src/sail_pp.ml b/src/sail_pp.ml new file mode 100644 index 00000000..30f93a3e --- /dev/null +++ b/src/sail_pp.ml @@ -0,0 +1,904 @@ +(* generated by Ott 0.30 from: ../language/sail.ott *) +open PPrintEngine +open PPrintCombinators +open + +let rec pp_raw_l_default + +and pp_raw_id_aux x = match x with +| Id_aux_aux(Id(x),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Id" ^^ string "(" ^^ string "\"" ^^ string x ^^ string "\"" ^^ string ")" +| Id_aux_aux(Operator(x),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Operator" ^^ string "(" ^^ string "\"" ^^ string x ^^ string "\"" ^^ string ")" + +and pp_raw_id x = match x with +| Id_aux(id_aux,l) -> string "Id_aux" ^^ string "(" ^^ pp_raw_id_aux id_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_kid_aux x = match x with +| Kid_aux_aux(Var(x),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Var" ^^ string "(" ^^ string "\"" ^^ string x ^^ string "\"" ^^ string ")" + +and pp_raw_kid x = match x with +| Kid_aux(kid_aux,l) -> string "Kid_aux" ^^ string "(" ^^ pp_raw_kid_aux kid_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_kind_aux x = match x with +| K_aux(K_type,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "K_type" +| K_aux(K_int,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "K_int" +| K_aux(K_order,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "K_order" +| K_aux(K_bool,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "K_bool" + +and pp_raw_kind x = match x with +| K_aux(kind_aux,l) -> string "K_aux" ^^ string "(" ^^ pp_raw_kind_aux kind_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_nexp_aux x = match x with +| Nexp_aux(Nexp_id(id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Nexp_id" ^^ string "(" ^^ pp_raw_id id ^^ string ")" +| Nexp_aux(Nexp_var(kid),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Nexp_var" ^^ string "(" ^^ pp_raw_kid kid ^^ string ")" +| Nexp_aux(Nexp_constant(num),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Nexp_constant" ^^ string "(" ^^ string "\"" ^^ string num ^^ string "\"" ^^ string ")" +| Nexp_aux(Nexp_app(id,nexp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Nexp_app" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (nexp0) -> string "(" ^^ pp_raw_nexp nexp0 ^^ string ")") nexp0) ^^ string "]" ^^ string ")" +| Nexp_aux(Nexp_times(nexp1,nexp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Nexp_times" ^^ string "(" ^^ pp_raw_nexp nexp1 ^^ string "," ^^ pp_raw_nexp nexp2 ^^ string ")" +| Nexp_aux(Nexp_sum(nexp1,nexp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Nexp_sum" ^^ string "(" ^^ pp_raw_nexp nexp1 ^^ string "," ^^ pp_raw_nexp nexp2 ^^ string ")" +| Nexp_aux(Nexp_minus(nexp1,nexp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Nexp_minus" ^^ string "(" ^^ pp_raw_nexp nexp1 ^^ string "," ^^ pp_raw_nexp nexp2 ^^ string ")" +| Nexp_aux(Nexp_exp(nexp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Nexp_exp" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string ")" +| Nexp_aux(Nexp_neg(nexp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Nexp_neg" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string ")" + +and pp_raw_nexp x = match x with +| Nexp_aux(nexp_aux,l) -> string "Nexp_aux" ^^ string "(" ^^ pp_raw_nexp_aux nexp_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_order_aux x = match x with +| Ord_aux(Ord_var(kid),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Ord_var" ^^ string "(" ^^ pp_raw_kid kid ^^ string ")" +| Ord_aux(Ord_inc,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Ord_inc" +| Ord_aux(Ord_dec,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Ord_dec" + +and pp_raw_order x = match x with +| Ord_aux(order_aux,l) -> string "Ord_aux" ^^ string "(" ^^ pp_raw_order_aux order_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_base_effect_aux x = match x with +| BE_aux(BE_rreg,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_rreg" +| BE_aux(BE_wreg,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_wreg" +| BE_aux(BE_rmem,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_rmem" +| BE_aux(BE_rmemt,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_rmemt" +| BE_aux(BE_wmem,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_wmem" +| BE_aux(BE_eamem,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_eamem" +| BE_aux(BE_exmem,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_exmem" +| BE_aux(BE_wmv,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_wmv" +| BE_aux(BE_wmvt,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_wmvt" +| BE_aux(BE_barr,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_barr" +| BE_aux(BE_depend,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_depend" +| BE_aux(BE_undef,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_undef" +| BE_aux(BE_unspec,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_unspec" +| BE_aux(BE_nondet,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_nondet" +| BE_aux(BE_escape,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_escape" +| BE_aux(BE_config,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BE_config" + +and pp_raw_base_effect x = match x with +| BE_aux(base_effect_aux,l) -> string "BE_aux" ^^ string "(" ^^ pp_raw_base_effect_aux base_effect_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_effect_aux x = match x with +| Effect_aux(Effect_set(base_effect0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Effect_set" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (base_effect0) -> string "(" ^^ pp_raw_base_effect base_effect0 ^^ string ")") base_effect0) ^^ string "]" ^^ string ")" + +and pp_raw_effect x = match x with +| Effect_aux(effect_aux,l) -> string "Effect_aux" ^^ string "(" ^^ pp_raw_effect_aux effect_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_typ_aux x = match x with +| Typ_aux(Typ_internal_unknown,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Typ_internal_unknown" +| Typ_aux(Typ_id(id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Typ_id" ^^ string "(" ^^ pp_raw_id id ^^ string ")" +| Typ_aux(Typ_var(kid),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Typ_var" ^^ string "(" ^^ pp_raw_kid kid ^^ string ")" +| Typ_aux(Typ_fn(typ0,typ2,effect),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Typ_fn" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (typ0) -> string "(" ^^ pp_raw_typ typ0 ^^ string ")") typ0) ^^ string "]" ^^ string "," ^^ pp_raw_typ typ2 ^^ string "," ^^ pp_raw_effect effect ^^ string ")" +| Typ_aux(Typ_bidir(typ1,typ2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Typ_bidir" ^^ string "(" ^^ pp_raw_typ typ1 ^^ string "," ^^ pp_raw_typ typ2 ^^ string ")" +| Typ_aux(Typ_tup(typ0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Typ_tup" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (typ0) -> string "(" ^^ pp_raw_typ typ0 ^^ string ")") typ0) ^^ string "]" ^^ string ")" +| Typ_aux(Typ_app(id,typ_arg0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Typ_app" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (typ_arg0) -> string "(" ^^ pp_raw_typ_arg typ_arg0 ^^ string ")") typ_arg0) ^^ string "]" ^^ string ")" +| Typ_aux(Typ_exist(kinded_id0,n_constraint,typ),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Typ_exist" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (kinded_id0) -> string "(" ^^ pp_raw_kinded_id kinded_id0 ^^ string ")") kinded_id0) ^^ string "]" ^^ string "," ^^ pp_raw_n_constraint n_constraint ^^ string "," ^^ pp_raw_typ typ ^^ string ")" + +and pp_raw_typ x = match x with +| Typ_aux(typ_aux,l) -> string "Typ_aux" ^^ string "(" ^^ pp_raw_typ_aux typ_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_typ_arg_aux x = match x with +| A_aux(A_nexp(nexp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "A_nexp" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string ")" +| A_aux(A_typ(typ),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "A_typ" ^^ string "(" ^^ pp_raw_typ typ ^^ string ")" +| A_aux(A_order(order),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "A_order" ^^ string "(" ^^ pp_raw_order order ^^ string ")" +| A_aux(A_bool(n_constraint),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "A_bool" ^^ string "(" ^^ pp_raw_n_constraint n_constraint ^^ string ")" + +and pp_raw_typ_arg x = match x with +| A_aux(typ_arg_aux,l) -> string "A_aux" ^^ string "(" ^^ pp_raw_typ_arg_aux typ_arg_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_n_constraint_aux x = match x with +| NC_aux(NC_equal(nexp,nexp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_equal" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string "," ^^ pp_raw_nexp nexp_prime ^^ string ")" +| NC_aux(NC_bounded_ge(nexp,nexp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_bounded_ge" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string "," ^^ pp_raw_nexp nexp_prime ^^ string ")" +| NC_aux(NC_bounded_gt(nexp,nexp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_bounded_gt" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string "," ^^ pp_raw_nexp nexp_prime ^^ string ")" +| NC_aux(NC_bounded_le(nexp,nexp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_bounded_le" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string "," ^^ pp_raw_nexp nexp_prime ^^ string ")" +| NC_aux(NC_bounded_lt(nexp,nexp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_bounded_lt" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string "," ^^ pp_raw_nexp nexp_prime ^^ string ")" +| NC_aux(NC_not_equal(nexp,nexp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_not_equal" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string "," ^^ pp_raw_nexp nexp_prime ^^ string ")" +| NC_aux(NC_set(kid,num0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_set" ^^ string "(" ^^ pp_raw_kid kid ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (num0) -> string "(" ^^ string "\"" ^^ string num0 ^^ string "\"" ^^ string ")") num0) ^^ string "]" ^^ string ")" +| NC_aux(NC_or(n_constraint,n_constraint_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_or" ^^ string "(" ^^ pp_raw_n_constraint n_constraint ^^ string "," ^^ pp_raw_n_constraint n_constraint_prime ^^ string ")" +| NC_aux(NC_and(n_constraint,n_constraint_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_and" ^^ string "(" ^^ pp_raw_n_constraint n_constraint ^^ string "," ^^ pp_raw_n_constraint n_constraint_prime ^^ string ")" +| NC_aux(NC_app(id,typ_arg0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_app" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (typ_arg0) -> string "(" ^^ pp_raw_typ_arg typ_arg0 ^^ string ")") typ_arg0) ^^ string "]" ^^ string ")" +| NC_aux(NC_var(kid),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_var" ^^ string "(" ^^ pp_raw_kid kid ^^ string ")" +| NC_aux(NC_true,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_true" +| NC_aux(NC_false,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "NC_false" + +and pp_raw_n_constraint x = match x with +| NC_aux(n_constraint_aux,l) -> string "NC_aux" ^^ string "(" ^^ pp_raw_n_constraint_aux n_constraint_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_kinded_id_aux x = match x with +| KOpt_aux(KOpt_kind(kind,kid),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "KOpt_kind" ^^ string "(" ^^ pp_raw_kind kind ^^ string "," ^^ pp_raw_kid kid ^^ string ")" + +and pp_raw_kinded_id x = match x with +| KOpt_aux(kinded_id_aux,l) -> string "KOpt_aux" ^^ string "(" ^^ pp_raw_kinded_id_aux kinded_id_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_quant_item_aux x = match x with +| QI_aux(QI_id(kinded_id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "QI_id" ^^ string "(" ^^ pp_raw_kinded_id kinded_id ^^ string ")" +| QI_aux(QI_constraint(n_constraint),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "QI_constraint" ^^ string "(" ^^ pp_raw_n_constraint n_constraint ^^ string ")" +| QI_aux(QI_constant(kinded_id0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "QI_constant" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (kinded_id0) -> string "(" ^^ pp_raw_kinded_id kinded_id0 ^^ string ")") kinded_id0) ^^ string "]" ^^ string ")" + +and pp_raw_quant_item x = match x with +| QI_aux(quant_item_aux,l) -> string "QI_aux" ^^ string "(" ^^ pp_raw_quant_item_aux quant_item_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_typquant_aux x = match x with +| TypQ_aux(TypQ_tq(quant_item0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "TypQ_tq" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (quant_item0) -> string "(" ^^ pp_raw_quant_item quant_item0 ^^ string ")") quant_item0) ^^ string "]" ^^ string ")" +| TypQ_aux(TypQ_no_forall,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "TypQ_no_forall" + +and pp_raw_typquant x = match x with +| TypQ_aux(typquant_aux,l) -> string "TypQ_aux" ^^ string "(" ^^ pp_raw_typquant_aux typquant_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_typschm_aux x = match x with +| TypSchm_aux(TypSchm_ts(typquant,typ),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "TypSchm_ts" ^^ string "(" ^^ pp_raw_typquant typquant ^^ string "," ^^ pp_raw_typ typ ^^ string ")" + +and pp_raw_typschm x = match x with +| TypSchm_aux(typschm_aux,l) -> string "TypSchm_aux" ^^ string "(" ^^ pp_raw_typschm_aux typschm_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_type_def x = match x with +| TD_aux(type_def_aux) -> string "TD_aux" ^^ string "(" ^^ pp_raw_type_def_aux type_def_aux ^^ string ")" + +and pp_raw_type_def_aux x = match x with +| TD_abbrev(id,typquant,typ_arg) -> string "TD_abbrev" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_typquant typquant ^^ string "," ^^ pp_raw_typ_arg typ_arg ^^ string ")" +| TD_record(id,typquant,typ0_id0,semi_opt) -> string "TD_record" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_typquant typquant ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (typ0,id0) -> string "(" ^^ pp_raw_typ typ0 ^^ string "," ^^ pp_raw_id id0 ^^ string ")") typ0_id0) ^^ string "]" ^^ string "," ^^ pp_raw_semi_opt semi_opt ^^ string ")" +| TD_variant(id,typquant,type_union0,semi_opt) -> string "TD_variant" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_typquant typquant ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (type_union0) -> string "(" ^^ pp_raw_type_union type_union0 ^^ string ")") type_union0) ^^ string "]" ^^ string "," ^^ pp_raw_semi_opt semi_opt ^^ string ")" +| TD_enum(id,id0,semi_opt) -> string "TD_enum" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (id0) -> string "(" ^^ pp_raw_id id0 ^^ string ")") id0) ^^ string "]" ^^ string "," ^^ pp_raw_semi_opt semi_opt ^^ string ")" +| TD_bitfield(id,typ,id0_index_range0) -> string "TD_bitfield" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_typ typ ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (id0,index_range0) -> string "(" ^^ pp_raw_id id0 ^^ string "," ^^ pp_raw_index_range index_range0 ^^ string ")") id0_index_range0) ^^ string "]" ^^ string ")" + +and pp_raw_type_union_aux x = match x with +| Tu_aux(Tu_ty_id(typ,id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Tu_ty_id" ^^ string "(" ^^ pp_raw_typ typ ^^ string "," ^^ pp_raw_id id ^^ string ")" + +and pp_raw_type_union x = match x with +| Tu_aux(type_union_aux,l) -> string "Tu_aux" ^^ string "(" ^^ pp_raw_type_union_aux type_union_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_index_range_aux x = match x with +| BF_aux(BF_single(nexp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BF_single" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string ")" +| BF_aux(BF_range(nexp1,nexp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BF_range" ^^ string "(" ^^ pp_raw_nexp nexp1 ^^ string "," ^^ pp_raw_nexp nexp2 ^^ string ")" +| BF_aux(BF_concat(index_range1,index_range2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "BF_concat" ^^ string "(" ^^ pp_raw_index_range index_range1 ^^ string "," ^^ pp_raw_index_range index_range2 ^^ string ")" + +and pp_raw_index_range x = match x with +| BF_aux(index_range_aux,l) -> string "BF_aux" ^^ string "(" ^^ pp_raw_index_range_aux index_range_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_lit_aux x = match x with +| L_aux(L_unit,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_unit" +| L_aux(L_zero,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_zero" +| L_aux(L_one,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_one" +| L_aux(L_true,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_true" +| L_aux(L_false,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_false" +| L_aux(L_num(num),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_num" ^^ string "(" ^^ string "\"" ^^ string num ^^ string "\"" ^^ string ")" +| L_aux(L_hex(hex),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_hex" ^^ string "(" ^^ string "\"" ^^ string hex ^^ string "\"" ^^ string ")" +| L_aux(L_bin(bin),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_bin" ^^ string "(" ^^ string "\"" ^^ string bin ^^ string "\"" ^^ string ")" +| L_aux(L_string(string),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_string" ^^ string "(" ^^ string "\"" ^^ string string ^^ string "\"" ^^ string ")" +| L_aux(L_undef,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_undef" +| L_aux(L_real(real),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "L_real" ^^ string "(" ^^ string "\"" ^^ string real ^^ string "\"" ^^ string ")" + +and pp_raw_lit x = match x with +| L_aux(lit_aux,l) -> string "L_aux" ^^ string "(" ^^ pp_raw_lit_aux lit_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_semi_opt_default + +and pp_raw_typ_pat_aux x = match x with +| TP_aux(TP_wild,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "TP_wild" +| TP_aux(TP_var(kid),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "TP_var" ^^ string "(" ^^ pp_raw_kid kid ^^ string ")" +| TP_aux(TP_app(id,typ_pat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "TP_app" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (typ_pat0) -> string "(" ^^ pp_raw_typ_pat typ_pat0 ^^ string ")") typ_pat0) ^^ string "]" ^^ string ")" + +and pp_raw_typ_pat x = match x with +| TP_aux(typ_pat_aux,l) -> string "TP_aux" ^^ string "(" ^^ pp_raw_typ_pat_aux typ_pat_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_pat_aux x = match x with +| P_aux(P_lit(lit),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_lit" ^^ string "(" ^^ pp_raw_lit lit ^^ string ")" +| P_aux(P_wild,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_wild" +| P_aux(P_or(pat1,pat2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_or" ^^ string "(" ^^ pp_raw_pat pat1 ^^ string "," ^^ pp_raw_pat pat2 ^^ string ")" +| P_aux(P_not(pat),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_not" ^^ string "(" ^^ pp_raw_pat pat ^^ string ")" +| P_aux(P_as(pat,id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_as" ^^ string "(" ^^ pp_raw_pat pat ^^ string "," ^^ pp_raw_id id ^^ string ")" +| P_aux(P_typ(typ,pat),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_typ" ^^ string "(" ^^ pp_raw_typ typ ^^ string "," ^^ pp_raw_pat pat ^^ string ")" +| P_aux(P_id(id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_id" ^^ string "(" ^^ pp_raw_id id ^^ string ")" +| P_aux(P_var(pat,typ_pat),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_var" ^^ string "(" ^^ pp_raw_pat pat ^^ string "," ^^ pp_raw_typ_pat typ_pat ^^ string ")" +| P_aux(P_app(id,pat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_app" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (pat0) -> string "(" ^^ pp_raw_pat pat0 ^^ string ")") pat0) ^^ string "]" ^^ string ")" +| P_aux(P_vector(pat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_vector" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (pat0) -> string "(" ^^ pp_raw_pat pat0 ^^ string ")") pat0) ^^ string "]" ^^ string ")" +| P_aux(P_vector_concat(pat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_vector_concat" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (pat0) -> string "(" ^^ pp_raw_pat pat0 ^^ string ")") pat0) ^^ string "]" ^^ string ")" +| P_aux(P_tup(pat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_tup" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (pat0) -> string "(" ^^ pp_raw_pat pat0 ^^ string ")") pat0) ^^ string "]" ^^ string ")" +| P_aux(P_list(pat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_list" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (pat0) -> string "(" ^^ pp_raw_pat pat0 ^^ string ")") pat0) ^^ string "]" ^^ string ")" +| P_aux(P_cons(pat1,pat2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_cons" ^^ string "(" ^^ pp_raw_pat pat1 ^^ string "," ^^ pp_raw_pat pat2 ^^ string ")" +| P_aux(P_string_append(pat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "P_string_append" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (pat0) -> string "(" ^^ pp_raw_pat pat0 ^^ string ")") pat0) ^^ string "]" ^^ string ")" + +and pp_raw_pat x = match x with +| P_aux(pat_aux,annot) -> string "P_aux" ^^ string "(" ^^ pp_raw_pat_aux pat_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_loop_default + +and pp_raw_internal_loop_measure_aux x = match x with +| Measure_aux(Measure_none,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Measure_none" +| Measure_aux(Measure_some(exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Measure_some" ^^ string "(" ^^ pp_raw_exp exp ^^ string ")" + +and pp_raw_internal_loop_measure x = match x with +| Measure_aux(internal_loop_measure_aux,l) -> string "Measure_aux" ^^ string "(" ^^ pp_raw_internal_loop_measure_aux internal_loop_measure_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_exp_aux x = match x with +| E_aux(E_block(exp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_block" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (exp0) -> string "(" ^^ pp_raw_exp exp0 ^^ string ")") exp0) ^^ string "]" ^^ string ")" +| E_aux(E_id(id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_id" ^^ string "(" ^^ pp_raw_id id ^^ string ")" +| E_aux(E_lit(lit),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_lit" ^^ string "(" ^^ pp_raw_lit lit ^^ string ")" +| E_aux(E_cast(typ,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_cast" ^^ string "(" ^^ pp_raw_typ typ ^^ string "," ^^ pp_raw_exp exp ^^ string ")" +| E_aux(E_app(id,exp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_app" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (exp0) -> string "(" ^^ pp_raw_exp exp0 ^^ string ")") exp0) ^^ string "]" ^^ string ")" +| E_aux(E_app_infix(exp1,id,exp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_app_infix" ^^ string "(" ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_id id ^^ string "," ^^ pp_raw_exp exp2 ^^ string ")" +| E_aux(E_tuple(exp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_tuple" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (exp0) -> string "(" ^^ pp_raw_exp exp0 ^^ string ")") exp0) ^^ string "]" ^^ string ")" +| E_aux(E_if(exp1,exp2,exp3),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_if" ^^ string "(" ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp2 ^^ string "," ^^ pp_raw_exp exp3 ^^ string ")" +| E_aux(E_loop(loop,internal_loop_measure,exp1,exp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_loop" ^^ string "(" ^^ pp_raw_loop loop ^^ string "," ^^ pp_raw_internal_loop_measure internal_loop_measure ^^ string "," ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp2 ^^ string ")" +| E_aux(E_for(id,exp1,exp2,exp3,order,exp4),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_for" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp2 ^^ string "," ^^ pp_raw_exp exp3 ^^ string "," ^^ pp_raw_order order ^^ string "," ^^ pp_raw_exp exp4 ^^ string ")" +| E_aux(E_vector(exp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_vector" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (exp0) -> string "(" ^^ pp_raw_exp exp0 ^^ string ")") exp0) ^^ string "]" ^^ string ")" +| E_aux(E_vector_access(exp,exp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_vector_access" ^^ string "(" ^^ pp_raw_exp exp ^^ string "," ^^ pp_raw_exp exp_prime ^^ string ")" +| E_aux(E_vector_subrange(exp,exp1,exp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_vector_subrange" ^^ string "(" ^^ pp_raw_exp exp ^^ string "," ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp2 ^^ string ")" +| E_aux(E_vector_update(exp,exp1,exp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_vector_update" ^^ string "(" ^^ pp_raw_exp exp ^^ string "," ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp2 ^^ string ")" +| E_aux(E_vector_update_subrange(exp,exp1,exp2,exp3),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_vector_update_subrange" ^^ string "(" ^^ pp_raw_exp exp ^^ string "," ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp2 ^^ string "," ^^ pp_raw_exp exp3 ^^ string ")" +| E_aux(E_vector_append(exp1,exp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_vector_append" ^^ string "(" ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp2 ^^ string ")" +| E_aux(E_list(exp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_list" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (exp0) -> string "(" ^^ pp_raw_exp exp0 ^^ string ")") exp0) ^^ string "]" ^^ string ")" +| E_aux(E_cons(exp1,exp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_cons" ^^ string "(" ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp2 ^^ string ")" +| E_aux(E_record(fexp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_record" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (fexp0) -> string "(" ^^ pp_raw_fexp fexp0 ^^ string ")") fexp0) ^^ string "]" ^^ string ")" +| E_aux(E_record_update(exp,fexp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_record_update" ^^ string "(" ^^ pp_raw_exp exp ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (fexp0) -> string "(" ^^ pp_raw_fexp fexp0 ^^ string ")") fexp0) ^^ string "]" ^^ string ")" +| E_aux(E_field(exp,id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_field" ^^ string "(" ^^ pp_raw_exp exp ^^ string "," ^^ pp_raw_id id ^^ string ")" +| E_aux(E_case(exp,pexp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_case" ^^ string "(" ^^ pp_raw_exp exp ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (pexp0) -> string "(" ^^ pp_raw_pexp pexp0 ^^ string ")") pexp0) ^^ string "]" ^^ string ")" +| E_aux(E_let(letbind,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_let" ^^ string "(" ^^ pp_raw_letbind letbind ^^ string "," ^^ pp_raw_exp exp ^^ string ")" +| E_aux(E_assign(lexp,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_assign" ^^ string "(" ^^ pp_raw_lexp lexp ^^ string "," ^^ pp_raw_exp exp ^^ string ")" +| E_aux(E_sizeof(nexp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_sizeof" ^^ string "(" ^^ pp_raw_nexp nexp ^^ string ")" +| E_aux(E_return(exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_return" ^^ string "(" ^^ pp_raw_exp exp ^^ string ")" +| E_aux(E_exit(exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_exit" ^^ string "(" ^^ pp_raw_exp exp ^^ string ")" +| E_aux(E_ref(id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_ref" ^^ string "(" ^^ pp_raw_id id ^^ string ")" +| E_aux(E_throw(exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_throw" ^^ string "(" ^^ pp_raw_exp exp ^^ string ")" +| E_aux(E_try(exp,pexp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_try" ^^ string "(" ^^ pp_raw_exp exp ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (pexp0) -> string "(" ^^ pp_raw_pexp pexp0 ^^ string ")") pexp0) ^^ string "]" ^^ string ")" +| E_aux(E_assert(exp,exp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_assert" ^^ string "(" ^^ pp_raw_exp exp ^^ string "," ^^ pp_raw_exp exp_prime ^^ string ")" +| E_aux(E_var(lexp,exp,exp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_var" ^^ string "(" ^^ pp_raw_lexp lexp ^^ string "," ^^ pp_raw_exp exp ^^ string "," ^^ pp_raw_exp exp_prime ^^ string ")" +| E_aux(E_internal_plet(pat,exp,exp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_internal_plet" ^^ string "(" ^^ pp_raw_pat pat ^^ string "," ^^ pp_raw_exp exp ^^ string "," ^^ pp_raw_exp exp_prime ^^ string ")" +| E_aux(E_internal_return(exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_internal_return" ^^ string "(" ^^ pp_raw_exp exp ^^ string ")" +| E_aux(E_internal_value(value),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_internal_value" ^^ string "(" ^^ string "\"" ^^ string value ^^ string "\"" ^^ string ")" +| E_aux(E_constraint(n_constraint),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "E_constraint" ^^ string "(" ^^ pp_raw_n_constraint n_constraint ^^ string ")" + +and pp_raw_exp x = match x with +| E_aux(exp_aux,annot) -> string "E_aux" ^^ string "(" ^^ pp_raw_exp_aux exp_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_lexp_aux x = match x with +| LEXP_aux(LEXP_id(id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "LEXP_id" ^^ string "(" ^^ pp_raw_id id ^^ string ")" +| LEXP_aux(LEXP_deref(exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "LEXP_deref" ^^ string "(" ^^ pp_raw_exp exp ^^ string ")" +| LEXP_aux(LEXP_memory(id,exp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "LEXP_memory" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (exp0) -> string "(" ^^ pp_raw_exp exp0 ^^ string ")") exp0) ^^ string "]" ^^ string ")" +| LEXP_aux(LEXP_cast(typ,id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "LEXP_cast" ^^ string "(" ^^ pp_raw_typ typ ^^ string "," ^^ pp_raw_id id ^^ string ")" +| LEXP_aux(LEXP_tup(lexp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "LEXP_tup" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (lexp0) -> string "(" ^^ pp_raw_lexp lexp0 ^^ string ")") lexp0) ^^ string "]" ^^ string ")" +| LEXP_aux(LEXP_vector_concat(lexp0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "LEXP_vector_concat" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (lexp0) -> string "(" ^^ pp_raw_lexp lexp0 ^^ string ")") lexp0) ^^ string "]" ^^ string ")" +| LEXP_aux(LEXP_vector(lexp,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "LEXP_vector" ^^ string "(" ^^ pp_raw_lexp lexp ^^ string "," ^^ pp_raw_exp exp ^^ string ")" +| LEXP_aux(LEXP_vector_range(lexp,exp1,exp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "LEXP_vector_range" ^^ string "(" ^^ pp_raw_lexp lexp ^^ string "," ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp2 ^^ string ")" +| LEXP_aux(LEXP_field(lexp,id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "LEXP_field" ^^ string "(" ^^ pp_raw_lexp lexp ^^ string "," ^^ pp_raw_id id ^^ string ")" + +and pp_raw_lexp x = match x with +| LEXP_aux(lexp_aux,annot) -> string "LEXP_aux" ^^ string "(" ^^ pp_raw_lexp_aux lexp_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_fexp_aux x = match x with +| FE_aux(FE_Fexp(id,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "FE_Fexp" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_exp exp ^^ string ")" + +and pp_raw_fexp x = match x with +| FE_aux(fexp_aux,annot) -> string "FE_aux" ^^ string "(" ^^ pp_raw_fexp_aux fexp_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_opt_default_aux x = match x with +| Def_val_aux(Def_val_empty,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Def_val_empty" +| Def_val_aux(Def_val_dec(exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Def_val_dec" ^^ string "(" ^^ pp_raw_exp exp ^^ string ")" + +and pp_raw_opt_default x = match x with +| Def_val_aux(opt_default_aux,annot) -> string "Def_val_aux" ^^ string "(" ^^ pp_raw_opt_default_aux opt_default_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_pexp_aux x = match x with +| Pat_aux(Pat_exp(pat,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Pat_exp" ^^ string "(" ^^ pp_raw_pat pat ^^ string "," ^^ pp_raw_exp exp ^^ string ")" +| Pat_aux(Pat_when(pat,exp1,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Pat_when" ^^ string "(" ^^ pp_raw_pat pat ^^ string "," ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp ^^ string ")" + +and pp_raw_pexp x = match x with +| Pat_aux(pexp_aux,annot) -> string "Pat_aux" ^^ string "(" ^^ pp_raw_pexp_aux pexp_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_tannot_opt_aux x = match x with +| Typ_annot_opt_aux(Typ_annot_opt_none,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Typ_annot_opt_none" +| Typ_annot_opt_aux(Typ_annot_opt_some(typquant,typ),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Typ_annot_opt_some" ^^ string "(" ^^ pp_raw_typquant typquant ^^ string "," ^^ pp_raw_typ typ ^^ string ")" + +and pp_raw_tannot_opt x = match x with +| Typ_annot_opt_aux(tannot_opt_aux,l) -> string "Typ_annot_opt_aux" ^^ string "(" ^^ pp_raw_tannot_opt_aux tannot_opt_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_rec_opt_aux x = match x with +| Rec_aux(Rec_nonrec,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Rec_nonrec" +| Rec_aux(Rec_rec,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Rec_rec" +| Rec_aux(Rec_measure(pat,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Rec_measure" ^^ string "(" ^^ pp_raw_pat pat ^^ string "," ^^ pp_raw_exp exp ^^ string ")" + +and pp_raw_rec_opt x = match x with +| Rec_aux(rec_opt_aux,l) -> string "Rec_aux" ^^ string "(" ^^ pp_raw_rec_opt_aux rec_opt_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_effect_opt_aux x = match x with +| Effect_opt_aux(Effect_opt_none,ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Effect_opt_none" +| Effect_opt_aux(Effect_opt_effect(effect),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "Effect_opt_effect" ^^ string "(" ^^ pp_raw_effect effect ^^ string ")" + +and pp_raw_effect_opt x = match x with +| Effect_opt_aux(effect_opt_aux,l) -> string "Effect_opt_aux" ^^ string "(" ^^ pp_raw_effect_opt_aux effect_opt_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_pexp_funcl x = match x with +| Pat_funcl_exp(pat,exp) -> string "Pat_funcl_exp" ^^ string "(" ^^ pp_raw_pat pat ^^ string "," ^^ pp_raw_exp exp ^^ string ")" +| Pat_funcl_when(pat,exp1,exp) -> string "Pat_funcl_when" ^^ string "(" ^^ pp_raw_pat pat ^^ string "," ^^ pp_raw_exp exp1 ^^ string "," ^^ pp_raw_exp exp ^^ string ")" + +and pp_raw_funcl_aux x = match x with +| FCL_aux(FCL_Funcl(id,pexp_funcl),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "FCL_Funcl" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_pexp_funcl pexp_funcl ^^ string ")" + +and pp_raw_funcl x = match x with +| FCL_aux(funcl_aux,annot) -> string "FCL_aux" ^^ string "(" ^^ pp_raw_funcl_aux funcl_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_fundef_aux x = match x with +| FD_aux(FD_function(rec_opt,tannot_opt,effect_opt,funcl0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "FD_function" ^^ string "(" ^^ pp_raw_rec_opt rec_opt ^^ string "," ^^ pp_raw_tannot_opt tannot_opt ^^ string "," ^^ pp_raw_effect_opt effect_opt ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (funcl0) -> string "(" ^^ pp_raw_funcl funcl0 ^^ string ")") funcl0) ^^ string "]" ^^ string ")" + +and pp_raw_fundef x = match x with +| FD_aux(fundef_aux,annot) -> string "FD_aux" ^^ string "(" ^^ pp_raw_fundef_aux fundef_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_mpat_aux x = match x with +| MP_aux(MP_lit(lit),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_lit" ^^ string "(" ^^ pp_raw_lit lit ^^ string ")" +| MP_aux(MP_id(id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_id" ^^ string "(" ^^ pp_raw_id id ^^ string ")" +| MP_aux(MP_app(id,mpat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_app" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (mpat0) -> string "(" ^^ pp_raw_mpat mpat0 ^^ string ")") mpat0) ^^ string "]" ^^ string ")" +| MP_aux(MP_vector(mpat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_vector" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (mpat0) -> string "(" ^^ pp_raw_mpat mpat0 ^^ string ")") mpat0) ^^ string "]" ^^ string ")" +| MP_aux(MP_vector_concat(mpat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_vector_concat" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (mpat0) -> string "(" ^^ pp_raw_mpat mpat0 ^^ string ")") mpat0) ^^ string "]" ^^ string ")" +| MP_aux(MP_tup(mpat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_tup" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (mpat0) -> string "(" ^^ pp_raw_mpat mpat0 ^^ string ")") mpat0) ^^ string "]" ^^ string ")" +| MP_aux(MP_list(mpat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_list" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (mpat0) -> string "(" ^^ pp_raw_mpat mpat0 ^^ string ")") mpat0) ^^ string "]" ^^ string ")" +| MP_aux(MP_cons(mpat1,mpat2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_cons" ^^ string "(" ^^ pp_raw_mpat mpat1 ^^ string "," ^^ pp_raw_mpat mpat2 ^^ string ")" +| MP_aux(MP_string_append(mpat0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_string_append" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (mpat0) -> string "(" ^^ pp_raw_mpat mpat0 ^^ string ")") mpat0) ^^ string "]" ^^ string ")" +| MP_aux(MP_typ(mpat,typ),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_typ" ^^ string "(" ^^ pp_raw_mpat mpat ^^ string "," ^^ pp_raw_typ typ ^^ string ")" +| MP_aux(MP_as(mpat,id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MP_as" ^^ string "(" ^^ pp_raw_mpat mpat ^^ string "," ^^ pp_raw_id id ^^ string ")" + +and pp_raw_mpat x = match x with +| MP_aux(mpat_aux,annot) -> string "MP_aux" ^^ string "(" ^^ pp_raw_mpat_aux mpat_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_mpexp_aux x = match x with +| MPat_aux(MPat_pat(mpat),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MPat_pat" ^^ string "(" ^^ pp_raw_mpat mpat ^^ string ")" +| MPat_aux(MPat_when(mpat,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MPat_when" ^^ string "(" ^^ pp_raw_mpat mpat ^^ string "," ^^ pp_raw_exp exp ^^ string ")" + +and pp_raw_mpexp x = match x with +| MPat_aux(mpexp_aux,annot) -> string "MPat_aux" ^^ string "(" ^^ pp_raw_mpexp_aux mpexp_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_mapcl_aux x = match x with +| MCL_aux(MCL_bidir(mpexp1,mpexp2),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MCL_bidir" ^^ string "(" ^^ pp_raw_mpexp mpexp1 ^^ string "," ^^ pp_raw_mpexp mpexp2 ^^ string ")" +| MCL_aux(MCL_forwards(mpexp,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MCL_forwards" ^^ string "(" ^^ pp_raw_mpexp mpexp ^^ string "," ^^ pp_raw_exp exp ^^ string ")" +| MCL_aux(MCL_backwards(mpexp,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MCL_backwards" ^^ string "(" ^^ pp_raw_mpexp mpexp ^^ string "," ^^ pp_raw_exp exp ^^ string ")" + +and pp_raw_mapcl x = match x with +| MCL_aux(mapcl_aux,annot) -> string "MCL_aux" ^^ string "(" ^^ pp_raw_mapcl_aux mapcl_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_mapdef_aux x = match x with +| MD_aux(MD_mapping(id,tannot_opt,mapcl0),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "MD_mapping" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_tannot_opt tannot_opt ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (mapcl0) -> string "(" ^^ pp_raw_mapcl mapcl0 ^^ string ")") mapcl0) ^^ string "]" ^^ string ")" + +and pp_raw_mapdef x = match x with +| MD_aux(mapdef_aux,annot) -> string "MD_aux" ^^ string "(" ^^ pp_raw_mapdef_aux mapdef_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_letbind_aux x = match x with +| LB_aux(LB_val(pat,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "LB_val" ^^ string "(" ^^ pp_raw_pat pat ^^ string "," ^^ pp_raw_exp exp ^^ string ")" + +and pp_raw_letbind x = match x with +| LB_aux(letbind_aux,annot) -> string "LB_aux" ^^ string "(" ^^ pp_raw_letbind_aux letbind_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_val_spec x = match x with +| VS_aux(val_spec_aux) -> string "VS_aux" ^^ string "(" ^^ pp_raw_val_spec_aux val_spec_aux ^^ string ")" + +and pp_raw_val_spec_aux x = match x with + +and pp_raw_default_spec_aux x = match x with +| DT_aux(DT_order(order),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "DT_order" ^^ string "(" ^^ pp_raw_order order ^^ string ")" + +and pp_raw_default_spec x = match x with +| DT_aux(default_spec_aux,l) -> string "DT_aux" ^^ string "(" ^^ pp_raw_default_spec_aux default_spec_aux ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_scattered_def_aux x = match x with +| SD_aux(SD_function(rec_opt,tannot_opt,effect_opt,id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "SD_function" ^^ string "(" ^^ pp_raw_rec_opt rec_opt ^^ string "," ^^ pp_raw_tannot_opt tannot_opt ^^ string "," ^^ pp_raw_effect_opt effect_opt ^^ string "," ^^ pp_raw_id id ^^ string ")" +| SD_aux(SD_funcl(funcl),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "SD_funcl" ^^ string "(" ^^ pp_raw_funcl funcl ^^ string ")" +| SD_aux(SD_variant(id,typquant),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "SD_variant" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_typquant typquant ^^ string ")" +| SD_aux(SD_unioncl(id,type_union),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "SD_unioncl" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_type_union type_union ^^ string ")" +| SD_aux(SD_mapping(id,tannot_opt),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "SD_mapping" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_tannot_opt tannot_opt ^^ string ")" +| SD_aux(SD_mapcl(id,mapcl),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "SD_mapcl" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_mapcl mapcl ^^ string ")" +| SD_aux(SD_end(id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "SD_end" ^^ string "(" ^^ pp_raw_id id ^^ string ")" + +and pp_raw_scattered_def x = match x with +| SD_aux(scattered_def_aux,annot) -> string "SD_aux" ^^ string "(" ^^ pp_raw_scattered_def_aux scattered_def_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_reg_id_aux x = match x with +| RI_aux(RI_id(id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "RI_id" ^^ string "(" ^^ pp_raw_id id ^^ string ")" + +and pp_raw_reg_id x = match x with +| RI_aux(reg_id_aux,annot) -> string "RI_aux" ^^ string "(" ^^ pp_raw_reg_id_aux reg_id_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_alias_spec_aux x = match x with +| AL_aux(AL_subreg(reg_id,id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "AL_subreg" ^^ string "(" ^^ pp_raw_reg_id reg_id ^^ string "," ^^ pp_raw_id id ^^ string ")" +| AL_aux(AL_bit(reg_id,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "AL_bit" ^^ string "(" ^^ pp_raw_reg_id reg_id ^^ string "," ^^ pp_raw_exp exp ^^ string ")" +| AL_aux(AL_slice(reg_id,exp,exp_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "AL_slice" ^^ string "(" ^^ pp_raw_reg_id reg_id ^^ string "," ^^ pp_raw_exp exp ^^ string "," ^^ pp_raw_exp exp_prime ^^ string ")" +| AL_aux(AL_concat(reg_id,reg_id_prime),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "AL_concat" ^^ string "(" ^^ pp_raw_reg_id reg_id ^^ string "," ^^ pp_raw_reg_id reg_id_prime ^^ string ")" + +and pp_raw_alias_spec x = match x with +| AL_aux(alias_spec_aux,annot) -> string "AL_aux" ^^ string "(" ^^ pp_raw_alias_spec_aux alias_spec_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_dec_spec_aux x = match x with +| DEC_aux(DEC_reg(effect,effect_prime,typ,id),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "DEC_reg" ^^ string "(" ^^ pp_raw_effect effect ^^ string "," ^^ pp_raw_effect effect_prime ^^ string "," ^^ pp_raw_typ typ ^^ string "," ^^ pp_raw_id id ^^ string ")" +| DEC_aux(DEC_config(id,typ,exp),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "DEC_config" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_typ typ ^^ string "," ^^ pp_raw_exp exp ^^ string ")" +| DEC_aux(DEC_alias(id,alias_spec),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "DEC_alias" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_alias_spec alias_spec ^^ string ")" +| DEC_aux(DEC_typ_alias(typ,id,alias_spec),ott_menhir_loc) -> string "[" ^^ string (pp_raw_l ott_menhir_loc) ^^ string "]" ^^ string "DEC_typ_alias" ^^ string "(" ^^ pp_raw_typ typ ^^ string "," ^^ pp_raw_id id ^^ string "," ^^ pp_raw_alias_spec alias_spec ^^ string ")" + +and pp_raw_dec_spec x = match x with +| DEC_aux(dec_spec_aux,annot) -> string "DEC_aux" ^^ string "(" ^^ pp_raw_dec_spec_aux dec_spec_aux ^^ string "," ^^ pp_raw_annot annot ^^ string ")" + +and pp_raw_prec x = match x with +| Infix -> string "Infix" +| InfixL -> string "InfixL" +| InfixR -> string "InfixR" + +and pp_raw_loop_measure x = match x with +| Loop(loop,exp) -> string "Loop" ^^ string "(" ^^ pp_raw_loop loop ^^ string "," ^^ pp_raw_exp exp ^^ string ")" + +and pp_raw_def x = match x with +| DEF_type(type_def) -> string "DEF_type" ^^ string "(" ^^ pp_raw_type_def type_def ^^ string ")" +| DEF_fundef(fundef) -> string "DEF_fundef" ^^ string "(" ^^ pp_raw_fundef fundef ^^ string ")" +| DEF_mapdef(mapdef) -> string "DEF_mapdef" ^^ string "(" ^^ pp_raw_mapdef mapdef ^^ string ")" +| DEF_val(letbind) -> string "DEF_val" ^^ string "(" ^^ pp_raw_letbind letbind ^^ string ")" +| DEF_spec(val_spec) -> string "DEF_spec" ^^ string "(" ^^ pp_raw_val_spec val_spec ^^ string ")" +| DEF_fixity(prec,num,id) -> string "DEF_fixity" ^^ string "(" ^^ pp_raw_prec prec ^^ string "," ^^ string "\"" ^^ string num ^^ string "\"" ^^ string "," ^^ pp_raw_id id ^^ string ")" +| DEF_overload(id,id0) -> string "DEF_overload" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (id0) -> string "(" ^^ pp_raw_id id0 ^^ string ")") id0) ^^ string "]" ^^ string ")" +| DEF_default(default_spec) -> string "DEF_default" ^^ string "(" ^^ pp_raw_default_spec default_spec ^^ string ")" +| DEF_scattered(scattered_def) -> string "DEF_scattered" ^^ string "(" ^^ pp_raw_scattered_def scattered_def ^^ string ")" +| DEF_measure(id,pat,exp) -> string "DEF_measure" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ pp_raw_pat pat ^^ string "," ^^ pp_raw_exp exp ^^ string ")" +| DEF_loop_measures(id,loop_measure0) -> string "DEF_loop_measures" ^^ string "(" ^^ pp_raw_id id ^^ string "," ^^ string "[" ^^ separate (string ";") (List.map (function (loop_measure0) -> string "(" ^^ pp_raw_loop_measure loop_measure0 ^^ string ")") loop_measure0) ^^ string "]" ^^ string ")" +| DEF_reg_dec(dec_spec) -> string "DEF_reg_dec" ^^ string "(" ^^ pp_raw_dec_spec dec_spec ^^ string ")" +| DEF_internal_mutrec(fundef0) -> string "DEF_internal_mutrec" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (fundef0) -> string "(" ^^ pp_raw_fundef fundef0 ^^ string ")") fundef0) ^^ string "]" ^^ string ")" +| DEF_pragma(string1,string2,l) -> string "DEF_pragma" ^^ string "(" ^^ string "\"" ^^ string string1 ^^ string "\"" ^^ string "," ^^ string "\"" ^^ string string2 ^^ string "\"" ^^ string "," ^^ pp_raw_l l ^^ string ")" + +and pp_raw_defs x = match x with +| Defs(def0) -> string "Defs" ^^ string "(" ^^ string "[" ^^ separate (string ";") (List.map (function (def0) -> string "(" ^^ pp_raw_def def0 ^^ string ")") def0) ^^ string "]" ^^ string ")" + + +let rec pp_l_default + +and pp_id_aux x = match x with +| Id_aux_aux(Id(x),ott_menhir_loc) -> string x +| Id_aux_aux(Operator(x),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ string "operator" ^^ string " " ^^ string x ^^ string " " ^^ string ")" ^^ string ")" + +and pp_id x = match x with +| Id_aux(id_aux,l) -> string "(" ^^ pp_id_aux id_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_kid_aux x = match x with +| Kid_aux_aux(Var(x),ott_menhir_loc) -> string "(" ^^ string "'" ^^ string " " ^^ string x ^^ string ")" + +and pp_kid x = match x with +| Kid_aux(kid_aux,l) -> string "(" ^^ pp_kid_aux kid_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_kind_aux x = match x with +| K_aux(K_type,ott_menhir_loc) -> string "Type" +| K_aux(K_int,ott_menhir_loc) -> string "Int" +| K_aux(K_order,ott_menhir_loc) -> string "Order" +| K_aux(K_bool,ott_menhir_loc) -> string "Bool" + +and pp_kind x = match x with +| K_aux(kind_aux,l) -> string "(" ^^ pp_kind_aux kind_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_nexp_aux x = match x with +| Nexp_aux(Nexp_id(id),ott_menhir_loc) -> pp_id id +| Nexp_aux(Nexp_var(kid),ott_menhir_loc) -> pp_kid kid +| Nexp_aux(Nexp_constant(num),ott_menhir_loc) -> string num +| Nexp_aux(Nexp_app(id,nexp0),ott_menhir_loc) -> string "(" ^^ pp_id id ^^ string " " ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (nexp0) -> pp_nexp nexp0) nexp0) ^^ string " " ^^ string ")" ^^ string ")" +| Nexp_aux(Nexp_times(nexp1,nexp2),ott_menhir_loc) -> string "(" ^^ pp_nexp nexp1 ^^ string " " ^^ string "*" ^^ string " " ^^ pp_nexp nexp2 ^^ string ")" +| Nexp_aux(Nexp_sum(nexp1,nexp2),ott_menhir_loc) -> string "(" ^^ pp_nexp nexp1 ^^ string " " ^^ string "+" ^^ string " " ^^ pp_nexp nexp2 ^^ string ")" +| Nexp_aux(Nexp_minus(nexp1,nexp2),ott_menhir_loc) -> string "(" ^^ pp_nexp nexp1 ^^ string " " ^^ string "-" ^^ string " " ^^ pp_nexp nexp2 ^^ string ")" +| Nexp_aux(Nexp_exp(nexp),ott_menhir_loc) -> string "(" ^^ string "2" ^^ string " " ^^ string "^" ^^ string " " ^^ pp_nexp nexp ^^ string ")" +| Nexp_aux(Nexp_neg(nexp),ott_menhir_loc) -> string "(" ^^ string "-" ^^ string " " ^^ pp_nexp nexp ^^ string ")" + +and pp_nexp x = match x with +| Nexp_aux(nexp_aux,l) -> string "(" ^^ pp_nexp_aux nexp_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_order_aux x = match x with +| Ord_aux(Ord_var(kid),ott_menhir_loc) -> pp_kid kid +| Ord_aux(Ord_inc,ott_menhir_loc) -> string "inc" +| Ord_aux(Ord_dec,ott_menhir_loc) -> string "dec" + +and pp_order x = match x with +| Ord_aux(order_aux,l) -> string "(" ^^ pp_order_aux order_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_base_effect_aux x = match x with +| BE_aux(BE_rreg,ott_menhir_loc) -> string "rreg" +| BE_aux(BE_wreg,ott_menhir_loc) -> string "wreg" +| BE_aux(BE_rmem,ott_menhir_loc) -> string "rmem" +| BE_aux(BE_rmemt,ott_menhir_loc) -> string "rmemt" +| BE_aux(BE_wmem,ott_menhir_loc) -> string "wmem" +| BE_aux(BE_eamem,ott_menhir_loc) -> string "wmea" +| BE_aux(BE_exmem,ott_menhir_loc) -> string "exmem" +| BE_aux(BE_wmv,ott_menhir_loc) -> string "wmv" +| BE_aux(BE_wmvt,ott_menhir_loc) -> string "wmvt" +| BE_aux(BE_barr,ott_menhir_loc) -> string "barr" +| BE_aux(BE_depend,ott_menhir_loc) -> string "depend" +| BE_aux(BE_undef,ott_menhir_loc) -> string "undef" +| BE_aux(BE_unspec,ott_menhir_loc) -> string "unspec" +| BE_aux(BE_nondet,ott_menhir_loc) -> string "nondet" +| BE_aux(BE_escape,ott_menhir_loc) -> string "escape" +| BE_aux(BE_config,ott_menhir_loc) -> string "config" + +and pp_base_effect x = match x with +| BE_aux(base_effect_aux,l) -> string "(" ^^ pp_base_effect_aux base_effect_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_effect_aux x = match x with +| Effect_aux(Effect_set(base_effect0),ott_menhir_loc) -> string "(" ^^ string "{" ^^ string " " ^^ separate (string ",") (List.map (function (base_effect0) -> pp_base_effect base_effect0) base_effect0) ^^ string " " ^^ string "}" ^^ string ")" + +and pp_effect x = match x with +| Effect_aux(effect_aux,l) -> string "(" ^^ pp_effect_aux effect_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_typ_aux x = match x with +| Typ_aux(Typ_internal_unknown,ott_menhir_loc) -> string "" +| Typ_aux(Typ_id(id),ott_menhir_loc) -> pp_id id +| Typ_aux(Typ_var(kid),ott_menhir_loc) -> pp_kid kid +| Typ_aux(Typ_fn(typ0,typ2,effect),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (typ0) -> pp_typ typ0) typ0) ^^ string " " ^^ string ")" ^^ string " " ^^ string "->" ^^ string " " ^^ pp_typ typ2 ^^ string " " ^^ string "effectkw" ^^ string " " ^^ pp_effect effect ^^ string ")" +| Typ_aux(Typ_bidir(typ1,typ2),ott_menhir_loc) -> string "(" ^^ pp_typ typ1 ^^ string " " ^^ string "<->" ^^ string " " ^^ pp_typ typ2 ^^ string ")" +| Typ_aux(Typ_tup(typ0),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (typ0) -> pp_typ typ0) typ0) ^^ string " " ^^ string ")" ^^ string ")" +| Typ_aux(Typ_app(id,typ_arg0),ott_menhir_loc) -> string "(" ^^ pp_id id ^^ string " " ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (typ_arg0) -> pp_typ_arg typ_arg0) typ_arg0) ^^ string " " ^^ string ")" ^^ string ")" +| Typ_aux(Typ_exist(kinded_id0,n_constraint,typ),ott_menhir_loc) -> string "(" ^^ string "{" ^^ string " " ^^ separate (string " ") (List.map (function (kinded_id0) -> pp_kinded_id kinded_id0) kinded_id0) ^^ string " " ^^ string "," ^^ string " " ^^ pp_n_constraint n_constraint ^^ string " " ^^ string "." ^^ string " " ^^ pp_typ typ ^^ string " " ^^ string "}" ^^ string ")" + +and pp_typ x = match x with +| Typ_aux(typ_aux,l) -> string "(" ^^ pp_typ_aux typ_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_typ_arg_aux x = match x with +| A_aux(A_nexp(nexp),ott_menhir_loc) -> pp_nexp nexp +| A_aux(A_typ(typ),ott_menhir_loc) -> pp_typ typ +| A_aux(A_order(order),ott_menhir_loc) -> pp_order order +| A_aux(A_bool(n_constraint),ott_menhir_loc) -> pp_n_constraint n_constraint + +and pp_typ_arg x = match x with +| A_aux(typ_arg_aux,l) -> string "(" ^^ pp_typ_arg_aux typ_arg_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_n_constraint_aux x = match x with +| NC_aux(NC_equal(nexp,nexp_prime),ott_menhir_loc) -> string "(" ^^ pp_nexp nexp ^^ string " " ^^ string "==" ^^ string " " ^^ pp_nexp nexp_prime ^^ string ")" +| NC_aux(NC_bounded_ge(nexp,nexp_prime),ott_menhir_loc) -> string "(" ^^ pp_nexp nexp ^^ string " " ^^ string ">=" ^^ string " " ^^ pp_nexp nexp_prime ^^ string ")" +| NC_aux(NC_bounded_gt(nexp,nexp_prime),ott_menhir_loc) -> string "(" ^^ pp_nexp nexp ^^ string " " ^^ string ">" ^^ string " " ^^ pp_nexp nexp_prime ^^ string ")" +| NC_aux(NC_bounded_le(nexp,nexp_prime),ott_menhir_loc) -> string "(" ^^ pp_nexp nexp ^^ string " " ^^ string "<=" ^^ string " " ^^ pp_nexp nexp_prime ^^ string ")" +| NC_aux(NC_bounded_lt(nexp,nexp_prime),ott_menhir_loc) -> string "(" ^^ pp_nexp nexp ^^ string " " ^^ string "<" ^^ string " " ^^ pp_nexp nexp_prime ^^ string ")" +| NC_aux(NC_not_equal(nexp,nexp_prime),ott_menhir_loc) -> string "(" ^^ pp_nexp nexp ^^ string " " ^^ string "!=" ^^ string " " ^^ pp_nexp nexp_prime ^^ string ")" +| NC_aux(NC_set(kid,num0),ott_menhir_loc) -> string "(" ^^ pp_kid kid ^^ string " " ^^ string "IN" ^^ string " " ^^ string "{" ^^ string " " ^^ separate (string ",") (List.map (function (num0) -> string num0) num0) ^^ string " " ^^ string "}" ^^ string ")" +| NC_aux(NC_or(n_constraint,n_constraint_prime),ott_menhir_loc) -> string "(" ^^ pp_n_constraint n_constraint ^^ string " " ^^ string "&" ^^ string " " ^^ pp_n_constraint n_constraint_prime ^^ string ")" +| NC_aux(NC_and(n_constraint,n_constraint_prime),ott_menhir_loc) -> string "(" ^^ pp_n_constraint n_constraint ^^ string " " ^^ string "|" ^^ string " " ^^ pp_n_constraint n_constraint_prime ^^ string ")" +| NC_aux(NC_app(id,typ_arg0),ott_menhir_loc) -> string "(" ^^ pp_id id ^^ string " " ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (typ_arg0) -> pp_typ_arg typ_arg0) typ_arg0) ^^ string " " ^^ string ")" ^^ string ")" +| NC_aux(NC_var(kid),ott_menhir_loc) -> pp_kid kid +| NC_aux(NC_true,ott_menhir_loc) -> string "true" +| NC_aux(NC_false,ott_menhir_loc) -> string "false" + +and pp_n_constraint x = match x with +| NC_aux(n_constraint_aux,l) -> string "(" ^^ pp_n_constraint_aux n_constraint_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_kinded_id_aux x = match x with +| KOpt_aux(KOpt_kind(kind,kid),ott_menhir_loc) -> string "(" ^^ pp_kind kind ^^ string " " ^^ pp_kid kid ^^ string ")" + +and pp_kinded_id x = match x with +| KOpt_aux(kinded_id_aux,l) -> string "(" ^^ pp_kinded_id_aux kinded_id_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_quant_item_aux x = match x with +| QI_aux(QI_id(kinded_id),ott_menhir_loc) -> pp_kinded_id kinded_id +| QI_aux(QI_constraint(n_constraint),ott_menhir_loc) -> pp_n_constraint n_constraint +| QI_aux(QI_constant(kinded_id0),ott_menhir_loc) -> separate (string " ") (List.map (function (kinded_id0) -> pp_kinded_id kinded_id0) kinded_id0) + +and pp_quant_item x = match x with +| QI_aux(quant_item_aux,l) -> string "(" ^^ pp_quant_item_aux quant_item_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_typquant_aux x = match x with +| TypQ_aux(TypQ_tq(quant_item0),ott_menhir_loc) -> string "(" ^^ string "forall" ^^ string " " ^^ separate (string ",") (List.map (function (quant_item0) -> pp_quant_item quant_item0) quant_item0) ^^ string " " ^^ string "." ^^ string ")" +| TypQ_aux(TypQ_no_forall,ott_menhir_loc) -> string "" + +and pp_typquant x = match x with +| TypQ_aux(typquant_aux,l) -> string "(" ^^ pp_typquant_aux typquant_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_typschm_aux x = match x with +| TypSchm_aux(TypSchm_ts(typquant,typ),ott_menhir_loc) -> string "(" ^^ pp_typquant typquant ^^ string " " ^^ pp_typ typ ^^ string ")" + +and pp_typschm x = match x with +| TypSchm_aux(typschm_aux,l) -> string "(" ^^ pp_typschm_aux typschm_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_type_def x = match x with +| TD_aux(type_def_aux) -> pp_type_def_aux type_def_aux + +and pp_type_def_aux x = match x with +| TD_abbrev(id,typquant,typ_arg) -> string "(" ^^ string "type" ^^ string " " ^^ pp_id id ^^ string " " ^^ pp_typquant typquant ^^ string " " ^^ string "=" ^^ string " " ^^ pp_typ_arg typ_arg ^^ string ")" +| TD_record(id,typquant,typ0_id0,semi_opt) -> string "(" ^^ string "typedef" ^^ string " " ^^ pp_id id ^^ string " " ^^ string "=" ^^ string " " ^^ string "const" ^^ string " " ^^ string "struct" ^^ string " " ^^ pp_typquant typquant ^^ string " " ^^ string "{" ^^ string " " ^^ separate (string ";") (List.map (function (typ0,id0) -> pp_typ typ0 ^^ string " " ^^ pp_id id0) typ0_id0) ^^ string " " ^^ pp_semi_opt semi_opt ^^ string " " ^^ string "}" ^^ string ")" +| TD_variant(id,typquant,type_union0,semi_opt) -> string "(" ^^ string "typedef" ^^ string " " ^^ pp_id id ^^ string " " ^^ string "=" ^^ string " " ^^ string "const" ^^ string " " ^^ string "union" ^^ string " " ^^ pp_typquant typquant ^^ string " " ^^ string "{" ^^ string " " ^^ separate (string ";") (List.map (function (type_union0) -> pp_type_union type_union0) type_union0) ^^ string " " ^^ pp_semi_opt semi_opt ^^ string " " ^^ string "}" ^^ string ")" +| TD_enum(id,id0,semi_opt) -> string "(" ^^ string "typedef" ^^ string " " ^^ pp_id id ^^ string " " ^^ string "=" ^^ string " " ^^ string "enumerate" ^^ string " " ^^ string "{" ^^ string " " ^^ separate (string ";") (List.map (function (id0) -> pp_id id0) id0) ^^ string " " ^^ pp_semi_opt semi_opt ^^ string " " ^^ string "}" ^^ string ")" +| TD_bitfield(id,typ,id0_index_range0) -> string "(" ^^ string "bitfield" ^^ string " " ^^ pp_id id ^^ string " " ^^ string ":" ^^ string " " ^^ pp_typ typ ^^ string " " ^^ string "=" ^^ string " " ^^ string "{" ^^ string " " ^^ separate (string ",") (List.map (function (id0,index_range0) -> pp_id id0 ^^ string " " ^^ string ":" ^^ string " " ^^ pp_index_range index_range0) id0_index_range0) ^^ string " " ^^ string "}" ^^ string ")" + +and pp_type_union_aux x = match x with +| Tu_aux(Tu_ty_id(typ,id),ott_menhir_loc) -> string "(" ^^ pp_typ typ ^^ string " " ^^ pp_id id ^^ string ")" + +and pp_type_union x = match x with +| Tu_aux(type_union_aux,l) -> string "(" ^^ pp_type_union_aux type_union_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_index_range_aux x = match x with +| BF_aux(BF_single(nexp),ott_menhir_loc) -> pp_nexp nexp +| BF_aux(BF_range(nexp1,nexp2),ott_menhir_loc) -> string "(" ^^ pp_nexp nexp1 ^^ string " " ^^ string ".." ^^ string " " ^^ pp_nexp nexp2 ^^ string ")" +| BF_aux(BF_concat(index_range1,index_range2),ott_menhir_loc) -> string "(" ^^ pp_index_range index_range1 ^^ string " " ^^ string "," ^^ string " " ^^ pp_index_range index_range2 ^^ string ")" + +and pp_index_range x = match x with +| BF_aux(index_range_aux,l) -> string "(" ^^ pp_index_range_aux index_range_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_lit_aux x = match x with +| L_aux(L_unit,ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ string ")" ^^ string ")" +| L_aux(L_zero,ott_menhir_loc) -> string "bitzero" +| L_aux(L_one,ott_menhir_loc) -> string "bitone" +| L_aux(L_true,ott_menhir_loc) -> string "true" +| L_aux(L_false,ott_menhir_loc) -> string "false" +| L_aux(L_num(num),ott_menhir_loc) -> string num +| L_aux(L_hex(hex),ott_menhir_loc) -> string hex +| L_aux(L_bin(bin),ott_menhir_loc) -> string bin +| L_aux(L_string(string),ott_menhir_loc) -> string string +| L_aux(L_undef,ott_menhir_loc) -> string "undefined" +| L_aux(L_real(real),ott_menhir_loc) -> string real + +and pp_lit x = match x with +| L_aux(lit_aux,l) -> string "(" ^^ pp_lit_aux lit_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_semi_opt_default + +and pp_typ_pat_aux x = match x with +| TP_aux(TP_wild,ott_menhir_loc) -> string "_" +| TP_aux(TP_var(kid),ott_menhir_loc) -> pp_kid kid +| TP_aux(TP_app(id,typ_pat0),ott_menhir_loc) -> string "(" ^^ pp_id id ^^ string " " ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (typ_pat0) -> pp_typ_pat typ_pat0) typ_pat0) ^^ string " " ^^ string ")" ^^ string ")" + +and pp_typ_pat x = match x with +| TP_aux(typ_pat_aux,l) -> string "(" ^^ pp_typ_pat_aux typ_pat_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_pat_aux x = match x with +| P_aux(P_lit(lit),ott_menhir_loc) -> pp_lit lit +| P_aux(P_wild,ott_menhir_loc) -> string "_" +| P_aux(P_or(pat1,pat2),ott_menhir_loc) -> string "(" ^^ pp_pat pat1 ^^ string " " ^^ string "|" ^^ string " " ^^ pp_pat pat2 ^^ string ")" +| P_aux(P_not(pat),ott_menhir_loc) -> string "(" ^^ string "~" ^^ string " " ^^ pp_pat pat ^^ string ")" +| P_aux(P_as(pat,id),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ pp_pat pat ^^ string " " ^^ string "as" ^^ string " " ^^ pp_id id ^^ string " " ^^ string ")" ^^ string ")" +| P_aux(P_typ(typ,pat),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ pp_typ typ ^^ string " " ^^ string ")" ^^ string " " ^^ pp_pat pat ^^ string ")" +| P_aux(P_id(id),ott_menhir_loc) -> pp_id id +| P_aux(P_var(pat,typ_pat),ott_menhir_loc) -> string "(" ^^ pp_pat pat ^^ string " " ^^ pp_typ_pat typ_pat ^^ string ")" +| P_aux(P_app(id,pat0),ott_menhir_loc) -> string "(" ^^ pp_id id ^^ string " " ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (pat0) -> pp_pat pat0) pat0) ^^ string " " ^^ string ")" ^^ string ")" +| P_aux(P_vector(pat0),ott_menhir_loc) -> string "(" ^^ string "[" ^^ string " " ^^ separate (string ",") (List.map (function (pat0) -> pp_pat pat0) pat0) ^^ string " " ^^ string "]" ^^ string ")" +| P_aux(P_vector_concat(pat0),ott_menhir_loc) -> separate (string "@") (List.map (function (pat0) -> pp_pat pat0) pat0) +| P_aux(P_tup(pat0),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (pat0) -> pp_pat pat0) pat0) ^^ string " " ^^ string ")" ^^ string ")" +| P_aux(P_list(pat0),ott_menhir_loc) -> string "(" ^^ string "[||" ^^ string " " ^^ separate (string ",") (List.map (function (pat0) -> pp_pat pat0) pat0) ^^ string " " ^^ string "||]" ^^ string ")" +| P_aux(P_cons(pat1,pat2),ott_menhir_loc) -> string "(" ^^ pp_pat pat1 ^^ string " " ^^ string "::" ^^ string " " ^^ pp_pat pat2 ^^ string ")" +| P_aux(P_string_append(pat0),ott_menhir_loc) -> separate (string "^^") (List.map (function (pat0) -> pp_pat pat0) pat0) + +and pp_pat x = match x with +| P_aux(pat_aux,annot) -> string "(" ^^ pp_pat_aux pat_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_loop_default + +and pp_internal_loop_measure_aux x = match x with +| Measure_aux(Measure_none,ott_menhir_loc) -> string "" +| Measure_aux(Measure_some(exp),ott_menhir_loc) -> string "(" ^^ string "termination_measure" ^^ string " " ^^ string "{" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "}" ^^ string ")" + +and pp_internal_loop_measure x = match x with +| Measure_aux(internal_loop_measure_aux,l) -> string "(" ^^ pp_internal_loop_measure_aux internal_loop_measure_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_exp_aux x = match x with +| E_aux(E_block(exp0),ott_menhir_loc) -> string "(" ^^ string "{" ^^ string " " ^^ separate (string ";") (List.map (function (exp0) -> pp_exp exp0) exp0) ^^ string " " ^^ string "}" ^^ string ")" +| E_aux(E_id(id),ott_menhir_loc) -> pp_id id +| E_aux(E_lit(lit),ott_menhir_loc) -> pp_lit lit +| E_aux(E_cast(typ,exp),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ pp_typ typ ^^ string " " ^^ string ")" ^^ string " " ^^ pp_exp exp ^^ string ")" +| E_aux(E_app(id,exp0),ott_menhir_loc) -> string "(" ^^ pp_id id ^^ string " " ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (exp0) -> pp_exp exp0) exp0) ^^ string " " ^^ string ")" ^^ string ")" +| E_aux(E_app_infix(exp1,id,exp2),ott_menhir_loc) -> string "(" ^^ pp_exp exp1 ^^ string " " ^^ pp_id id ^^ string " " ^^ pp_exp exp2 ^^ string ")" +| E_aux(E_tuple(exp0),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (exp0) -> pp_exp exp0) exp0) ^^ string " " ^^ string ")" ^^ string ")" +| E_aux(E_if(exp1,exp2,exp3),ott_menhir_loc) -> string "(" ^^ string "if" ^^ string " " ^^ pp_exp exp1 ^^ string " " ^^ string "then" ^^ string " " ^^ pp_exp exp2 ^^ string " " ^^ string "else" ^^ string " " ^^ pp_exp exp3 ^^ string ")" +| E_aux(E_loop(loop,internal_loop_measure,exp1,exp2),ott_menhir_loc) -> string "(" ^^ pp_loop loop ^^ string " " ^^ pp_internal_loop_measure internal_loop_measure ^^ string " " ^^ pp_exp exp1 ^^ string " " ^^ pp_exp exp2 ^^ string ")" +| E_aux(E_for(id,exp1,exp2,exp3,order,exp4),ott_menhir_loc) -> string "(" ^^ string "foreach" ^^ string " " ^^ string "(" ^^ string " " ^^ pp_id id ^^ string " " ^^ string "from" ^^ string " " ^^ pp_exp exp1 ^^ string " " ^^ string "to" ^^ string " " ^^ pp_exp exp2 ^^ string " " ^^ string "by" ^^ string " " ^^ pp_exp exp3 ^^ string " " ^^ string "in" ^^ string " " ^^ pp_order order ^^ string " " ^^ string ")" ^^ string " " ^^ pp_exp exp4 ^^ string ")" +| E_aux(E_vector(exp0),ott_menhir_loc) -> string "(" ^^ string "[" ^^ string " " ^^ separate (string ",") (List.map (function (exp0) -> pp_exp exp0) exp0) ^^ string " " ^^ string "]" ^^ string ")" +| E_aux(E_vector_access(exp,exp_prime),ott_menhir_loc) -> string "(" ^^ pp_exp exp ^^ string " " ^^ string "[" ^^ string " " ^^ pp_exp exp_prime ^^ string " " ^^ string "]" ^^ string ")" +| E_aux(E_vector_subrange(exp,exp1,exp2),ott_menhir_loc) -> string "(" ^^ pp_exp exp ^^ string " " ^^ string "[" ^^ string " " ^^ pp_exp exp1 ^^ string " " ^^ string ".." ^^ string " " ^^ pp_exp exp2 ^^ string " " ^^ string "]" ^^ string ")" +| E_aux(E_vector_update(exp,exp1,exp2),ott_menhir_loc) -> string "(" ^^ string "[" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "with" ^^ string " " ^^ pp_exp exp1 ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp2 ^^ string " " ^^ string "]" ^^ string ")" +| E_aux(E_vector_update_subrange(exp,exp1,exp2,exp3),ott_menhir_loc) -> string "(" ^^ string "[" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "with" ^^ string " " ^^ pp_exp exp1 ^^ string " " ^^ string ".." ^^ string " " ^^ pp_exp exp2 ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp3 ^^ string " " ^^ string "]" ^^ string ")" +| E_aux(E_vector_append(exp1,exp2),ott_menhir_loc) -> string "(" ^^ pp_exp exp1 ^^ string " " ^^ string "@" ^^ string " " ^^ pp_exp exp2 ^^ string ")" +| E_aux(E_list(exp0),ott_menhir_loc) -> string "(" ^^ string "[|" ^^ string " " ^^ separate (string ",") (List.map (function (exp0) -> pp_exp exp0) exp0) ^^ string " " ^^ string "|]" ^^ string ")" +| E_aux(E_cons(exp1,exp2),ott_menhir_loc) -> string "(" ^^ pp_exp exp1 ^^ string " " ^^ string "::" ^^ string " " ^^ pp_exp exp2 ^^ string ")" +| E_aux(E_record(fexp0),ott_menhir_loc) -> string "(" ^^ string "struct" ^^ string " " ^^ string "{" ^^ string " " ^^ separate (string ",") (List.map (function (fexp0) -> pp_fexp fexp0) fexp0) ^^ string " " ^^ string "}" ^^ string ")" +| E_aux(E_record_update(exp,fexp0),ott_menhir_loc) -> string "(" ^^ string "{" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "with" ^^ string " " ^^ separate (string ",") (List.map (function (fexp0) -> pp_fexp fexp0) fexp0) ^^ string " " ^^ string "}" ^^ string ")" +| E_aux(E_field(exp,id),ott_menhir_loc) -> string "(" ^^ pp_exp exp ^^ string " " ^^ string "." ^^ string " " ^^ pp_id id ^^ string ")" +| E_aux(E_case(exp,pexp0),ott_menhir_loc) -> string "(" ^^ string "match" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "{" ^^ string " " ^^ separate (string ",") (List.map (function (pexp0) -> pp_pexp pexp0) pexp0) ^^ string " " ^^ string "}" ^^ string ")" +| E_aux(E_let(letbind,exp),ott_menhir_loc) -> string "(" ^^ pp_letbind letbind ^^ string " " ^^ string "in" ^^ string " " ^^ pp_exp exp ^^ string ")" +| E_aux(E_assign(lexp,exp),ott_menhir_loc) -> string "(" ^^ pp_lexp lexp ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp ^^ string ")" +| E_aux(E_sizeof(nexp),ott_menhir_loc) -> string "(" ^^ string "sizeof" ^^ string " " ^^ pp_nexp nexp ^^ string ")" +| E_aux(E_return(exp),ott_menhir_loc) -> string "(" ^^ string "return" ^^ string " " ^^ pp_exp exp ^^ string ")" +| E_aux(E_exit(exp),ott_menhir_loc) -> string "(" ^^ string "exit" ^^ string " " ^^ pp_exp exp ^^ string ")" +| E_aux(E_ref(id),ott_menhir_loc) -> string "(" ^^ string "ref" ^^ string " " ^^ pp_id id ^^ string ")" +| E_aux(E_throw(exp),ott_menhir_loc) -> string "(" ^^ string "throw" ^^ string " " ^^ pp_exp exp ^^ string ")" +| E_aux(E_try(exp,pexp0),ott_menhir_loc) -> string "(" ^^ string "try" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "catch" ^^ string " " ^^ string "{" ^^ string " " ^^ separate (string ",") (List.map (function (pexp0) -> pp_pexp pexp0) pexp0) ^^ string " " ^^ string "}" ^^ string ")" +| E_aux(E_assert(exp,exp_prime),ott_menhir_loc) -> string "(" ^^ string "assert" ^^ string " " ^^ string "(" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "," ^^ string " " ^^ pp_exp exp_prime ^^ string " " ^^ string ")" ^^ string ")" +| E_aux(E_var(lexp,exp,exp_prime),ott_menhir_loc) -> string "(" ^^ string "var" ^^ string " " ^^ pp_lexp lexp ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "in" ^^ string " " ^^ pp_exp exp_prime ^^ string ")" +| E_aux(E_internal_plet(pat,exp,exp_prime),ott_menhir_loc) -> string "(" ^^ string "let" ^^ string " " ^^ pp_pat pat ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "in" ^^ string " " ^^ pp_exp exp_prime ^^ string ")" +| E_aux(E_internal_return(exp),ott_menhir_loc) -> string "(" ^^ string "return_int" ^^ string " " ^^ string "(" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string ")" ^^ string ")" +| E_aux(E_internal_value(value),ott_menhir_loc) -> string value +| E_aux(E_constraint(n_constraint),ott_menhir_loc) -> string "(" ^^ string "constraint" ^^ string " " ^^ pp_n_constraint n_constraint ^^ string ")" + +and pp_exp x = match x with +| E_aux(exp_aux,annot) -> string "(" ^^ pp_exp_aux exp_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_lexp_aux x = match x with +| LEXP_aux(LEXP_id(id),ott_menhir_loc) -> pp_id id +| LEXP_aux(LEXP_deref(exp),ott_menhir_loc) -> string "(" ^^ string "deref" ^^ string " " ^^ pp_exp exp ^^ string ")" +| LEXP_aux(LEXP_memory(id,exp0),ott_menhir_loc) -> string "(" ^^ pp_id id ^^ string " " ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (exp0) -> pp_exp exp0) exp0) ^^ string " " ^^ string ")" ^^ string ")" +| LEXP_aux(LEXP_cast(typ,id),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ pp_typ typ ^^ string " " ^^ string ")" ^^ string " " ^^ pp_id id ^^ string ")" +| LEXP_aux(LEXP_tup(lexp0),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (lexp0) -> pp_lexp lexp0) lexp0) ^^ string " " ^^ string ")" ^^ string ")" +| LEXP_aux(LEXP_vector_concat(lexp0),ott_menhir_loc) -> separate (string "@") (List.map (function (lexp0) -> pp_lexp lexp0) lexp0) +| LEXP_aux(LEXP_vector(lexp,exp),ott_menhir_loc) -> string "(" ^^ pp_lexp lexp ^^ string " " ^^ string "[" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "]" ^^ string ")" +| LEXP_aux(LEXP_vector_range(lexp,exp1,exp2),ott_menhir_loc) -> string "(" ^^ pp_lexp lexp ^^ string " " ^^ string "[" ^^ string " " ^^ pp_exp exp1 ^^ string " " ^^ string ".." ^^ string " " ^^ pp_exp exp2 ^^ string " " ^^ string "]" ^^ string ")" +| LEXP_aux(LEXP_field(lexp,id),ott_menhir_loc) -> string "(" ^^ pp_lexp lexp ^^ string " " ^^ string "." ^^ string " " ^^ pp_id id ^^ string ")" + +and pp_lexp x = match x with +| LEXP_aux(lexp_aux,annot) -> string "(" ^^ pp_lexp_aux lexp_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_fexp_aux x = match x with +| FE_aux(FE_Fexp(id,exp),ott_menhir_loc) -> string "(" ^^ pp_id id ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp ^^ string ")" + +and pp_fexp x = match x with +| FE_aux(fexp_aux,annot) -> string "(" ^^ pp_fexp_aux fexp_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_opt_default_aux x = match x with +| Def_val_aux(Def_val_empty,ott_menhir_loc) -> string "" +| Def_val_aux(Def_val_dec(exp),ott_menhir_loc) -> string "(" ^^ string ";" ^^ string " " ^^ string "default" ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp ^^ string ")" + +and pp_opt_default x = match x with +| Def_val_aux(opt_default_aux,annot) -> string "(" ^^ pp_opt_default_aux opt_default_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_pexp_aux x = match x with +| Pat_aux(Pat_exp(pat,exp),ott_menhir_loc) -> string "(" ^^ pp_pat pat ^^ string " " ^^ string "->" ^^ string " " ^^ pp_exp exp ^^ string ")" +| Pat_aux(Pat_when(pat,exp1,exp),ott_menhir_loc) -> string "(" ^^ pp_pat pat ^^ string " " ^^ string "when" ^^ string " " ^^ pp_exp exp1 ^^ string " " ^^ string "->" ^^ string " " ^^ pp_exp exp ^^ string ")" + +and pp_pexp x = match x with +| Pat_aux(pexp_aux,annot) -> string "(" ^^ pp_pexp_aux pexp_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_tannot_opt_aux x = match x with +| Typ_annot_opt_aux(Typ_annot_opt_none,ott_menhir_loc) -> string "" +| Typ_annot_opt_aux(Typ_annot_opt_some(typquant,typ),ott_menhir_loc) -> string "(" ^^ pp_typquant typquant ^^ string " " ^^ pp_typ typ ^^ string ")" + +and pp_tannot_opt x = match x with +| Typ_annot_opt_aux(tannot_opt_aux,l) -> string "(" ^^ pp_tannot_opt_aux tannot_opt_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_rec_opt_aux x = match x with +| Rec_aux(Rec_nonrec,ott_menhir_loc) -> string "" +| Rec_aux(Rec_rec,ott_menhir_loc) -> string "rec" +| Rec_aux(Rec_measure(pat,exp),ott_menhir_loc) -> string "(" ^^ string "{" ^^ string " " ^^ pp_pat pat ^^ string " " ^^ string "->" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "}" ^^ string ")" + +and pp_rec_opt x = match x with +| Rec_aux(rec_opt_aux,l) -> string "(" ^^ pp_rec_opt_aux rec_opt_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_effect_opt_aux x = match x with +| Effect_opt_aux(Effect_opt_none,ott_menhir_loc) -> string "" +| Effect_opt_aux(Effect_opt_effect(effect),ott_menhir_loc) -> string "(" ^^ string "effectkw" ^^ string " " ^^ pp_effect effect ^^ string ")" + +and pp_effect_opt x = match x with +| Effect_opt_aux(effect_opt_aux,l) -> string "(" ^^ pp_effect_opt_aux effect_opt_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_pexp_funcl x = match x with +| Pat_funcl_exp(pat,exp) -> string "(" ^^ pp_pat pat ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp ^^ string ")" +| Pat_funcl_when(pat,exp1,exp) -> string "(" ^^ string "(" ^^ string " " ^^ pp_pat pat ^^ string " " ^^ string "when" ^^ string " " ^^ pp_exp exp1 ^^ string " " ^^ string ")" ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp ^^ string ")" + +and pp_funcl_aux x = match x with +| FCL_aux(FCL_Funcl(id,pexp_funcl),ott_menhir_loc) -> string "(" ^^ pp_id id ^^ string " " ^^ pp_pexp_funcl pexp_funcl ^^ string ")" + +and pp_funcl x = match x with +| FCL_aux(funcl_aux,annot) -> string "(" ^^ pp_funcl_aux funcl_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_fundef_aux x = match x with +| FD_aux(FD_function(rec_opt,tannot_opt,effect_opt,funcl0),ott_menhir_loc) -> string "(" ^^ string "function" ^^ string " " ^^ pp_rec_opt rec_opt ^^ string " " ^^ pp_tannot_opt tannot_opt ^^ string " " ^^ pp_effect_opt effect_opt ^^ string " " ^^ separate (string "and") (List.map (function (funcl0) -> pp_funcl funcl0) funcl0) ^^ string ")" + +and pp_fundef x = match x with +| FD_aux(fundef_aux,annot) -> string "(" ^^ pp_fundef_aux fundef_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_mpat_aux x = match x with +| MP_aux(MP_lit(lit),ott_menhir_loc) -> pp_lit lit +| MP_aux(MP_id(id),ott_menhir_loc) -> pp_id id +| MP_aux(MP_app(id,mpat0),ott_menhir_loc) -> string "(" ^^ pp_id id ^^ string " " ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (mpat0) -> pp_mpat mpat0) mpat0) ^^ string " " ^^ string ")" ^^ string ")" +| MP_aux(MP_vector(mpat0),ott_menhir_loc) -> string "(" ^^ string "[" ^^ string " " ^^ separate (string ",") (List.map (function (mpat0) -> pp_mpat mpat0) mpat0) ^^ string " " ^^ string "]" ^^ string ")" +| MP_aux(MP_vector_concat(mpat0),ott_menhir_loc) -> separate (string "@") (List.map (function (mpat0) -> pp_mpat mpat0) mpat0) +| MP_aux(MP_tup(mpat0),ott_menhir_loc) -> string "(" ^^ string "(" ^^ string " " ^^ separate (string ",") (List.map (function (mpat0) -> pp_mpat mpat0) mpat0) ^^ string " " ^^ string ")" ^^ string ")" +| MP_aux(MP_list(mpat0),ott_menhir_loc) -> string "(" ^^ string "[||" ^^ string " " ^^ separate (string ",") (List.map (function (mpat0) -> pp_mpat mpat0) mpat0) ^^ string " " ^^ string "||]" ^^ string ")" +| MP_aux(MP_cons(mpat1,mpat2),ott_menhir_loc) -> string "(" ^^ pp_mpat mpat1 ^^ string " " ^^ string "::" ^^ string " " ^^ pp_mpat mpat2 ^^ string ")" +| MP_aux(MP_string_append(mpat0),ott_menhir_loc) -> separate (string "^^") (List.map (function (mpat0) -> pp_mpat mpat0) mpat0) +| MP_aux(MP_typ(mpat,typ),ott_menhir_loc) -> string "(" ^^ pp_mpat mpat ^^ string " " ^^ string ":" ^^ string " " ^^ pp_typ typ ^^ string ")" +| MP_aux(MP_as(mpat,id),ott_menhir_loc) -> string "(" ^^ pp_mpat mpat ^^ string " " ^^ string "as" ^^ string " " ^^ pp_id id ^^ string ")" + +and pp_mpat x = match x with +| MP_aux(mpat_aux,annot) -> string "(" ^^ pp_mpat_aux mpat_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_mpexp_aux x = match x with +| MPat_aux(MPat_pat(mpat),ott_menhir_loc) -> pp_mpat mpat +| MPat_aux(MPat_when(mpat,exp),ott_menhir_loc) -> string "(" ^^ pp_mpat mpat ^^ string " " ^^ string "when" ^^ string " " ^^ pp_exp exp ^^ string ")" + +and pp_mpexp x = match x with +| MPat_aux(mpexp_aux,annot) -> string "(" ^^ pp_mpexp_aux mpexp_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_mapcl_aux x = match x with +| MCL_aux(MCL_bidir(mpexp1,mpexp2),ott_menhir_loc) -> string "(" ^^ pp_mpexp mpexp1 ^^ string " " ^^ string "<->" ^^ string " " ^^ pp_mpexp mpexp2 ^^ string ")" +| MCL_aux(MCL_forwards(mpexp,exp),ott_menhir_loc) -> string "(" ^^ pp_mpexp mpexp ^^ string " " ^^ string "=>" ^^ string " " ^^ pp_exp exp ^^ string ")" +| MCL_aux(MCL_backwards(mpexp,exp),ott_menhir_loc) -> string "(" ^^ pp_mpexp mpexp ^^ string " " ^^ string "<-" ^^ string " " ^^ pp_exp exp ^^ string ")" + +and pp_mapcl x = match x with +| MCL_aux(mapcl_aux,annot) -> string "(" ^^ pp_mapcl_aux mapcl_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_mapdef_aux x = match x with +| MD_aux(MD_mapping(id,tannot_opt,mapcl0),ott_menhir_loc) -> string "(" ^^ string "mapping" ^^ string " " ^^ pp_id id ^^ string " " ^^ pp_tannot_opt tannot_opt ^^ string " " ^^ string "=" ^^ string " " ^^ string "{" ^^ string " " ^^ separate (string ",") (List.map (function (mapcl0) -> pp_mapcl mapcl0) mapcl0) ^^ string " " ^^ string "}" ^^ string ")" + +and pp_mapdef x = match x with +| MD_aux(mapdef_aux,annot) -> string "(" ^^ pp_mapdef_aux mapdef_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_letbind_aux x = match x with +| LB_aux(LB_val(pat,exp),ott_menhir_loc) -> string "(" ^^ string "let" ^^ string " " ^^ pp_pat pat ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp ^^ string ")" + +and pp_letbind x = match x with +| LB_aux(letbind_aux,annot) -> string "(" ^^ pp_letbind_aux letbind_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_val_spec x = match x with +| VS_aux(val_spec_aux) -> pp_val_spec_aux val_spec_aux + +and pp_val_spec_aux x = match x with + +and pp_default_spec_aux x = match x with +| DT_aux(DT_order(order),ott_menhir_loc) -> string "(" ^^ string "default" ^^ string " " ^^ string "Order" ^^ string " " ^^ pp_order order ^^ string ")" + +and pp_default_spec x = match x with +| DT_aux(default_spec_aux,l) -> string "(" ^^ pp_default_spec_aux default_spec_aux ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_scattered_def_aux x = match x with +| SD_aux(SD_function(rec_opt,tannot_opt,effect_opt,id),ott_menhir_loc) -> string "(" ^^ string "scattered" ^^ string " " ^^ string "function" ^^ string " " ^^ pp_rec_opt rec_opt ^^ string " " ^^ pp_tannot_opt tannot_opt ^^ string " " ^^ pp_effect_opt effect_opt ^^ string " " ^^ pp_id id ^^ string ")" +| SD_aux(SD_funcl(funcl),ott_menhir_loc) -> string "(" ^^ string "function" ^^ string " " ^^ string "clause" ^^ string " " ^^ pp_funcl funcl ^^ string ")" +| SD_aux(SD_variant(id,typquant),ott_menhir_loc) -> string "(" ^^ string "scattered" ^^ string " " ^^ string "typedef" ^^ string " " ^^ pp_id id ^^ string " " ^^ string "=" ^^ string " " ^^ string "const" ^^ string " " ^^ string "union" ^^ string " " ^^ pp_typquant typquant ^^ string ")" +| SD_aux(SD_unioncl(id,type_union),ott_menhir_loc) -> string "(" ^^ string "union" ^^ string " " ^^ pp_id id ^^ string " " ^^ string "member" ^^ string " " ^^ pp_type_union type_union ^^ string ")" +| SD_aux(SD_mapping(id,tannot_opt),ott_menhir_loc) -> string "(" ^^ string "scattered" ^^ string " " ^^ string "mapping" ^^ string " " ^^ pp_id id ^^ string " " ^^ string ":" ^^ string " " ^^ pp_tannot_opt tannot_opt ^^ string ")" +| SD_aux(SD_mapcl(id,mapcl),ott_menhir_loc) -> string "(" ^^ string "mapping" ^^ string " " ^^ string "clause" ^^ string " " ^^ pp_id id ^^ string " " ^^ string "=" ^^ string " " ^^ pp_mapcl mapcl ^^ string ")" +| SD_aux(SD_end(id),ott_menhir_loc) -> string "(" ^^ string "end" ^^ string " " ^^ pp_id id ^^ string ")" + +and pp_scattered_def x = match x with +| SD_aux(scattered_def_aux,annot) -> string "(" ^^ pp_scattered_def_aux scattered_def_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_reg_id_aux x = match x with +| RI_aux(RI_id(id),ott_menhir_loc) -> pp_id id + +and pp_reg_id x = match x with +| RI_aux(reg_id_aux,annot) -> string "(" ^^ pp_reg_id_aux reg_id_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_alias_spec_aux x = match x with +| AL_aux(AL_subreg(reg_id,id),ott_menhir_loc) -> string "(" ^^ pp_reg_id reg_id ^^ string " " ^^ string "." ^^ string " " ^^ pp_id id ^^ string ")" +| AL_aux(AL_bit(reg_id,exp),ott_menhir_loc) -> string "(" ^^ pp_reg_id reg_id ^^ string " " ^^ string "[" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string "]" ^^ string ")" +| AL_aux(AL_slice(reg_id,exp,exp_prime),ott_menhir_loc) -> string "(" ^^ pp_reg_id reg_id ^^ string " " ^^ string "[" ^^ string " " ^^ pp_exp exp ^^ string " " ^^ string ".." ^^ string " " ^^ pp_exp exp_prime ^^ string " " ^^ string "]" ^^ string ")" +| AL_aux(AL_concat(reg_id,reg_id_prime),ott_menhir_loc) -> string "(" ^^ pp_reg_id reg_id ^^ string " " ^^ string ":" ^^ string " " ^^ pp_reg_id reg_id_prime ^^ string ")" + +and pp_alias_spec x = match x with +| AL_aux(alias_spec_aux,annot) -> string "(" ^^ pp_alias_spec_aux alias_spec_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_dec_spec_aux x = match x with +| DEC_aux(DEC_reg(effect,effect_prime,typ,id),ott_menhir_loc) -> string "(" ^^ string "register" ^^ string " " ^^ pp_effect effect ^^ string " " ^^ pp_effect effect_prime ^^ string " " ^^ pp_typ typ ^^ string " " ^^ pp_id id ^^ string ")" +| DEC_aux(DEC_config(id,typ,exp),ott_menhir_loc) -> string "(" ^^ string "register" ^^ string " " ^^ string "configuration" ^^ string " " ^^ pp_id id ^^ string " " ^^ string ":" ^^ string " " ^^ pp_typ typ ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp ^^ string ")" +| DEC_aux(DEC_alias(id,alias_spec),ott_menhir_loc) -> string "(" ^^ string "register" ^^ string " " ^^ string "alias" ^^ string " " ^^ pp_id id ^^ string " " ^^ string "=" ^^ string " " ^^ pp_alias_spec alias_spec ^^ string ")" +| DEC_aux(DEC_typ_alias(typ,id,alias_spec),ott_menhir_loc) -> string "(" ^^ string "register" ^^ string " " ^^ string "alias" ^^ string " " ^^ pp_typ typ ^^ string " " ^^ pp_id id ^^ string " " ^^ string "=" ^^ string " " ^^ pp_alias_spec alias_spec ^^ string ")" + +and pp_dec_spec x = match x with +| DEC_aux(dec_spec_aux,annot) -> string "(" ^^ pp_dec_spec_aux dec_spec_aux ^^ string " " ^^ pp_annot annot ^^ string ")" + +and pp_prec x = match x with +| Infix -> string "infix" +| InfixL -> string "infixl" +| InfixR -> string "infixr" + +and pp_loop_measure x = match x with +| Loop(loop,exp) -> string "(" ^^ pp_loop loop ^^ string " " ^^ pp_exp exp ^^ string ")" + +and pp_def x = match x with +| DEF_type(type_def) -> pp_type_def type_def +| DEF_fundef(fundef) -> pp_fundef fundef +| DEF_mapdef(mapdef) -> pp_mapdef mapdef +| DEF_val(letbind) -> pp_letbind letbind +| DEF_spec(val_spec) -> pp_val_spec val_spec +| DEF_fixity(prec,num,id) -> string "(" ^^ string "fix" ^^ string " " ^^ pp_prec prec ^^ string " " ^^ string num ^^ string " " ^^ pp_id id ^^ string ")" +| DEF_overload(id,id0) -> string "(" ^^ string "overload" ^^ string " " ^^ pp_id id ^^ string " " ^^ string "[" ^^ string " " ^^ separate (string ";") (List.map (function (id0) -> pp_id id0) id0) ^^ string " " ^^ string "]" ^^ string ")" +| DEF_default(default_spec) -> pp_default_spec default_spec +| DEF_scattered(scattered_def) -> pp_scattered_def scattered_def +| DEF_measure(id,pat,exp) -> string "(" ^^ string "termination_measure" ^^ string " " ^^ pp_id id ^^ string " " ^^ pp_pat pat ^^ string " " ^^ string "=" ^^ string " " ^^ pp_exp exp ^^ string ")" +| DEF_loop_measures(id,loop_measure0) -> string "(" ^^ string "termination_measure" ^^ string " " ^^ pp_id id ^^ string " " ^^ separate (string ",") (List.map (function (loop_measure0) -> pp_loop_measure loop_measure0) loop_measure0) ^^ string ")" +| DEF_reg_dec(dec_spec) -> pp_dec_spec dec_spec +| DEF_internal_mutrec(fundef0) -> separate (string " ") (List.map (function (fundef0) -> pp_fundef fundef0) fundef0) +| DEF_pragma(string1,string2,l) -> string "(" ^^ string "$" ^^ string " " ^^ string string1 ^^ string " " ^^ string string2 ^^ string " " ^^ pp_l l ^^ string ")" + +and pp_defs x = match x with +| Defs(def0) -> separate (string " ") (List.map (function (def0) -> pp_def def0) def0) + diff --git a/src/slice.ml b/src/slice.ml index 1ac390bd..c249fb5a 100644 --- a/src/slice.ml +++ b/src/slice.ml @@ -130,7 +130,7 @@ and typ_ids' (Typ_aux (aux, _)) = IdSet.add id (List.fold_left IdSet.union IdSet.empty (List.map typ_arg_ids' args)) | Typ_fn (typs, typ, _) -> IdSet.union (typ_ids' typ) (List.fold_left IdSet.union IdSet.empty (List.map typ_ids' typs)) - | Typ_bidir (typ1, typ2) -> + | Typ_bidir (typ1, typ2, _) -> IdSet.union (typ_ids' typ1) (typ_ids' typ2) | Typ_tup typs -> List.fold_left IdSet.union IdSet.empty (List.map typ_ids' typs) @@ -169,13 +169,23 @@ let add_def_to_graph graph def = let scan_lexp self lexp_aux annot = let env = env_of_annot annot in begin match lexp_aux with - | LEXP_cast (typ, _) -> - IdSet.iter (fun id -> graph := G.add_edge self (Type id) !graph) (typ_ids typ) + | LEXP_cast (typ, id) -> + IdSet.iter (fun id -> graph := G.add_edge self (Type id) !graph) (typ_ids typ); + begin match Env.lookup_id id env with + | Register _ -> + graph := G.add_edge self (Register id) !graph + | Enum _ -> graph := G.add_edge self (Constructor id) !graph + | _ -> + if IdSet.mem id (Env.get_toplevel_lets env) then + graph := G.add_edge self (Letbind id) !graph + else () + end | LEXP_memory (id, _) -> graph := G.add_edge self (Function id) !graph | LEXP_id id -> begin match Env.lookup_id id env with - | Register _ -> graph := G.add_edge self (Register id) !graph + | Register _ -> + graph := G.add_edge self (Register id) !graph | Enum _ -> graph := G.add_edge self (Constructor id) !graph | _ -> if IdSet.mem id (Env.get_toplevel_lets env) then @@ -361,24 +371,20 @@ let () = let slice_roots = ref IdSet.empty in let slice_cuts = ref IdSet.empty in - (fun arg -> + ArgString ("identifiers", fun arg -> Action (fun () -> let args = Str.split (Str.regexp " +") arg in let ids = List.map mk_id args |> IdSet.of_list in Specialize.add_initial_calls ids; slice_roots := IdSet.union ids !slice_roots - ) |> register_command - ~name:"slice_roots" - ~help:(sprintf ":slice_roots %s - Set the roots for %s" (arg "identifiers") (command "slice")); + )) |> register_command ~name:"slice_roots" ~help:"Set the roots for :slice"; - (fun arg -> + ArgString ("identifiers", fun arg -> Action (fun () -> let args = Str.split (Str.regexp " +") arg in let ids = List.map mk_id args |> IdSet.of_list in slice_cuts := IdSet.union ids !slice_cuts - ) |> register_command - ~name:"slice_cuts" - ~help:(sprintf ":slice_cuts %s - Set the roots for %s" (arg "identifiers") (command "slice")); + )) |> register_command ~name:"slice_cuts" ~help:"Set the cuts for :slice"; - (fun arg -> + Action (fun () -> let module NodeSet = Set.Make(Node) in let module G = Graph.Make(Node) in let g = graph_of_ast !ast in @@ -388,10 +394,11 @@ let () = ast := filter_ast cuts g !ast ) |> register_command ~name:"slice" - ~help:(sprintf ":slice - Slice AST to the definitions which the functions given by %s depend on, up to the functions given by %s" - (command "slice_roots") (command "slice_cuts")); + ~help:"Slice AST to the definitions which the functions given \ + by :slice_roots depend on, up to the functions given \ + by :slice_cuts"; - (fun arg -> + Action (fun () -> let module NodeSet = Set.Make(Node) in let module NodeMap = Map.Make(Node) in let module G = Graph.Make(Node) in @@ -409,7 +416,7 @@ let () = ~name:"thin_slice" ~help:(sprintf ":thin_slice - Slice AST to the function definitions given with %s" (command "slice_roots")); - (fun arg -> + ArgString ("format", fun arg -> Action (fun () -> let format = if arg = "" then "svg" else arg in let dotfile, out_chan = Filename.open_temp_file "sail_graph_" ".gz" in let image = Filename.temp_file "sail_graph_" ("." ^ format) in @@ -418,9 +425,8 @@ let () = let _ = Unix.system (Printf.sprintf "dot -T%s %s -o %s" format dotfile image) in let _ = Unix.system (Printf.sprintf "xdg-open %s" image) in () - ) |> register_command - ~name:"graph" - ~help:(sprintf ":graph %s - Draw a callgraph using dot in %s (default svg if none provided), and open with xdg-open" - (arg "format") (arg "format")); + )) |> register_command + ~name:"graph" + ~help:"Draw a callgraph using dot in :0 (e.g. svg), and open with xdg-open" diff --git a/src/smtlib.ml b/src/smtlib.ml index b90f33a7..e12657c3 100644 --- a/src/smtlib.ml +++ b/src/smtlib.ml @@ -60,6 +60,30 @@ type smt_typ = | Tuple of smt_typ list | Array of smt_typ * smt_typ +let rec smt_typ_compare t1 t2 = + match t1, t2 with + | Bitvec n, Bitvec m -> compare n m + | Bool, Bool -> 0 + | String, String -> 0 + | Real, Real -> 0 + | Datatype (name1, _), Datatype (name2, _) -> String.compare name1 name2 + | Tuple ts1, Tuple ts2 -> Util.lex_ord_list smt_typ_compare ts1 ts2 + | Array (t11, t12), Array (t21, t22) -> + let c = smt_typ_compare t11 t21 in + if c = 0 then smt_typ_compare t12 t22 else c + | Bitvec _, _ -> 1 + | _, Bitvec _ -> -1 + | Bool, _ -> 1 + | _, Bool -> -1 + | String, _ -> 1 + | _, String -> -1 + | Real, _ -> 1 + | _, Real -> -1 + | Datatype _, _ -> 1 + | _, Datatype _ -> -1 + | Tuple _, _ -> 1 + | _, Tuple _ -> -1 + let rec smt_typ_equal t1 t2 = match t1, t2 with | Bitvec n, Bitvec m -> n = m @@ -89,11 +113,11 @@ let mk_variant name ctors = type smt_exp = | Bool_lit of bool - | Hex of string - | Bin of string + | Bitvec_lit of Sail2_values.bitU list | Real_lit of string | String_lit of string | Var of string + | Shared of string | Read_res of string | Enum of string | Fn of string * smt_exp list @@ -102,6 +126,11 @@ type smt_exp = | SignExtend of int * smt_exp | Extract of int * int * smt_exp | Tester of string * smt_exp + | Syntactic of smt_exp * smt_exp list + | Struct of string * (string * smt_exp) list + | Field of string * smt_exp + (* Used by sail-axiomatic, should never be generated by sail -smt! *) + | Forall of (string * smt_typ) list * smt_exp let rec fold_smt_exp f = function | Fn (name, args) -> f (Fn (name, List.map (fold_smt_exp f) args)) @@ -110,7 +139,11 @@ let rec fold_smt_exp f = function | SignExtend (n, exp) -> f (SignExtend (n, fold_smt_exp f exp)) | Extract (n, m, exp) -> f (Extract (n, m, fold_smt_exp f exp)) | Tester (ctor, exp) -> f (Tester (ctor, fold_smt_exp f exp)) - | (Bool_lit _ | Hex _ | Bin _ | Real_lit _ | String_lit _ | Var _ | Read_res _ | Enum _ as exp) -> f exp + | Forall (binders, exp) -> f (Forall (binders, fold_smt_exp f exp)) + | Syntactic (exp, exps) -> f (Syntactic (fold_smt_exp f exp, List.map (fold_smt_exp f) exps)) + | Field (name, exp) -> f (Field (name, fold_smt_exp f exp)) + | Struct (name, fields) -> f (Struct (name, List.map (fun (field, exp) -> field, fold_smt_exp f exp) fields)) + | (Bool_lit _ | Bitvec_lit _ | Real_lit _ | String_lit _ | Var _ | Shared _ | Read_res _ | Enum _ as exp) -> f exp let smt_conj = function | [] -> Bool_lit true @@ -136,21 +169,13 @@ let bvshl x y = Fn ("bvshl", [x; y]) let bvlshr x y = Fn ("bvlshr", [x; y]) let bvult x y = Fn ("bvult", [x; y]) -let bvzero n = - if n mod 4 = 0 then - Hex (String.concat "" (Util.list_init (n / 4) (fun _ -> "0"))) - else - Bin (String.concat "" (Util.list_init n (fun _ -> "0"))) +let bvzero n = Bitvec_lit (Sail2_operators_bitlists.zeros (Big_int.of_int n)) -let bvones n = - if n mod 4 = 0 then - Hex (String.concat "" (Util.list_init (n / 4) (fun _ -> "F"))) - else - Bin (String.concat "" (Util.list_init n (fun _ -> "1"))) +let bvones n = Bitvec_lit (Sail2_operators_bitlists.ones (Big_int.of_int n)) let simp_equal x y = match x, y with - | Bin str1, Bin str2 -> Some (str1 = str2) + | Bitvec_lit bv1, Bitvec_lit bv2 -> Some (Sail2_operators_bitlists.eq_vec bv1 bv2) | _, _ -> None let simp_and xs = @@ -175,6 +200,16 @@ let simp_or xs = else Fn ("or", xs) +let rec all_bitvec_lit = function + | Bitvec_lit _ :: rest -> all_bitvec_lit rest + | [] -> true + | _ :: _ -> false + +let rec merge_bitvec_lit = function + | Bitvec_lit b :: rest -> b @ merge_bitvec_lit rest + | [] -> [] + | _ :: _ -> assert false + let simp_fn = function | Fn ("not", [Fn ("not", [exp])]) -> exp | Fn ("not", [Bool_lit b]) -> Bool_lit (not b) @@ -184,6 +219,9 @@ let simp_fn = function | Fn ("and", xs) -> simp_and xs | Fn ("=>", [Bool_lit true; y]) -> y | Fn ("=>", [Bool_lit false; y]) -> Bool_lit true + | Fn ("bvsub", [Bitvec_lit bv1; Bitvec_lit bv2]) -> Bitvec_lit (Sail2_operators_bitlists.sub_vec bv1 bv2) + | Fn ("bvadd", [Bitvec_lit bv1; Bitvec_lit bv2]) -> Bitvec_lit (Sail2_operators_bitlists.add_vec bv1 bv2) + | Fn ("concat", xs) when all_bitvec_lit xs -> Bitvec_lit (merge_bitvec_lit xs) | Fn ("=", [x; y]) as exp -> begin match simp_equal x y with | Some b -> Bool_lit b @@ -205,7 +243,16 @@ let rec simp_smt_exp vars kinds = function | Some exp -> simp_smt_exp vars kinds exp | None -> Var v end - | (Read_res _ | Enum _ | Hex _ | Bin _ | Bool_lit _ | String_lit _ | Real_lit _ as exp) -> exp + | (Read_res _ | Shared _ | Enum _ | Bitvec_lit _ | Bool_lit _ | String_lit _ | Real_lit _ as exp) -> exp + | Field (field, exp) -> + let exp = simp_smt_exp vars kinds exp in + begin match exp with + | Struct (_, fields) -> + List.assoc field fields + | _ -> Field (field, exp) + end + | Struct (name, fields) -> + Struct (name, List.map (fun (field, exp) -> field, simp_smt_exp vars kinds exp) fields) | Fn (f, exps) -> let exps = List.map (simp_smt_exp vars kinds) exps in simp_fn (Fn (f, exps)) @@ -220,8 +267,8 @@ let rec simp_smt_exp vars kinds = function | Extract (i, j, exp) -> let exp = simp_smt_exp vars kinds exp in begin match exp with - | Bin str -> - Bin (String.sub str ((String.length str - 1) - i) ((i + 1) - j)) + | Bitvec_lit bv -> + Bitvec_lit (Sail2_operators_bitlists.subrange_vec_dec bv (Big_int.of_int i) (Big_int.of_int j)) | _ -> Extract (i, j, exp) end | Tester (str, exp) -> @@ -235,48 +282,167 @@ let rec simp_smt_exp vars kinds = function end | _ -> Tester (str, exp) end + | Syntactic (exp, _) -> exp | SignExtend (i, exp) -> let exp = simp_smt_exp vars kinds exp in - SignExtend (i, exp) + begin match exp with + | Bitvec_lit bv -> + Bitvec_lit (Sail2_operators_bitlists.sign_extend bv (Big_int.of_int (i + List.length bv))) + | _ -> SignExtend (i, exp) + end + | Forall (binders, exp) -> Forall (binders, exp) + +type read_info = { + name : string; + node : int; + active : smt_exp; + kind : smt_exp; + addr_type : smt_typ; + addr : smt_exp; + ret_type : smt_typ; + doc : string + } + +type write_info = { + name : string; + node : int; + active : smt_exp; + kind : smt_exp; + addr_type : smt_typ; + addr : smt_exp; + data_type : smt_typ; + data : smt_exp; + doc : string + } + +type barrier_info = { + name : string; + node : int; + active : smt_exp; + kind : smt_exp; + doc : string + } + +type branch_info = { + name : string; + node : int; + active : smt_exp; + addr_type : smt_typ; + addr : smt_exp; + doc : string + } + +type cache_op_info = { + name : string; + node : int; + active : smt_exp; + kind : smt_exp; + addr_type : smt_typ; + addr : smt_exp; + doc : string + } type smt_def = | Define_fun of string * (string * smt_typ) list * smt_typ * smt_exp + | Declare_fun of string * smt_typ list * smt_typ | Declare_const of string * smt_typ | Define_const of string * smt_typ * smt_exp - | Write_mem of string * int * smt_exp * smt_exp * smt_exp * smt_typ * smt_exp * smt_typ + (* Same as Define_const, but it'll never be removed by simplification *) + | Preserve_const of string * smt_typ * smt_exp + | Write_mem of write_info | Write_mem_ea of string * int * smt_exp * smt_exp * smt_exp * smt_typ * smt_exp * smt_typ - | Read_mem of string * int * smt_exp * smt_typ * smt_exp * smt_exp * smt_typ - | Barrier of string * int * smt_exp * smt_exp + | Read_mem of read_info + | Barrier of barrier_info + | Branch_announce of branch_info + | Cache_maintenance of cache_op_info | Excl_res of string * int * smt_exp | Declare_datatypes of string * (string * (string * smt_typ) list) list | Declare_tuple of int | Assert of smt_exp +let smt_def_map_exp f = function + | Define_fun (name, args, ty, exp) -> Define_fun (name, args, ty, f exp) + | Declare_fun (name, args, ty) -> Declare_fun (name, args, ty) + | Declare_const (name, ty) -> Declare_const (name, ty) + | Define_const (name, ty, exp) -> Define_const (name, ty, f exp) + | Preserve_const (name, ty, exp) -> Preserve_const (name, ty, f exp) + | Write_mem w -> Write_mem { w with active = f w.active; kind = f w.kind; addr = f w.addr; data = f w.data } + | Write_mem_ea (name, node, active, wk, addr, addr_ty, data_size, data_size_ty) -> + Write_mem_ea (name, node, f active, f wk, f addr, addr_ty, f data_size, data_size_ty) + | Read_mem r -> Read_mem { r with active = f r.active; kind = f r.kind; addr = f r.addr } + | Barrier b -> Barrier { b with active = f b.active; kind = f b.kind } + | Cache_maintenance m -> Cache_maintenance { m with active = f m.active; kind = f m.kind ; addr = f m.addr } + | Branch_announce c -> Branch_announce { c with active = f c.active; addr = f c.addr } + | Excl_res (name, node, active) -> Excl_res (name, node, f active) + | Declare_datatypes (name, ctors) -> Declare_datatypes (name, ctors) + | Declare_tuple n -> Declare_tuple n + | Assert exp -> Assert (f exp) + +let smt_def_iter_exp f = function + | Define_fun (name, args, ty, exp) -> f exp + | Define_const (name, ty, exp) -> f exp + | Preserve_const (name, ty, exp) -> f exp + | Write_mem w -> f w.active; f w.kind; f w.addr; f w.data + | Write_mem_ea (name, node, active, wk, addr, addr_ty, data_size, data_size_ty) -> + f active; f wk; f addr; f data_size + | Read_mem r -> f r.active; f r.kind; f r.addr + | Barrier b -> f b.active; f b.kind + | Cache_maintenance m -> f m.active; f m.kind; f m.addr + | Branch_announce c -> f c.active; f c.addr + | Excl_res (name, node, active) -> f active + | Assert exp -> f exp + | Declare_fun _ | Declare_const _ | Declare_tuple _ | Declare_datatypes _ -> () + let declare_datatypes = function | Datatype (name, ctors) -> Declare_datatypes (name, ctors) | _ -> assert false +(** For generating SMT with multiple threads (i.e. for litmus tests), + we suffix all the variables in the generated SMT with a thread + identifier to avoid any name clashes between the two threads. *) + let suffix_variables_exp sfx = - fold_smt_exp (function Var v -> Var (v ^ sfx) | exp -> exp) + fold_smt_exp (function Var v -> Var (v ^ sfx) | Read_res v -> Read_res (v ^ sfx) | exp -> exp) + +let suffix_variables_read_info sfx (r : read_info) = + let suffix exp = suffix_variables_exp sfx exp in + { r with name = r.name ^ sfx; active = suffix r.active; kind = suffix r.kind; addr = suffix r.addr } + +let suffix_variables_write_info sfx (w : write_info) = + let suffix exp = suffix_variables_exp sfx exp in + { w with name = w.name ^ sfx; active = suffix w.active; kind = suffix w.kind; addr = suffix w.addr; data = suffix w.data } + +let suffix_variables_barrier_info sfx (b : barrier_info) = + let suffix exp = suffix_variables_exp sfx exp in + { b with name = b.name ^ sfx; active = suffix b.active; kind = suffix b.kind } + +let suffix_variables_branch_info sfx (c : branch_info) = + let suffix exp = suffix_variables_exp sfx exp in + { c with name = c.name ^ sfx; active = suffix c.active; addr = suffix c.addr } + +let suffix_variables_cache_op_info sfx (m : cache_op_info) = + let suffix exp = suffix_variables_exp sfx exp in + { m with name = m.name ^ sfx; kind = suffix m.kind; active = suffix m.active; addr = suffix m.addr } let suffix_variables_def sfx = function | Define_fun (name, args, ty, exp) -> Define_fun (name ^ sfx, List.map (fun (arg, ty) -> sfx ^ arg, ty) args, ty, suffix_variables_exp sfx exp) + | Declare_fun (name, tys, ty) -> + Declare_fun (name ^ sfx, tys, ty) | Declare_const (name, ty) -> Declare_const (name ^ sfx, ty) | Define_const (name, ty, exp) -> Define_const (name ^ sfx, ty, suffix_variables_exp sfx exp) - | Write_mem (name, node, active, wk, addr, addr_ty, data, data_ty) -> - Write_mem (name ^ sfx, node, suffix_variables_exp sfx active, suffix_variables_exp sfx wk, - suffix_variables_exp sfx addr, addr_ty, suffix_variables_exp sfx data, data_ty) + | Preserve_const (name, ty, exp) -> + Preserve_const (name, ty, suffix_variables_exp sfx exp) + | Write_mem w -> Write_mem (suffix_variables_write_info sfx w) | Write_mem_ea (name, node, active , wk, addr, addr_ty, data_size, data_size_ty) -> - Write_mem (name ^ sfx, node, suffix_variables_exp sfx active, suffix_variables_exp sfx wk, - suffix_variables_exp sfx addr, addr_ty, suffix_variables_exp sfx data_size, data_size_ty) - | Read_mem (name, node, active, ty, rk, addr, addr_ty) -> - Read_mem (name ^ sfx, node, suffix_variables_exp sfx active, ty, suffix_variables_exp sfx rk, - suffix_variables_exp sfx addr, addr_ty) - | Barrier (name, node, active, bk) -> - Barrier (name ^ sfx, node, suffix_variables_exp sfx active, suffix_variables_exp sfx bk) + Write_mem_ea (name ^ sfx, node, suffix_variables_exp sfx active, suffix_variables_exp sfx wk, + suffix_variables_exp sfx addr, addr_ty, suffix_variables_exp sfx data_size, data_size_ty) + | Read_mem r -> Read_mem (suffix_variables_read_info sfx r) + | Barrier b -> Barrier (suffix_variables_barrier_info sfx b) + | Cache_maintenance m -> Cache_maintenance (suffix_variables_cache_op_info sfx m) + | Branch_announce c -> Branch_announce (suffix_variables_branch_info sfx c) | Excl_res (name, node, active) -> Excl_res (name ^ sfx, node, suffix_variables_exp sfx active) | Declare_datatypes (name, ctors) -> @@ -286,54 +452,37 @@ let suffix_variables_def sfx = function | Assert exp -> Assert (suffix_variables_exp sfx exp) -let merge_datatypes defs1 defs2 = - let module StringSet = Set.Make(String) in - let datatype_name = function - | Declare_datatypes (name, _) -> name - | _ -> assert false - in - let names = List.fold_left (fun set def -> StringSet.add (datatype_name def) set) StringSet.empty defs1 in - defs1 @ List.filter (fun def -> not (StringSet.mem (datatype_name def) names)) defs2 - -let merge_tuples defs1 defs2 = - let tuple_size = function - | Declare_tuple size -> size - | _ -> assert false - in - let names = List.fold_left (fun set def -> Util.IntSet.add (tuple_size def) set) Util.IntSet.empty defs1 in - defs1 @ List.filter (fun def -> not (Util.IntSet.mem (tuple_size def) names)) defs2 - -let merge_smt_defs defs1 defs2 = - let is_tuple = function - | Declare_datatypes _ | Declare_tuple _ -> true - | _ -> false - in - let is_datatype = function - | Declare_datatypes _ | Declare_tuple _ -> true - | _ -> false - in - let datatypes1, body1 = List.partition is_datatype defs1 in - let datatypes2, body2 = List.partition is_datatype defs2 in - let tuples1, datatypes1 = List.partition is_tuple datatypes1 in - let tuples2, datatypes2 = List.partition is_tuple datatypes2 in - merge_tuples tuples1 tuples2 @ merge_datatypes datatypes1 datatypes2 @ body1 @ body2 - let pp_sfun str docs = let open PPrint in parens (separate space (string str :: docs)) +let rec pp_smt_typ = + let open PPrint in + function + | Bool -> string "Bool" + | String -> string "String" + | Real -> string "Real" + | Bitvec n -> string (Printf.sprintf "(_ BitVec %d)" n) + | Datatype (name, _) -> string name + | Tuple tys -> pp_sfun ("Tup" ^ string_of_int (List.length tys)) (List.map pp_smt_typ tys) + | Array (ty1, ty2) -> pp_sfun "Array" [pp_smt_typ ty1; pp_smt_typ ty2] + +let pp_str_smt_typ (str, ty) = let open PPrint in parens (string str ^^ space ^^ pp_smt_typ ty) + let rec pp_smt_exp = let open PPrint in function | Bool_lit b -> string (string_of_bool b) | Real_lit str -> string str | String_lit str -> string ("\"" ^ str ^ "\"") - | Hex str -> string ("#x" ^ str) - | Bin str -> string ("#b" ^ str) + | Bitvec_lit bv -> string (Sail2_values.show_bitlist_prefix '#' bv) | Var str -> string str + | Shared str -> string str | Read_res str -> string (str ^ "_ret") | Enum str -> string str | Fn (str, exps) -> parens (string str ^^ space ^^ separate_map space pp_smt_exp exps) + | Field (str, exp) -> parens (string str ^^ space ^^ pp_smt_exp exp) + | Struct (str, fields) -> parens (string str ^^ space ^^ separate_map space (fun (_, exp) -> pp_smt_exp exp) fields) | Ctor (str, exps) -> parens (string str ^^ space ^^ separate_map space pp_smt_exp exps) | Ite (cond, then_exp, else_exp) -> parens (separate space [string "ite"; pp_smt_exp cond; pp_smt_exp then_exp; pp_smt_exp else_exp]) @@ -343,19 +492,9 @@ let rec pp_smt_exp = parens (string (Printf.sprintf "(_ is %s)" kind) ^^ space ^^ pp_smt_exp exp) | SignExtend (i, exp) -> parens (string (Printf.sprintf "(_ sign_extend %d)" i) ^^ space ^^ pp_smt_exp exp) - -let rec pp_smt_typ = - let open PPrint in - function - | Bool -> string "Bool" - | String -> string "String" - | Real -> string "Real" - | Bitvec n -> string (Printf.sprintf "(_ BitVec %d)" n) - | Datatype (name, _) -> string name - | Tuple tys -> pp_sfun ("Tup" ^ string_of_int (List.length tys)) (List.map pp_smt_typ tys) - | Array (ty1, ty2) -> pp_sfun "Array" [pp_smt_typ ty1; pp_smt_typ ty2] - -let pp_str_smt_typ (str, ty) = let open PPrint in string str ^^ space ^^ pp_smt_typ ty + | Syntactic (exp, _) -> pp_smt_exp exp + | Forall (binders, exp) -> + parens (string "forall" ^^ space ^^ parens (separate_map space pp_str_smt_typ binders) ^^ space ^^ pp_smt_exp exp) let pp_smt_def = let open PPrint in @@ -367,18 +506,23 @@ let pp_smt_def = ^^ space ^^ pp_smt_typ ty ^//^ pp_smt_exp exp) + | Declare_fun (name, args, ty) -> + parens (string "declare-fun" ^^ space ^^ string name + ^^ space ^^ parens (separate_map space pp_smt_typ args) + ^^ space ^^ pp_smt_typ ty) + | Declare_const (name, ty) -> pp_sfun "declare-const" [string name; pp_smt_typ ty] - | Define_const (name, ty, exp) -> + | Define_const (name, ty, exp) | Preserve_const (name, ty, exp) -> pp_sfun "define-const" [string name; pp_smt_typ ty; pp_smt_exp exp] - | Write_mem (name, _, active, wk, addr, addr_ty, data, data_ty) -> - pp_sfun "define-const" [string (name ^ "_kind"); string "Zwrite_kind"; pp_smt_exp wk] ^^ hardline - ^^ pp_sfun "define-const" [string (name ^ "_active"); pp_smt_typ Bool; pp_smt_exp active] ^^ hardline - ^^ pp_sfun "define-const" [string (name ^ "_data"); pp_smt_typ data_ty; pp_smt_exp data] ^^ hardline - ^^ pp_sfun "define-const" [string (name ^ "_addr"); pp_smt_typ addr_ty; pp_smt_exp addr] ^^ hardline - ^^ pp_sfun "declare-const" [string (name ^ "_ret"); pp_smt_typ Bool] + | Write_mem w -> + pp_sfun "define-const" [string (w.name ^ "_kind"); string "Zwrite_kind"; pp_smt_exp w.kind] ^^ hardline + ^^ pp_sfun "define-const" [string (w.name ^ "_active"); pp_smt_typ Bool; pp_smt_exp w.active] ^^ hardline + ^^ pp_sfun "define-const" [string (w.name ^ "_data"); pp_smt_typ w.data_type; pp_smt_exp w.data] ^^ hardline + ^^ pp_sfun "define-const" [string (w.name ^ "_addr"); pp_smt_typ w.addr_type; pp_smt_exp w.addr] ^^ hardline + ^^ pp_sfun "declare-const" [string (w.name ^ "_ret"); pp_smt_typ Bool] | Write_mem_ea (name, _, active, wk, addr, addr_ty, data_size, data_size_ty) -> pp_sfun "define-const" [string (name ^ "_kind"); string "Zwrite_kind"; pp_smt_exp wk] ^^ hardline @@ -386,15 +530,24 @@ let pp_smt_def = ^^ pp_sfun "define-const" [string (name ^ "_size"); pp_smt_typ data_size_ty; pp_smt_exp data_size] ^^ hardline ^^ pp_sfun "define-const" [string (name ^ "_addr"); pp_smt_typ addr_ty; pp_smt_exp addr] - | Read_mem (name, _, active, ty, rk, addr, addr_ty) -> - pp_sfun "define-const" [string (name ^ "_kind"); string "Zread_kind"; pp_smt_exp rk] ^^ hardline - ^^ pp_sfun "define-const" [string (name ^ "_active"); pp_smt_typ Bool; pp_smt_exp active] ^^ hardline - ^^ pp_sfun "define-const" [string (name ^ "_addr"); pp_smt_typ addr_ty; pp_smt_exp addr] ^^ hardline - ^^ pp_sfun "declare-const" [string (name ^ "_ret"); pp_smt_typ ty] + | Read_mem r -> + pp_sfun "define-const" [string (r.name ^ "_kind"); string "Zread_kind"; pp_smt_exp r.kind] ^^ hardline + ^^ pp_sfun "define-const" [string (r.name ^ "_active"); pp_smt_typ Bool; pp_smt_exp r.active] ^^ hardline + ^^ pp_sfun "define-const" [string (r.name ^ "_addr"); pp_smt_typ r.addr_type; pp_smt_exp r.addr] ^^ hardline + ^^ pp_sfun "declare-const" [string (r.name ^ "_ret"); pp_smt_typ r.ret_type] - | Barrier (name, _, active, bk) -> - pp_sfun "define-const" [string (name ^ "_kind"); string "Zbarrier_kind"; pp_smt_exp bk] ^^ hardline - ^^ pp_sfun "define-const" [string (name ^ "_active"); pp_smt_typ Bool; pp_smt_exp active] + | Barrier b -> + pp_sfun "define-const" [string (b.name ^ "_kind"); string "Zbarrier_kind"; pp_smt_exp b.kind] ^^ hardline + ^^ pp_sfun "define-const" [string (b.name ^ "_active"); pp_smt_typ Bool; pp_smt_exp b.active] + + | Cache_maintenance m -> + pp_sfun "define-const" [string (m.name ^ "_active"); pp_smt_typ Bool; pp_smt_exp m.active] ^^ hardline + ^^ pp_sfun "define-const" [string (m.name ^ "_kind"); string "Zcache_op_kind"; pp_smt_exp m.kind] ^^ hardline + ^^ pp_sfun "define-const" [string (m.name ^ "_addr"); pp_smt_typ m.addr_type; pp_smt_exp m.addr] + + | Branch_announce c -> + pp_sfun "define-const" [string (c.name ^ "_active"); pp_smt_typ Bool; pp_smt_exp c.active] ^^ hardline + ^^ pp_sfun "define-const" [string (c.name ^ "_addr"); pp_smt_typ c.addr_type; pp_smt_exp c.addr] | Excl_res (name, _, active) -> pp_sfun "declare-const" [string (name ^ "_res"); pp_smt_typ Bool] ^^ hardline @@ -404,7 +557,7 @@ let pp_smt_def = let pp_ctor (ctor_name, fields) = match fields with | [] -> parens (string ctor_name) - | _ -> pp_sfun ctor_name (List.map (fun field -> parens (pp_str_smt_typ field)) fields) + | _ -> pp_sfun ctor_name (List.map pp_str_smt_typ fields) in pp_sfun "declare-datatypes" [Printf.ksprintf string "((%s 0))" name; @@ -529,7 +682,7 @@ let check_counterexample ast env fname function_id args arg_ctyps arg_smt_names prerr_endline (sprintf "Solver found counterexample: %s" Util.("ok" |> green |> clear)); let counterexample = build_counterexample args arg_ctyps arg_smt_names model in List.iter (fun (id, v) -> prerr_endline (" " ^ string_of_id id ^ " -> " ^ string_of_value v)) counterexample; - let istate = initial_state ast env primops in + let istate = initial_state ast env !primops in let annot = (Parse_ast.Unknown, Type_check.mk_tannot env bool_typ no_effect) in let call = E_aux (E_app (function_id, List.map (fun (_, v) -> E_aux (E_internal_value v, (Parse_ast.Unknown, Type_check.empty_tannot))) counterexample), annot) in let result = run (Step (lazy "", istate, return call, [])) in diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index 40855eec..75f2ff6e 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -89,8 +89,8 @@ let rec free_type_names_t consider_var (Typ_aux (t, l)) = match t with | Typ_id name -> Nameset.add (string_of_id name) mt | Typ_fn (arg_typs,ret_typ,_) -> List.fold_left Nameset.union (free_type_names_t consider_var ret_typ) (List.map (free_type_names_t consider_var) arg_typs) - | Typ_bidir (t1, t2) -> Nameset.union (free_type_names_t consider_var t1) - (free_type_names_t consider_var t2) + | Typ_bidir (t1,t2,_) -> Nameset.union (free_type_names_t consider_var t1) + (free_type_names_t consider_var t2) | Typ_tup ts -> free_type_names_ts consider_var ts | Typ_app (name,targs) -> Nameset.add (string_of_id name) (free_type_names_t_args consider_var targs) | Typ_exist (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 @@ -121,7 +121,7 @@ let rec fv_of_typ consider_var bound used (Typ_aux (t,l)) : Nameset.t = | Typ_id id -> conditional_add_typ bound used id | Typ_fn(arg,ret,_) -> fv_of_typ consider_var bound (List.fold_left Nameset.union Nameset.empty (List.map (fv_of_typ consider_var bound used) arg)) ret - | Typ_bidir(t1, t2) -> fv_of_typ consider_var bound (fv_of_typ consider_var bound used t1) t2 (* TODO FIXME? *) + | Typ_bidir(t1,t2,_) -> fv_of_typ consider_var bound (fv_of_typ consider_var bound used t1) t2 (* TODO FIXME? *) | Typ_tup ts -> List.fold_right (fun t n -> fv_of_typ consider_var bound n t) ts used | Typ_app(id,targs) -> List.fold_right (fun ta n -> fv_of_targ consider_var bound n ta) targs (conditional_add_typ bound used id) diff --git a/src/specialize.ml b/src/specialize.ml index 483697ce..d705b83a 100644 --- a/src/specialize.ml +++ b/src/specialize.ml @@ -92,7 +92,7 @@ let rec nexp_simp_typ (Typ_aux (typ_aux, l)) = | Typ_exist (kids, nc, typ) -> Typ_exist (kids, nc, nexp_simp_typ typ) | 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_bidir (t1, t2, effect) -> Typ_bidir (nexp_simp_typ t1, nexp_simp_typ t2, effect) | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" in Typ_aux (typ_aux, l) @@ -170,8 +170,8 @@ let string_of_instantiation instantiation = | Typ_app (id, args) -> string_of_id id ^ "(" ^ Util.string_of_list "," string_of_typ_arg args ^ ")" | Typ_fn (arg_typs, ret_typ, eff) -> "(" ^ Util.string_of_list ", " string_of_typ arg_typs ^ ") -> " ^ string_of_typ ret_typ ^ " effect " ^ string_of_effect eff - | Typ_bidir (t1, t2) -> - string_of_typ t1 ^ " <-> " ^ string_of_typ t2 + | Typ_bidir (t1, t2, eff) -> + string_of_typ t1 ^ " <-> " ^ string_of_typ t2 ^ " effect " ^ string_of_effect eff | Typ_exist (kids, nc, typ) -> "exist " ^ Util.string_of_list " " kid_name kids ^ ", " ^ string_of_n_constraint nc ^ ". " ^ string_of_typ typ | Typ_internal_unknown -> "UNKNOWN" @@ -290,7 +290,7 @@ let rec typ_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) = | Typ_exist (kopts, nc, typ) -> typ_frees ~exs:(KidSet.of_list (List.map kopt_kid kopts)) typ | Typ_fn (arg_typs, ret_typ, _) -> List.fold_left KidSet.union (typ_frees ~exs:exs ret_typ) (List.map (typ_frees ~exs:exs) arg_typs) - | Typ_bidir (t1, t2) -> KidSet.union (typ_frees ~exs:exs t1) (typ_frees ~exs:exs t2) + | Typ_bidir (t1, t2, _) -> KidSet.union (typ_frees ~exs:exs t1) (typ_frees ~exs:exs t2) | 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 @@ -308,7 +308,7 @@ let rec typ_int_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) = | Typ_exist (kopts, nc, typ) -> typ_int_frees ~exs:(KidSet.of_list (List.map kopt_kid kopts)) typ | Typ_fn (arg_typs, ret_typ, _) -> List.fold_left KidSet.union (typ_int_frees ~exs:exs ret_typ) (List.map (typ_int_frees ~exs:exs) arg_typs) - | Typ_bidir (t1, t2) -> KidSet.union (typ_int_frees ~exs:exs t1) (typ_int_frees ~exs:exs t2) + | Typ_bidir (t1, t2, _) -> KidSet.union (typ_int_frees ~exs:exs t1) (typ_int_frees ~exs:exs t2) | 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 @@ -325,7 +325,7 @@ let rec remove_implicit (Typ_aux (aux, l) as t) = | Typ_internal_unknown -> Typ_aux (Typ_internal_unknown, l) | Typ_tup typs -> Typ_aux (Typ_tup (List.map remove_implicit typs), l) | Typ_fn (arg_typs, ret_typ, effs) -> Typ_aux (Typ_fn (List.map remove_implicit arg_typs, remove_implicit ret_typ, effs), l) - | Typ_bidir (typ1, typ2) -> Typ_aux (Typ_bidir (remove_implicit typ1, remove_implicit typ2), l) + | Typ_bidir (typ1, typ2, effs) -> Typ_aux (Typ_bidir (remove_implicit typ1, remove_implicit typ2, effs), l) | Typ_app (Id_aux (Id "implicit", _), args) -> Typ_aux (Typ_app (mk_id "atom", List.map remove_implicit_arg args), l) | Typ_app (id, args) -> Typ_aux (Typ_app (id, List.map remove_implicit_arg args), l) | Typ_id id -> Typ_aux (Typ_id id, l) @@ -602,11 +602,9 @@ let rec specialize_passes n spec env ast = let specialize = specialize_passes (-1) let () = - let open Printf in let open Interactive in - - (fun _ -> + Action (fun () -> let ast', env' = specialize typ_ord_specialization !env !ast in ast := ast'; - env := env') - |> register_command ~name:"specialize" ~help:":specialize - Specialize Type and Order type variables in the AST" + env := env' + ) |> register_command ~name:"specialize" ~help:"Specialize Type and Order type variables in the AST" diff --git a/src/state.ml b/src/state.ml index 9d79fef0..478a3fd5 100644 --- a/src/state.ml +++ b/src/state.ml @@ -58,6 +58,8 @@ open PPrint open Pretty_print_common open Pretty_print_sail +let opt_type_grouped_regstate = ref false + let defs_of_string = ast_of_def_string let is_defined defs name = IdSet.mem (mk_id name) (ids_of_defs (Defs defs)) @@ -78,11 +80,48 @@ let find_registers defs = | _ -> acc ) [] defs -let generate_regstate = function - | [] -> ["type regstate = unit"] +let generate_register_id_enum = function + | [] -> ["type register_id = unit"] | registers -> - let reg (typ, id) = Printf.sprintf "%s : %s" (string_of_id id) (to_string (doc_typ typ)) in - ["struct regstate = { " ^ (String.concat ", " (List.map reg registers)) ^ " }"] + let reg (typ, id) = string_of_id id in + ["type register_id = " ^ String.concat " | " (List.map reg registers)] + +let rec id_of_regtyp builtins mwords (Typ_aux (t, l) as typ) = match t with + | Typ_id id -> id + | Typ_app (id, args) -> + let name_arg (A_aux (targ, _)) = match targ with + | A_typ targ -> string_of_id (id_of_regtyp builtins mwords targ) + | A_nexp nexp when is_nexp_constant (nexp_simp nexp) -> + string_of_nexp (nexp_simp nexp) + | A_order (Ord_aux (Ord_inc, _)) -> "inc" + | A_order (Ord_aux (Ord_dec, _)) -> "dec" + | _ -> + raise (Reporting.err_typ l "Unsupported register type") + in + if IdSet.mem id builtins && not (mwords && is_bitvector_typ typ) then id else + append_id id (String.concat "_" ("" :: List.map name_arg args)) + | _ -> raise (Reporting.err_typ l "Unsupported register type") + +let regstate_field typ = append_id (id_of_regtyp IdSet.empty false typ) "_reg" + +let generate_regstate registers = + let regstate_def = + if registers = [] then + TD_abbrev (mk_id "regstate", mk_typquant [], mk_typ_arg (A_typ unit_typ)) + else + let fields = + if !opt_type_grouped_regstate then + List.map + (fun (typ, id) -> + (function_typ [string_typ] typ no_effect, + regstate_field typ)) + registers + |> List.sort_uniq (fun (typ1, id1) (typ2, id2) -> Id.compare id1 id2) + else registers + in + TD_record (mk_id "regstate", mk_typquant [], fields, false) + in + Defs [DEF_type (TD_aux (regstate_def, (Unknown, ())))] let generate_initial_regstate defs = let registers = find_registers defs in @@ -181,27 +220,15 @@ let generate_initial_regstate defs = | _ -> inits) ([], Bindings.empty) defs in let init_reg (typ, id) = string_of_id id ^ " = " ^ lookup_init_val init_vals typ in - init_defs @ - ["let initial_regstate : regstate = struct { " ^ (String.concat ", " (List.map init_reg registers)) ^ " }"] + List.map defs_of_string + (init_defs @ + ["let initial_regstate : regstate = struct { " ^ + (String.concat ", " (List.map init_reg registers)) ^ + " }"]) with | _ -> [] (* Do not generate an initial register state if anything goes wrong *) -let rec regval_constr_id mwords (Typ_aux (t, l) as typ) = match t with - | Typ_id id -> id - | Typ_app (id, args) -> - let name_arg (A_aux (targ, _)) = match targ with - | A_typ targ -> string_of_id (regval_constr_id mwords targ) - | A_nexp nexp when is_nexp_constant (nexp_simp nexp) -> - string_of_nexp (nexp_simp nexp) - | A_order (Ord_aux (Ord_inc, _)) -> "inc" - | A_order (Ord_aux (Ord_dec, _)) -> "dec" - | _ -> - raise (Reporting.err_typ l "Unsupported register type") - in - let builtins = IdSet.of_list (List.map mk_id ["vector"; "bitvector"; "list"; "option"]) in - if IdSet.mem id builtins && not (mwords && is_bitvector_typ typ) then id else - append_id id (String.concat "_" ("" :: List.map name_arg args)) - | _ -> raise (Reporting.err_typ l "Unsupported register type") +let regval_constr_id = id_of_regtyp (IdSet.of_list (List.map mk_id ["vector"; "bitvector"; "list"; "option"])) let register_base_types mwords typs = let rec add_base_typs typs (Typ_aux (t, _) as typ) = @@ -211,8 +238,8 @@ let register_base_types mwords typs = when IdSet.mem id builtins && not (mwords && is_bitvector_typ typ) -> let add_typ_arg base_typs (A_aux (targ, _)) = match targ with - | A_typ typ -> add_base_typs typs typ - | _ -> typs + | A_typ typ -> add_base_typs base_typs typ + | _ -> base_typs in List.fold_left add_typ_arg typs args | _ -> Bindings.add (regval_constr_id mwords typ) typ typs @@ -223,13 +250,14 @@ let generate_regval_typ typs = let constr (constr_id, typ) = Printf.sprintf "Regval_%s : %s" (string_of_id constr_id) (to_string (doc_typ typ)) in let builtins = - "Regval_vector : (int, bool, list(register_value)), " ^ + "Regval_vector : list(register_value), " ^ "Regval_list : list(register_value), " ^ "Regval_option : option(register_value)" in - ["union register_value = { " ^ - (String.concat ", " (builtins :: List.map constr (Bindings.bindings typs))) ^ - " }"] + [defs_of_string + ("union register_value = { " ^ + (String.concat ", " (builtins :: List.map constr (Bindings.bindings typs))) ^ + " }")] let add_regval_conv id typ (Defs defs) = let id = string_of_id id in @@ -253,11 +281,9 @@ let add_regval_conv id typ (Defs defs) = let rec regval_convs_lem mwords (Typ_aux (t, _) as typ) = match t with | Typ_app _ when (is_vector_typ typ || is_bitvector_typ typ) && not (mwords && is_bitvector_typ typ) -> let size, ord, etyp = vector_typ_args_of typ in - let size = string_of_nexp (nexp_simp size) in - let is_inc = if is_order_inc ord then "true" else "false" in let etyp_of, of_etyp = regval_convs_lem mwords etyp in "(fun v -> vector_of_regval " ^ etyp_of ^ " v)", - "(fun v -> regval_of_vector " ^ of_etyp ^ " " ^ size ^ " " ^ is_inc ^ " v)" + "(fun v -> regval_of_vector " ^ of_etyp ^ " v)" | Typ_app (id, [A_aux (A_typ etyp, _)]) when string_of_id id = "list" -> let etyp_of, of_etyp = regval_convs_lem mwords etyp in @@ -277,12 +303,12 @@ let register_refs_lem mwords registers = separate_map hardline string [ "val vector_of_regval : forall 'a. (register_value -> maybe 'a) -> register_value -> maybe (list 'a)"; "let vector_of_regval of_regval = function"; - " | Regval_vector (_, _, v) -> just_list (List.map of_regval v)"; + " | Regval_vector v -> just_list (List.map of_regval v)"; " | _ -> Nothing"; "end"; ""; - "val regval_of_vector : forall 'a. ('a -> register_value) -> integer -> bool -> list 'a -> register_value"; - "let regval_of_vector regval_of size is_inc xs = Regval_vector (size, is_inc, List.map regval_of xs)"; + "val regval_of_vector : forall 'a. ('a -> register_value) -> list 'a -> register_value"; + "let regval_of_vector regval_of xs = Regval_vector (List.map regval_of xs)"; ""; "val list_of_regval : forall 'a. (register_value -> maybe 'a) -> register_value -> maybe (list 'a)"; "let list_of_regval of_regval = function"; @@ -307,12 +333,20 @@ let register_refs_lem mwords registers = in let register_ref (typ, id) = let idd = string (string_of_id id) in + let (read_from, write_to) = + if !opt_type_grouped_regstate then + let field_idd = string (string_of_id (regstate_field typ)) in + (field_idd ^^ space ^^ dquotes idd, + doc_op equals field_idd (string "(fun reg -> if reg = \"" ^^ idd ^^ string "\" then v else s." ^^ field_idd ^^ string " reg)")) + else + (idd, doc_op equals idd (string "v")) + in (* let field = if prefix_recordtype then string "regstate_" ^^ idd else idd in *) let of_regval, regval_of = regval_convs_lem mwords typ in concat [string "let "; idd; string "_ref = <|"; hardline; string " name = \""; idd; string "\";"; hardline; - string " read_from = (fun s -> s."; idd; string ");"; hardline; - string " write_to = (fun v s -> (<| s with "; idd; string " = v |>));"; hardline; + string " read_from = (fun s -> s."; read_from; string ");"; hardline; + string " write_to = (fun v s -> (<| s with "; write_to; string " |>));"; hardline; string " of_regval = "; string of_regval; string ";"; hardline; string " regval_of = "; string regval_of; string " |>"; hardline] in @@ -393,7 +427,7 @@ let generate_isa_lemmas mwords (Defs defs : tannot defs) = separate_map hardline string [ "lemma vector_of_rv_rv_of_vector[simp]:"; " assumes \"\\<And>v. of_rv (rv_of v) = Some v\""; - " shows \"vector_of_regval of_rv (regval_of_vector rv_of len is_inc v) = Some v\""; + " shows \"vector_of_regval of_rv (regval_of_vector rv_of v) = Some v\""; "proof -"; " from assms have \"of_rv \\<circ> rv_of = Some\" by auto"; " then show ?thesis by (auto simp: vector_of_regval_def regval_of_vector_def)"; @@ -421,7 +455,7 @@ let rec regval_convs_coq (Typ_aux (t, _) as typ) = match t with let is_inc = if is_order_inc ord then "true" else "false" in let etyp_of, of_etyp = regval_convs_coq etyp in "(fun v => vector_of_regval " ^ size ^ " " ^ etyp_of ^ " v)", - "(fun v => regval_of_vector " ^ of_etyp ^ " " ^ size ^ " " ^ is_inc ^ " v)" + "(fun v => regval_of_vector " ^ of_etyp ^ " v)" | Typ_app (id, [A_aux (A_typ etyp, _)]) when string_of_id id = "list" -> let etyp_of, of_etyp = regval_convs_coq etyp in @@ -440,11 +474,11 @@ let register_refs_coq registers = let generic_convs = separate_map hardline string [ "Definition vector_of_regval {a} n (of_regval : register_value -> option a) (rv : register_value) : option (vec a n) := match rv with"; - " | Regval_vector (n', _, v) => if n =? n' then map_bind (vec_of_list n) (just_list (List.map of_regval v)) else None"; + " | Regval_vector v => if n =? length_list v then map_bind (vec_of_list n) (just_list (List.map of_regval v)) else None"; " | _ => None"; "end."; ""; - "Definition regval_of_vector {a} (regval_of : a -> register_value) (size : Z) (is_inc : bool) (xs : vec a size) : register_value := Regval_vector (size, is_inc, List.map regval_of (list_of_vec xs))."; + "Definition regval_of_vector {a size} (regval_of : a -> register_value) (xs : vec a size) : register_value := Regval_vector (List.map regval_of (list_of_vec xs))."; ""; "Definition list_of_regval {a} (of_regval : register_value -> option a) (rv : register_value) : option (list a) := match rv with"; " | Regval_list v => just_list (List.map of_regval v)"; @@ -504,14 +538,20 @@ let generate_regstate_defs mwords defs = let regtyps = register_base_types mwords (List.map fst registers) in let option_typ = if is_defined defs "option" then [] else - ["union option ('a : Type) = {None : unit, Some : 'a}"] + [defs_of_string "union option ('a : Type) = {None : unit, Some : 'a}"] in let regval_typ = if is_defined defs "register_value" then [] else generate_regval_typ regtyps in - let regstate_typ = if is_defined defs "regstate" then [] else generate_regstate registers in - let initregstate = if is_defined defs "initial_regstate" then [] else generate_initial_regstate defs in + let regstate_typ = if is_defined defs "regstate" then [] else [generate_regstate registers] in + let initregstate = + (* Don't create initial regstate if it is already defined or if we generated + a regstate record with registers grouped per type; the latter would + require record fields storing functions, which is not supported in + Sail. *) + if is_defined defs "initial_regstate" || !opt_type_grouped_regstate then [] else + generate_initial_regstate defs + in let defs = option_typ @ regval_typ @ regstate_typ @ initregstate - |> List.map defs_of_string |> concat_ast |> Bindings.fold add_regval_conv regtyps in diff --git a/src/type_check.ml b/src/type_check.ml index af4a7f65..73ad5362 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -79,6 +79,9 @@ let opt_smt_linearize = ref false (* Allow use of div and mod when rewriting nexps *) let opt_smt_div = ref false +(* Use new bitfield syntax, more compatible with ASL *) +let opt_new_bitfields = ref false + let depth = ref 0 let rec indent n = match n with @@ -112,6 +115,7 @@ type env = union_ids : (typquant * typ) Bindings.t; registers : (effect * effect * typ) Bindings.t; variants : (typquant * type_union list) Bindings.t; + scattered_variant_envs : env Bindings.t; mappings : (typquant * typ * typ) Bindings.t; typ_vars : (Ast.l * kind_aux) KBindings.t; shadow_vars : int KBindings.t; @@ -130,6 +134,7 @@ type env = poly_undefineds : bool; prove : (env -> n_constraint -> bool) option; allow_unknowns : bool; + bitfields : (Big_int.num * Big_int.num) Bindings.t Bindings.t; } exception Type_error of env * l * type_error;; @@ -233,7 +238,7 @@ and strip_typ_aux : typ_aux -> typ_aux = function | Typ_id id -> Typ_id (strip_id id) | Typ_var kid -> Typ_var (strip_kid kid) | Typ_fn (arg_typs, ret_typ, effect) -> Typ_fn (List.map strip_typ arg_typs, strip_typ ret_typ, strip_effect effect) - | Typ_bidir (typ1, typ2) -> Typ_bidir (strip_typ typ1, strip_typ typ2) + | Typ_bidir (typ1, typ2, effect) -> Typ_bidir (strip_typ typ1, strip_typ typ2, strip_effect effect) | Typ_tup typs -> Typ_tup (List.map strip_typ typs) | Typ_exist (kopts, constr, typ) -> Typ_exist ((List.map strip_kinded_id kopts), strip_n_constraint constr, strip_typ typ) @@ -267,7 +272,7 @@ let rec typ_constraints (Typ_aux (typ_aux, l)) = | Typ_exist (kids, nc, typ) -> typ_constraints typ | Typ_fn (arg_typs, ret_typ, _) -> List.concat (List.map typ_constraints arg_typs) @ typ_constraints ret_typ - | Typ_bidir (typ1, typ2) -> + | Typ_bidir (typ1, typ2, _) -> typ_constraints typ1 @ typ_constraints typ2 and typ_arg_nexps (A_aux (typ_arg_aux, l)) = match typ_arg_aux with @@ -286,7 +291,7 @@ let rec typ_nexps (Typ_aux (typ_aux, l)) = | Typ_exist (kids, nc, typ) -> typ_nexps typ | Typ_fn (arg_typs, ret_typ, _) -> List.concat (List.map typ_nexps arg_typs) @ typ_nexps ret_typ - | Typ_bidir (typ1, typ2) -> + | Typ_bidir (typ1, typ2, _) -> typ_nexps typ1 @ typ_nexps typ2 and typ_arg_nexps (A_aux (typ_arg_aux, l)) = match typ_arg_aux with @@ -421,7 +426,8 @@ module Env : sig val add_scattered_variant : id -> typquant -> t -> t val add_variant_clause : id -> type_union -> t -> t val get_variant : id -> t -> typquant * type_union list - val add_mapping : id -> typquant * typ * typ -> t -> t + val get_scattered_variant_env : id -> t -> t + val add_mapping : id -> typquant * typ * typ * effect -> t -> t val add_union_id : id -> typquant * typ -> t -> t val get_union_id : id -> t -> typquant * typ val is_register : id -> t -> bool @@ -434,6 +440,7 @@ module Env : sig val get_typ_var_loc : kid -> t -> Ast.l val get_typ_vars : t -> kind_aux KBindings.t val get_typ_var_locs : t -> Ast.l KBindings.t + val shadows : kid -> t -> int val add_typ_var_shadow : l -> kinded_id -> t -> t * kid option val add_typ_var : l -> kinded_id -> t -> t val get_ret_typ : t -> typ option @@ -467,6 +474,8 @@ module Env : sig val base_typ_of : t -> typ -> typ val allow_unknowns : t -> bool val set_allow_unknowns : bool -> t -> t + val add_bitfield : id -> (Big_int.num * Big_int.num) Bindings.t -> t -> t + val get_bitfield_range : l -> id -> id -> t -> (Big_int.num * Big_int.num) val no_bindings : t -> t @@ -499,6 +508,7 @@ end = struct union_ids = Bindings.empty; registers = Bindings.empty; variants = Bindings.empty; + scattered_variant_envs = Bindings.empty; mappings = Bindings.empty; typ_vars = KBindings.empty; shadow_vars = KBindings.empty; @@ -517,6 +527,7 @@ end = struct poly_undefineds = false; prove = None; allow_unknowns = false; + bitfields = Bindings.empty; } let set_prover f env = { env with prove = f } @@ -563,8 +574,8 @@ end = struct let builtin_mappings = List.fold_left (fun m (name, typ) -> Bindings.add (mk_id name) typ m) Bindings.empty [ - ("int", Typ_bidir(int_typ, string_typ)); - ("nat", Typ_bidir(nat_typ, string_typ)); + ("int", Typ_bidir(int_typ, string_typ, no_effect)); + ("nat", Typ_bidir(nat_typ, string_typ, no_effect)); ] let bound_typ_id env id = @@ -715,7 +726,7 @@ end = struct | Typ_internal_unknown -> Typ_aux (Typ_internal_unknown, l) | Typ_tup typs -> Typ_aux (Typ_tup (List.map (expand_synonyms env) typs), l) | Typ_fn (arg_typs, ret_typ, effs) -> Typ_aux (Typ_fn (List.map (expand_synonyms env) arg_typs, expand_synonyms env ret_typ, effs), l) - | Typ_bidir (typ1, typ2) -> Typ_aux (Typ_bidir (expand_synonyms env typ1, expand_synonyms env typ2), l) + | Typ_bidir (typ1, typ2, effs) -> Typ_aux (Typ_bidir (expand_synonyms env typ1, expand_synonyms env typ2, effs), l) | Typ_app (id, args) -> (try begin match get_typ_synonym id env l env args with @@ -776,7 +787,7 @@ end = struct | Typ_internal_unknown | Typ_id _ | Typ_var _ -> typ | Typ_fn (arg_typs, ret_typ, effect) -> Typ_aux (Typ_fn (List.map (map_nexps f) arg_typs, map_nexps f ret_typ, effect), l) - | Typ_bidir (typ1, typ2) -> Typ_aux (Typ_bidir (map_nexps f typ1, map_nexps f typ2), l) + | Typ_bidir (typ1, typ2, effect) -> Typ_aux (Typ_bidir (map_nexps f typ1, map_nexps f typ2, effect), l) | Typ_tup typs -> Typ_aux (Typ_tup (List.map (map_nexps f) typs), l) | Typ_exist (kids, nc, typ) -> Typ_aux (Typ_exist (kids, nc, map_nexps f typ), l) | Typ_app (id, args) -> Typ_aux (Typ_app (id, List.map (map_nexps_arg f) args), l) @@ -803,15 +814,15 @@ end = struct | Typ_var kid -> begin match KBindings.find kid env.typ_vars with | (_, K_type) -> () - | (_, k) -> typ_error env l ("Kind identifier " ^ string_of_kid kid ^ " in type " ^ string_of_typ typ + | (_, k) -> typ_error env l ("Type variable " ^ string_of_kid kid ^ " in type " ^ string_of_typ typ ^ " is " ^ string_of_kind_aux k ^ " rather than Type") | exception Not_found -> - typ_error env l ("Unbound kind identifier " ^ string_of_kid kid ^ " in type " ^ string_of_typ typ) + typ_error env l ("Unbound type variable " ^ 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_bidir (typ1, typ2, _) when strip_typ typ1 = strip_typ typ2 -> 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_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, [A_aux (A_nexp _, _) as arg]) when string_of_id id = "implicit" -> wf_typ_arg ~exs:exs env arg @@ -969,8 +980,8 @@ end = struct typ_print (lazy (adding ^ "val " ^ string_of_id id ^ " : " ^ string_of_bind (typq, typ))); { env with top_val_specs = Bindings.add id (typq, typ) env.top_val_specs } - | Typ_aux (Typ_bidir (typ1, typ2), l) -> - let env = add_mapping id (typq, typ1, typ2) env in + | Typ_aux (Typ_bidir (typ1, typ2, effect), l) -> + let env = add_mapping id (typq, typ1, typ2, effect) env in typ_print (lazy (adding ^ "mapping " ^ string_of_id id ^ " : " ^ string_of_bind (typq, typ))); { env with top_val_specs = Bindings.add id (typq, typ) env.top_val_specs } @@ -992,16 +1003,16 @@ end = struct env *) - and add_mapping id (typq, typ1, typ2) env = + and add_mapping id (typq, typ1, typ2, effect) env = typ_print (lazy (adding ^ "mapping " ^ string_of_id id)); let forwards_id = mk_id (string_of_id id ^ "_forwards") in let forwards_matches_id = mk_id (string_of_id id ^ "_forwards_matches") in let backwards_id = mk_id (string_of_id id ^ "_backwards") in let backwards_matches_id = mk_id (string_of_id id ^ "_backwards_matches") in - let forwards_typ = Typ_aux (Typ_fn ([typ1], typ2, no_effect), Parse_ast.Unknown) in - let forwards_matches_typ = Typ_aux (Typ_fn ([typ1], bool_typ, no_effect), Parse_ast.Unknown) in - let backwards_typ = Typ_aux (Typ_fn ([typ2], typ1, no_effect), Parse_ast.Unknown) in - let backwards_matches_typ = Typ_aux (Typ_fn ([typ2], bool_typ, no_effect), Parse_ast.Unknown) in + let forwards_typ = Typ_aux (Typ_fn ([typ1], typ2, effect), Parse_ast.Unknown) in + let forwards_matches_typ = Typ_aux (Typ_fn ([typ1], bool_typ, effect), Parse_ast.Unknown) in + let backwards_typ = Typ_aux (Typ_fn ([typ2], typ1, effect), Parse_ast.Unknown) in + let backwards_matches_typ = Typ_aux (Typ_fn ([typ2], bool_typ, effect), Parse_ast.Unknown) in let env = { env with mappings = Bindings.add id (typq, typ1, typ2) env.mappings } |> add_val_spec forwards_id (typq, forwards_typ) @@ -1059,7 +1070,7 @@ end = struct | Not_found -> typ_error env (id_loc id) ("Enumeration " ^ string_of_id id ^ " does not exist") let is_enum id env = Bindings.mem id env.enums - + let is_record id env = Bindings.mem id env.records let get_record id env = Bindings.find id env.records @@ -1140,7 +1151,10 @@ end = struct let add_scattered_variant id typq env = typ_print (lazy (adding ^ "scattered variant " ^ string_of_id id)); - { env with variants = Bindings.add id (typq, []) env.variants } + { env with + variants = Bindings.add id (typq, []) env.variants; + scattered_variant_envs = Bindings.add id env env.scattered_variant_envs + } let add_variant_clause id tu env = match Bindings.find_opt id env.variants with @@ -1152,6 +1166,11 @@ end = struct | Some (typq, tus) -> typq, tus | None -> typ_error env (id_loc id) ("union " ^ string_of_id id ^ " not found") + let get_scattered_variant_env id env = + match Bindings.find_opt id env.scattered_variant_envs with + | Some env' -> env' + | None -> typ_error env (id_loc id) ("scattered union " ^ string_of_id id ^ " has not been declared") + let is_register id env = Bindings.mem id env.registers @@ -1206,6 +1225,8 @@ end = struct with | Not_found -> Unbound + let shadows v env = match KBindings.find_opt v env.shadow_vars with Some n -> n | None -> 0 + let add_typ_var_shadow 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 @@ -1308,6 +1329,18 @@ end = struct | targ -> rewrap targ in aux (expand_synonyms env typ) + let get_bitfield_range l id field env = + match Bindings.find_opt id env.bitfields with + | Some ranges -> + begin match Bindings.find_opt field ranges with + | Some range -> range + | None -> typ_error env l (Printf.sprintf "Field %s does not exist in the bitfield %s" (string_of_id field) (string_of_id id)) + end + | None -> typ_error env l (Printf.sprintf "%s is not a bitfield" (string_of_id id)) + + let add_bitfield id ranges env = + { env with bitfields = Bindings.add id ranges env.bitfields } + let allow_polymorphic_undefineds env = { env with poly_undefineds = true } @@ -1335,10 +1368,12 @@ let add_typquant l (quant : typquant) (env : Env.t) : Env.t = let expand_bind_synonyms l env (typq, typ) = typq, Env.expand_synonyms (add_typquant l typq env) typ -let wf_typschm env (TypSchm_aux (TypSchm_ts (typq, typ), l)) = +let wf_binding l env (typq, typ) = let env = add_typquant l typq env in Env.wf_typ env typ +let wf_typschm env (TypSchm_aux (TypSchm_ts (typq, typ), l)) = wf_binding l env (typq, typ) + (* Create vectors with the default order from the environment *) let default_order_error_string = @@ -1367,6 +1402,16 @@ let bind_numeric l typ env = nexp, add_existential l (List.map (mk_kopt K_int) kids) nc env | None -> typ_error env l ("Expected " ^ string_of_typ typ ^ " to be numeric") +let rec check_shadow_leaks l inner_env outer_env typ = + let vars = tyvars_of_typ typ in + List.iter (fun var -> + if Env.shadows var inner_env > Env.shadows var outer_env then + typ_error outer_env l + ("Type variable " ^ string_of_kid var ^ " would leak into a scope where it is shadowed") + else ()) + (KidSet.elements vars); + typ + (** Pull an (potentially)-existentially qualified type into the global typing environment **) let bind_existential l name typ env = @@ -1419,7 +1464,7 @@ let rec is_typ_monomorphic (Typ_aux (typ, l)) = | Typ_tup typs -> List.for_all is_typ_monomorphic typs | Typ_app (id, args) -> List.for_all is_typ_arg_monomorphic args | 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_bidir (typ1, typ2, _) -> is_typ_monomorphic typ1 && is_typ_monomorphic typ2 | Typ_exist _ | Typ_var _ -> false | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" and is_typ_arg_monomorphic (A_aux (arg, _)) = @@ -1618,9 +1663,10 @@ and typ_identical (Typ_aux (typ1, _)) (Typ_aux (typ2, _)) = List.for_all2 typ_identical arg_typs1 arg_typs2 && typ_identical ret_typ1 ret_typ2 && strip_effect eff1 = strip_effect eff2 - | Typ_bidir (typ1, typ2), Typ_bidir (typ3, typ4) -> + | Typ_bidir (typ1, typ2, eff1), Typ_bidir (typ3, typ4, eff2) -> typ_identical typ1 typ3 && typ_identical typ2 typ4 + && strip_effect eff1 = strip_effect eff2 | Typ_tup typs1, Typ_tup typs2 -> begin try List.for_all2 typ_identical typs1 typs2 with @@ -2018,7 +2064,7 @@ let rec alpha_equivalent env typ1 typ2 = | Typ_internal_unknown -> Typ_internal_unknown | Typ_id _ | Typ_var _ -> aux | Typ_fn (arg_typs, ret_typ, eff) -> Typ_fn (List.map relabel arg_typs, relabel ret_typ, eff) - | Typ_bidir (typ1, typ2) -> Typ_bidir (relabel typ1, relabel typ2) + | Typ_bidir (typ1, typ2, eff) -> Typ_bidir (relabel typ1, relabel typ2, eff) | Typ_tup typs -> Typ_tup (List.map relabel typs) | Typ_exist (kopts, nc, typ) -> let kind_map = List.fold_left (fun m kopt -> KBindings.add (kopt_kid kopt) (kopt_kind kopt) m) KBindings.empty kopts in @@ -2812,12 +2858,14 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ | LB_val (P_aux (P_typ (ptyp, _), _) as pat, bind) -> Env.wf_typ env ptyp; let checked_bind = crule check_exp env bind ptyp in - let tpat, env = bind_pat_no_guard env pat ptyp in - annot_exp (E_let (LB_aux (LB_val (tpat, checked_bind), (let_loc, None)), crule check_exp env exp typ)) typ + let tpat, inner_env = bind_pat_no_guard env pat ptyp in + annot_exp (E_let (LB_aux (LB_val (tpat, checked_bind), (let_loc, None)), crule check_exp inner_env exp typ)) + (check_shadow_leaks l inner_env env typ) | LB_val (pat, bind) -> let inferred_bind = irule infer_exp env bind in - let tpat, env = bind_pat_no_guard env pat (typ_of inferred_bind) in - annot_exp (E_let (LB_aux (LB_val (tpat, inferred_bind), (let_loc, None)), crule check_exp env exp typ)) typ + let tpat, inner_env = bind_pat_no_guard env pat (typ_of inferred_bind) in + annot_exp (E_let (LB_aux (LB_val (tpat, inferred_bind), (let_loc, None)), crule check_exp inner_env exp typ)) + (check_shadow_leaks l inner_env env typ) end | E_app_infix (x, op, y), _ -> check_exp env (E_aux (E_app (deinfix op, [x; y]), (l, ()))) typ @@ -3278,7 +3326,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) | _ -> [typ] in match Env.expand_synonyms env mapping_typ with - | Typ_aux (Typ_bidir (typ1, typ2), _) -> + | Typ_aux (Typ_bidir (typ1, typ2, _), _) -> begin try typ_debug (lazy ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for pattern " ^ string_of_typ typ)); @@ -3372,7 +3420,7 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as pat) = begin let (typq, mapping_typ) = Env.get_val_spec f env in match Env.expand_synonyms env mapping_typ with - | Typ_aux (Typ_bidir (typ1, typ2), _) -> + | Typ_aux (Typ_bidir (typ1, typ2, _), _) -> begin try bind_pat env pat typ2 @@ -3484,46 +3532,6 @@ and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as | _ -> false in match lexp_aux with - | LEXP_field (LEXP_aux (flexp, _), field) -> - begin - let infer_flexp = function - | LEXP_id v -> - 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 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 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 - in - let access = infer_exp (Env.enable_casts env) (E_aux (E_app (mk_id "vector_access", [E_aux (E_id v, (l, ())); exp]), (l, ()))) in - let inferred_exp = match access with - | E_aux (E_app (_, [_; inferred_exp]), _) -> inferred_exp - | _ -> assert false - in - typ_of access, LEXP_vector (annot_lexp (LEXP_id v) vtyp, inferred_exp), is_register - end - | _ -> 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))); - match Env.expand_synonyms env regtyp with - | 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 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 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 | LEXP_cast (typ_annot, v) -> @@ -3661,7 +3669,16 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) = annot_lexp (LEXP_vector (inferred_v_lexp, inferred_exp)) bit_typ else 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" + | Typ_id id when !opt_new_bitfields -> + begin match exp with + | E_aux (E_id field, _) -> + let (hi, lo) = Env.get_bitfield_range l id field env in + let hi, lo = mk_exp ~loc:l (E_lit (L_aux (L_num hi, l))), mk_exp ~loc:l (E_lit (L_aux (L_num lo, l))) in + infer_lexp env (LEXP_aux (LEXP_vector_range (LEXP_aux (LEXP_field (v_lexp, Id_aux (Id "bits", l)), (l, ())), hi, lo), (l, ()))) + | _ -> + typ_error env l (string_of_exp exp ^ " is not a bitfield accessor") + end + | _ -> typ_error env l "Cannot assign vector element of non vector or bitfield type" end | LEXP_vector_concat [] -> typ_error env l "Cannot have empty vector concatenation l-expression" | LEXP_vector_concat (v_lexp :: v_lexps) -> @@ -3696,15 +3713,17 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) = annot_lexp (LEXP_vector_concat (inferred_v_lexp :: inferred_v_lexps)) (bitvector_typ (nexp_simp len) ord) | _ -> typ_error env l ("Vector concatentation l-expression must only contain bitvector or 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 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_field ((LEXP_aux (_, (l, ())) as lexp), field_id) -> + let inferred_lexp = infer_lexp env lexp in + let rectyp = lexp_typ_of inferred_lexp in + begin match lexp_typ_of inferred_lexp with + | Typ_aux (Typ_id rectyp_id, _) | Typ_aux (Typ_app (rectyp_id, _), _) when Env.is_record rectyp_id env -> + let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field_id env in + let unifiers = try unify l env (tyvars_of_typ rectyp_q) rectyp_q rectyp with Unification_error (l, m) -> typ_error env l ("Unification error: " ^ m) in + let field_typ' = subst_unifiers unifiers field_typ in + annot_lexp (LEXP_field (inferred_lexp, field_id)) field_typ' + | _ -> typ_error env l "Field l-expression has invalid type" + end | LEXP_deref exp -> let inferred_exp = infer_exp env exp in begin match typ_of inferred_exp with @@ -3880,7 +3899,25 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = 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_access (v, n) -> + begin + try infer_exp env (E_aux (E_app (mk_id "vector_access", [v; n]), (l, ()))) with + | Type_error (err_env, err_l, err) when !opt_new_bitfields -> + (try ( + let inferred_v = infer_exp env v in + begin match typ_of inferred_v, n with + | Typ_aux (Typ_id id, _), E_aux (E_id field, (f_l, _)) -> + let (hi, lo) = Env.get_bitfield_range f_l id field env in + let hi, lo = mk_exp ~loc:l (E_lit (L_aux (L_num hi, l))), mk_exp ~loc:l (E_lit (L_aux (L_num lo, l))) in + infer_exp env (E_aux (E_vector_subrange (E_aux (E_field (v, Id_aux (Id "bits", f_l)), (l, ())), hi, lo), (l, ()))) + | _, _ -> + typ_error env l "Vector access could not be interpreted as a bitfield access" + end + ) with + | Type_error (_, err_l', err') -> + typ_raise err_env err_l (Err_because (err, err_l', err'))) + | exn -> raise exn + end | E_vector_update (v, n, exp) -> infer_exp env (E_aux (E_app (mk_id "vector_update", [v; n; exp]), (l, ()))) | E_vector_update_subrange (v, n, m, exp) -> infer_exp env (E_aux (E_app (mk_id "vector_update_subrange", [v; n; m; exp]), (l, ()))) | E_vector_append (v1, E_aux (E_vector [], _)) -> infer_exp env v1 @@ -3938,9 +3975,10 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = | LB_val (pat, bind) -> let inferred_bind = irule infer_exp env bind in inferred_bind, pat, typ_of inferred_bind in - let tpat, env = bind_pat_no_guard env pat ptyp in - let inferred_exp = irule infer_exp env exp in - annot_exp (E_let (LB_aux (LB_val (tpat, bind_exp), (let_loc, None)), inferred_exp)) (typ_of inferred_exp) + let tpat, inner_env = bind_pat_no_guard env pat ptyp in + let inferred_exp = irule infer_exp inner_env exp in + annot_exp (E_let (LB_aux (LB_val (tpat, bind_exp), (let_loc, None)), inferred_exp)) + (check_shadow_leaks l inner_env env (typ_of inferred_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) @@ -4221,7 +4259,7 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) ( | _ -> [typ] in match Env.expand_synonyms env mapping_typ with - | Typ_aux (Typ_bidir (typ1, typ2), _) -> + | Typ_aux (Typ_bidir (typ1, typ2, _), _) -> begin try typ_debug (lazy ("Unifying " ^ string_of_bind (typq, mapping_typ) ^ " for mapping-pattern " ^ string_of_typ typ)); @@ -4320,7 +4358,7 @@ and infer_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) begin let (typq, mapping_typ) = Env.get_val_spec f env in match Env.expand_synonyms env mapping_typ with - | Typ_aux (Typ_bidir (typ1, typ2), _) -> + | Typ_aux (Typ_bidir (typ1, typ2, _), _) -> begin try bind_mpat allow_unknown other_env env mpat typ2 @@ -4814,7 +4852,7 @@ let check_funcl env (FCL_aux (FCL_Funcl (id, pexp), (l, _))) typ = let check_mapcl : 'a. Env.t -> 'a mapcl -> typ -> tannot mapcl = fun env (MCL_aux (cl, (l, _))) typ -> match typ with - | Typ_aux (Typ_bidir (typ1, typ2), _) -> begin + | Typ_aux (Typ_bidir (typ1, typ2, _), _) -> begin match cl with | MCL_bidir (mpexp1, mpexp2) -> begin let testing_env = Env.set_allow_unknowns true env in @@ -4979,7 +5017,7 @@ let check_mapdef env (MD_aux (MD_mapping (id, tannot_opt, mapcls), (l, _)) as md raise err in let vtyp1, vtyp2, vl = match typ with - | Typ_aux (Typ_bidir (vtyp1, vtyp2), vl) -> vtyp1, vtyp2, vl + | Typ_aux (Typ_bidir (vtyp1, vtyp2, _), vl) -> vtyp1, vtyp2, vl | _ -> typ_error env l "Mapping val spec was not a mapping type" in begin match tannot_opt with @@ -5072,55 +5110,108 @@ let fold_union_quant quants (QI_aux (qi, l)) = | QI_id kind_id -> quants @ [kinded_id_arg kind_id] | _ -> quants -let check_type_union env variant typq (Tu_aux (tu, l)) = +(* We wrap this around wf_binding checks that aim to forbid recursive + types to explain any error messages raised if the well-formedness + check fails. *) +let forbid_recursive_types type_l f = + try f () with + | Type_error (env, l, err) -> + let msg = "Types are not well-formed within this type definition. Note that recursive types are forbidden." in + raise (Type_error (env, l, Err_because (err, type_l, Err_other msg))) + +let check_type_union u_l non_rec_env 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 (tyvars_of_typ typ))) in + wf_binding l env (typq, typ); + forbid_recursive_types u_l (fun () -> wf_binding l non_rec_env (typq, tuple_typ arg_typ)); env |> Env.add_union_id v (typq, typ) |> Env.add_val_spec v (typq, typ) | Tu_ty_id (arg_typ, v) -> let typ' = mk_typ (Typ_fn ([arg_typ], ret_typ, no_effect)) in + forbid_recursive_types u_l (fun () -> wf_binding l non_rec_env (typq, arg_typ)); + wf_binding l env (typq, typ'); env |> Env.add_union_id v (typq, typ') |> Env.add_val_spec v (typq, typ') -(* FIXME: This code is duplicated with general kind-checking code in environment, can they be merged? *) - 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) -> + begin match typ_arg with + | A_aux (A_typ typ, a_l) -> + forbid_recursive_types l (fun () -> wf_binding a_l env (typq, typ)); + | _ -> () + end; [DEF_type (TD_aux (tdef, (l, None)))], Env.add_typ_synonym id typq typ_arg env | TD_record (id, typq, fields, _) -> + forbid_recursive_types l (fun () -> List.iter (fun (Typ_aux (_, l) as field, _) -> wf_binding l env (typq, field)) fields); [DEF_type (TD_aux (tdef, (l, None)))], Env.add_record id typq fields env | TD_variant (id, typq, arms, _) -> + let rec_env = Env.add_variant id (typq, arms) env in + (* register_value is a special type used by theorem prover + backends that we allow to be recursive. *) + let non_rec_env = if string_of_id id = "register_value" then rec_env else env in 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) + rec_env + |> (fun env -> List.fold_left (fun env tu -> check_type_union l non_rec_env env id typq tu) env arms) in [DEF_type (TD_aux (tdef, (l, None)))], env | TD_enum (id, ids, _) -> [DEF_type (TD_aux (tdef, (l, None)))], Env.add_enum id ids env + | TD_bitfield (id, typ, ranges) when !opt_new_bitfields -> + let typ = Env.expand_synonyms env typ in + begin match typ with + (* The type of a bitfield must be a constant-width bitvector *) + | Typ_aux (Typ_app (v, [A_aux (A_nexp (Nexp_aux (Nexp_constant size, _)), _); + A_aux (A_order order, _)]), _) + when string_of_id v = "bitvector" -> + let size = Big_int.to_int size in + let eval_index_nexp l nexp = + match int_of_nexp_opt (nexp_simp (Env.expand_nexp_synonyms env nexp)) with + | Some i -> i + | None -> typ_error env l ("This numeric expression must evaluate to a constant: " ^ string_of_nexp nexp) + in + let record_tdef = TD_record (id, mk_typquant [], [(typ, mk_id "bits")], false) in + let ranges = + List.fold_left (fun ranges (field, range) -> + match range with + | BF_aux (BF_single nexp, l) -> + let n = eval_index_nexp l nexp in + Bindings.add field (n, n) ranges + | BF_aux (BF_range (hi, lo), l) -> + let hi, lo = eval_index_nexp l hi, eval_index_nexp l lo in + Bindings.add field (hi, lo) ranges + | BF_aux (BF_concat _, _) -> + typ_error env l "Bitfield concatenation ranges are not supported" + ) Bindings.empty ranges + in + [DEF_type (TD_aux (record_tdef, (l, None)))], + env + |> Env.add_record id (mk_typquant []) [(typ, mk_id "bits")] + |> Env.add_bitfield id ranges + | _ -> + typ_error env l "Underlying bitfield type must be a constant-width bitvector" + end | TD_bitfield (id, typ, ranges) -> let typ = Env.expand_synonyms env typ in - begin - match typ with - (* The type of a bitfield must be a constant-width bitvector *) - | Typ_aux (Typ_app (v, [A_aux (A_nexp (Nexp_aux (Nexp_constant size, _)), _); - A_aux (A_order order, _)]), _) - when string_of_id v = "bitvector" -> - let size = Big_int.to_int size in - let eval_index_nexp env nexp = - int_of_nexp_opt (nexp_simp (Env.expand_nexp_synonyms env nexp)) in - let (Defs defs), env = - check env (Bitfield.macro (eval_index_nexp env, (typ_error env)) id size order ranges) in - defs, env - | _ -> - typ_error env l "Bad bitfield type" + begin match typ with + (* The type of a bitfield must be a constant-width bitvector *) + | Typ_aux (Typ_app (v, [A_aux (A_nexp (Nexp_aux (Nexp_constant size, _)), _); + A_aux (A_order order, _)]), _) + when string_of_id v = "bitvector" -> + let size = Big_int.to_int size in + let eval_index_nexp env nexp = + int_of_nexp_opt (nexp_simp (Env.expand_nexp_synonyms env nexp)) in + let (Defs defs), env = + check env (Bitfield.macro (eval_index_nexp env, (typ_error env)) id size order ranges) in + defs, env + | _ -> + typ_error env l "Underlying bitfield type must be a constant-width bitvector" end and check_scattered : 'a. Env.t -> 'a scattered_def -> (tannot def) list * Env.t = @@ -5133,7 +5224,13 @@ and check_scattered : 'a. Env.t -> 'a scattered_def -> (tannot def) list * Env.t [DEF_scattered (SD_aux (SD_unioncl (id, tu), (l, None)))], let env = Env.add_variant_clause id tu env in let typq, _ = Env.get_variant id env in - check_type_union env id typq tu + let definition_env = Env.get_scattered_variant_env id env in + (try check_type_union l definition_env env id typq tu with + | Type_error (env, l', err) -> + let msg = "As this is a scattered union clause, this could \ + also be caused by using a type defined after the \ + 'scattered union' declaration" in + raise (Type_error (env, l', Err_because (err, id_loc id, Err_other msg)))) | SD_funcl (FCL_aux (FCL_Funcl (id, _), (l, _)) as funcl) -> let typq, typ = Env.get_val_spec id env in let funcl_env = add_typquant l typq env in diff --git a/src/type_check.mli b/src/type_check.mli index 711f2411..76b38557 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -80,6 +80,9 @@ val opt_smt_linearize : bool ref (** Allow use of div and mod when rewriting nexps *) val opt_smt_div : bool ref +(** Use new bitfield syntax, more compatible with ASL *) +val opt_new_bitfields : bool ref + (** {2 Type errors} *) type type_error = diff --git a/src/type_error.ml b/src/type_error.ml index eed1379a..6205302e 100644 --- a/src/type_error.ml +++ b/src/type_error.ml @@ -107,7 +107,7 @@ let message_of_type_error = let rec msg = function | Err_because (err, l', err') -> Seq [msg err; - Line "This error occured because of a previous error:"; + Line "This error was caused by:"; Location (l', msg err')] | Err_other str -> Line str diff --git a/src/util.ml b/src/util.ml index 2745631c..99f1111f 100644 --- a/src/util.ml +++ b/src/util.ml @@ -143,6 +143,22 @@ let remove_dups compare eq l = in aux [] l' +let lex_ord_list comparison xs ys = + let rec lex_lists xs ys = + match xs, ys with + | x :: xs, y :: ys -> + let c = comparison x y in + if c = 0 then lex_lists xs ys else c + | [], [] -> 0 + | _, _ -> assert false + in + if List.length xs = List.length ys then + lex_lists xs ys + else if List.length xs < List.length ys then + -1 + else + 1 + let rec power i tothe = if tothe <= 0 then 1 @@ -228,7 +244,7 @@ let option_bind f = function | None -> None | Some(o) -> f o -let rec option_binop f x y = match x, y with +let option_binop f x y = match x, y with | Some x, Some y -> Some (f x y) | _ -> None @@ -418,6 +434,7 @@ let termcode n = else "" let bold str = termcode 1 ^ str +let dim str = termcode 2 ^ str let darkgray str = termcode 90 ^ str let red str = termcode 91 ^ str diff --git a/src/util.mli b/src/util.mli index 9c57e360..3d83a1a4 100644 --- a/src/util.mli +++ b/src/util.mli @@ -73,6 +73,9 @@ val remove_duplicates : 'a list -> 'a list (** [remove_dups compare eq l] as remove_duplicates but with parameterised comparison and equality *) val remove_dups : ('a -> 'a -> int) -> ('a -> 'a -> bool) -> 'a list -> 'a list +(** Lift a comparison order to the lexical order on lists *) +val lex_ord_list : ('a -> 'a -> int) -> 'a list -> 'a list -> int + (** [assoc_equal_opt] and [assoc_compare_opt] are like List.assoc_opt but take equality/comparison functions as arguments, rather than relying on OCaml's built in equality *) @@ -237,6 +240,7 @@ val split_on_char : char -> string -> string list val termcode : int -> string val bold : string -> string +val dim : string -> string val darkgray : string -> string val green : string -> string val red : string -> string diff --git a/src/value.ml b/src/value.ml index 71d9ffe6..3a9a071f 100644 --- a/src/value.ml +++ b/src/value.ml @@ -369,6 +369,14 @@ let value_mult = function | [v1; v2] -> V_int (Sail_lib.mult (coerce_int v1, coerce_int v2)) | _ -> failwith "value mult" +let value_tdiv_int = function + | [v1; v2] -> V_int (Sail_lib.tdiv_int (coerce_int v1, coerce_int v2)) + | _ -> failwith "value tdiv_int" + +let value_tmod_int = function + | [v1; v2] -> V_int (Sail_lib.tmod_int (coerce_int v1, coerce_int v2)) + | _ -> failwith "value tmod_int" + let value_quotient = function | [v1; v2] -> V_int (Sail_lib.quotient (coerce_int v1, coerce_int v2)) | _ -> failwith "value quotient" @@ -486,7 +494,7 @@ let value_undefined_vector = function let value_undefined_bitvector = function | [v] -> V_vector (Sail_lib.undefined_vector (coerce_int v, V_bit (Sail_lib.B0))) | _ -> failwith "value undefined_bitvector" - + let value_read_ram = function | [v1; v2; v3; v4] -> mk_vector (Sail_lib.read_ram (coerce_int v1, coerce_int v2, coerce_bv v3, coerce_bv v4)) | _ -> failwith "value read_ram" @@ -620,131 +628,136 @@ let value_decimal_string_of_bits = function | [v] -> V_string (Sail_lib.decimal_string_of_bits (coerce_bv v)) | _ -> failwith "value decimal_string_of_bits" -let primops = - List.fold_left - (fun r (x, y) -> StringMap.add x y r) - StringMap.empty - [ ("and_bool", and_bool); - ("or_bool", or_bool); - ("print", value_print); - ("prerr", fun vs -> (prerr_string (string_of_value (List.hd vs)); V_unit)); - ("dec_str", fun _ -> V_string "X"); - ("print_endline", value_print_endline); - ("prerr_endline", fun vs -> (prerr_endline (string_of_value (List.hd vs)); V_unit)); - ("putchar", value_putchar); - ("string_of_int", fun vs -> V_string (string_of_value (List.hd vs))); - ("string_of_bits", fun vs -> V_string (string_of_value (List.hd vs))); - ("decimal_string_of_bits", value_decimal_string_of_bits); - ("print_bits", value_print_bits); - ("print_int", value_print_int); - ("print_string", value_print_string); - ("prerr_bits", value_print_bits); - ("prerr_int", value_print_int); - ("prerr_string", value_prerr_string); - ("concat_str", value_concat_str); - ("eq_int", value_eq_int); - ("lteq", value_lteq); - ("gteq", value_gteq); - ("lt", value_lt); - ("gt", value_gt); - ("eq_list", value_eq_list); - ("eq_bool", value_eq_bool); - ("eq_string", value_eq_string); - ("string_startswith", value_string_startswith); - ("string_drop", value_string_drop); - ("string_take", value_string_take); - ("string_length", value_string_length); - ("eq_bit", value_eq_bit); - ("eq_anything", value_eq_anything); - ("length", value_length); - ("subrange", value_subrange); - ("access", value_access); - ("update", value_update); - ("update_subrange", value_update_subrange); - ("slice", value_slice); - ("append", value_append); - ("append_list", value_append_list); - ("not", value_not); - ("not_vec", value_not_vec); - ("and_vec", value_and_vec); - ("or_vec", value_or_vec); - ("xor_vec", value_xor_vec); - ("uint", value_uint); - ("sint", value_sint); - ("get_slice_int", value_get_slice_int); - ("set_slice_int", value_set_slice_int); - ("set_slice", value_set_slice); - ("hex_slice", value_hex_slice); - ("zero_extend", value_zero_extend); - ("sign_extend", value_sign_extend); - ("zeros", value_zeros); - ("ones", value_ones); - ("shiftr", value_shiftr); - ("shiftl", value_shiftl); - ("shift_bits_left", value_shift_bits_left); - ("shift_bits_right", value_shift_bits_right); - ("add_int", value_add_int); - ("sub_int", value_sub_int); - ("sub_nat", value_sub_nat); - ("div_int", value_quotient); - ("mult_int", value_mult); - ("mult", value_mult); - ("quotient", value_quotient); - ("modulus", value_modulus); - ("negate", value_negate); - ("pow2", value_pow2); - ("int_power", value_int_power); - ("shr_int", value_shr_int); - ("shl_int", value_shl_int); - ("max_int", value_max_int); - ("min_int", value_min_int); - ("abs_int", value_abs_int); - ("add_vec_int", value_add_vec_int); - ("sub_vec_int", value_sub_vec_int); - ("add_vec", value_add_vec); - ("sub_vec", value_sub_vec); - ("vector_truncate", value_vector_truncate); - ("vector_truncateLSB", value_vector_truncateLSB); - ("read_ram", value_read_ram); - ("write_ram", value_write_ram); - ("trace_memory_read", fun _ -> V_unit); - ("trace_memory_write", fun _ -> V_unit); - ("get_time_ns", fun _ -> V_int (Sail_lib.get_time_ns())); - ("load_raw", value_load_raw); - ("to_real", value_to_real); - ("eq_real", value_eq_real); - ("lt_real", value_lt_real); - ("gt_real", value_gt_real); - ("lteq_real", value_lteq_real); - ("gteq_real", value_gteq_real); - ("add_real", value_add_real); - ("sub_real", value_sub_real); - ("mult_real", value_mult_real); - ("round_up", value_round_up); - ("round_down", value_round_down); - ("quot_round_zero", value_quot_round_zero); - ("rem_round_zero", value_rem_round_zero); - ("quotient_real", value_quotient_real); - ("abs_real", value_abs_real); - ("div_real", value_div_real); - ("sqrt_real", value_sqrt_real); - ("print_real", value_print_real); - ("random_real", value_random_real); - ("undefined_unit", fun _ -> V_unit); - ("undefined_bit", fun _ -> V_bit Sail_lib.B0); - ("undefined_int", fun _ -> V_int Big_int.zero); - ("undefined_nat", fun _ -> V_int Big_int.zero); - ("undefined_bool", fun _ -> V_bool false); - ("undefined_bitvector", value_undefined_bitvector); - ("undefined_vector", value_undefined_vector); - ("undefined_string", fun _ -> V_string ""); - ("internal_pick", value_internal_pick); - ("replicate_bits", value_replicate_bits); - ("Elf_loader.elf_entry", fun _ -> V_int (!Elf_loader.opt_elf_entry)); - ("Elf_loader.elf_tohost", fun _ -> V_int (!Elf_loader.opt_elf_tohost)); - ("string_append", value_string_append); - ("string_length", value_string_length); - ("string_startswith", value_string_startswith); - ("string_drop", value_string_drop); - ("skip", fun _ -> V_unit); - ] +let primops = ref + (List.fold_left + (fun r (x, y) -> StringMap.add x y r) + StringMap.empty + [ ("and_bool", and_bool); + ("or_bool", or_bool); + ("print", value_print); + ("prerr", fun vs -> (prerr_string (string_of_value (List.hd vs)); V_unit)); + ("dec_str", fun _ -> V_string "X"); + ("print_endline", value_print_endline); + ("prerr_endline", fun vs -> (prerr_endline (string_of_value (List.hd vs)); V_unit)); + ("putchar", value_putchar); + ("string_of_int", fun vs -> V_string (string_of_value (List.hd vs))); + ("string_of_bits", fun vs -> V_string (string_of_value (List.hd vs))); + ("decimal_string_of_bits", value_decimal_string_of_bits); + ("print_bits", value_print_bits); + ("print_int", value_print_int); + ("print_string", value_print_string); + ("prerr_bits", value_print_bits); + ("prerr_int", value_print_int); + ("prerr_string", value_prerr_string); + ("concat_str", value_concat_str); + ("eq_int", value_eq_int); + ("lteq", value_lteq); + ("gteq", value_gteq); + ("lt", value_lt); + ("gt", value_gt); + ("eq_list", value_eq_list); + ("eq_bool", value_eq_bool); + ("eq_string", value_eq_string); + ("string_startswith", value_string_startswith); + ("string_drop", value_string_drop); + ("string_take", value_string_take); + ("string_length", value_string_length); + ("eq_bit", value_eq_bit); + ("eq_anything", value_eq_anything); + ("length", value_length); + ("subrange", value_subrange); + ("access", value_access); + ("update", value_update); + ("update_subrange", value_update_subrange); + ("slice", value_slice); + ("append", value_append); + ("append_list", value_append_list); + ("not", value_not); + ("not_vec", value_not_vec); + ("and_vec", value_and_vec); + ("or_vec", value_or_vec); + ("xor_vec", value_xor_vec); + ("uint", value_uint); + ("sint", value_sint); + ("get_slice_int", value_get_slice_int); + ("set_slice_int", value_set_slice_int); + ("set_slice", value_set_slice); + ("hex_slice", value_hex_slice); + ("zero_extend", value_zero_extend); + ("sign_extend", value_sign_extend); + ("zeros", value_zeros); + ("ones", value_ones); + ("shiftr", value_shiftr); + ("shiftl", value_shiftl); + ("shift_bits_left", value_shift_bits_left); + ("shift_bits_right", value_shift_bits_right); + ("add_int", value_add_int); + ("sub_int", value_sub_int); + ("sub_nat", value_sub_nat); + ("div_int", value_quotient); + ("tdiv_int", value_tdiv_int); + ("tmod_int", value_tmod_int); + ("mult_int", value_mult); + ("mult", value_mult); + ("quotient", value_quotient); + ("modulus", value_modulus); + ("negate", value_negate); + ("pow2", value_pow2); + ("int_power", value_int_power); + ("shr_int", value_shr_int); + ("shl_int", value_shl_int); + ("max_int", value_max_int); + ("min_int", value_min_int); + ("abs_int", value_abs_int); + ("add_vec_int", value_add_vec_int); + ("sub_vec_int", value_sub_vec_int); + ("add_vec", value_add_vec); + ("sub_vec", value_sub_vec); + ("vector_truncate", value_vector_truncate); + ("vector_truncateLSB", value_vector_truncateLSB); + ("read_ram", value_read_ram); + ("write_ram", value_write_ram); + ("trace_memory_read", fun _ -> V_unit); + ("trace_memory_write", fun _ -> V_unit); + ("get_time_ns", fun _ -> V_int (Sail_lib.get_time_ns())); + ("load_raw", value_load_raw); + ("to_real", value_to_real); + ("eq_real", value_eq_real); + ("lt_real", value_lt_real); + ("gt_real", value_gt_real); + ("lteq_real", value_lteq_real); + ("gteq_real", value_gteq_real); + ("add_real", value_add_real); + ("sub_real", value_sub_real); + ("mult_real", value_mult_real); + ("round_up", value_round_up); + ("round_down", value_round_down); + ("quot_round_zero", value_quot_round_zero); + ("rem_round_zero", value_rem_round_zero); + ("quotient_real", value_quotient_real); + ("abs_real", value_abs_real); + ("div_real", value_div_real); + ("sqrt_real", value_sqrt_real); + ("print_real", value_print_real); + ("random_real", value_random_real); + ("undefined_unit", fun _ -> V_unit); + ("undefined_bit", fun _ -> V_bit Sail_lib.B0); + ("undefined_int", fun _ -> V_int Big_int.zero); + ("undefined_nat", fun _ -> V_int Big_int.zero); + ("undefined_bool", fun _ -> V_bool false); + ("undefined_bitvector", value_undefined_bitvector); + ("undefined_vector", value_undefined_vector); + ("undefined_string", fun _ -> V_string ""); + ("internal_pick", value_internal_pick); + ("replicate_bits", value_replicate_bits); + ("Elf_loader.elf_entry", fun _ -> V_int (!Elf_loader.opt_elf_entry)); + ("Elf_loader.elf_tohost", fun _ -> V_int (!Elf_loader.opt_elf_tohost)); + ("string_append", value_string_append); + ("string_length", value_string_length); + ("string_startswith", value_string_startswith); + ("string_drop", value_string_drop); + ("skip", fun _ -> V_unit); + ]) + +let add_primop name impl = + primops := StringMap.add name impl !primops diff --git a/src/value2.lem b/src/value2.lem index 0afaa2d1..1c525f80 100644 --- a/src/value2.lem +++ b/src/value2.lem @@ -60,4 +60,7 @@ type vl = | VL_int of integer | VL_string of string | VL_real of string - | VL_null (* Used for unitialized values and null pointers in C compilation *) + | VL_empty_list + | VL_enum of string + | VL_ref of string + | VL_undefined |