From e79b9f7d8de3866b939ca9d16f11e5a9e25047ff Mon Sep 17 00:00:00 2001 From: Jon French Date: Mon, 8 Oct 2018 15:25:23 +0100 Subject: Interpreter: refactor get/put state into more fine-grained responses in the monad --- src/interpreter.ml | 193 +++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 135 insertions(+), 58 deletions(-) (limited to 'src') diff --git a/src/interpreter.ml b/src/interpreter.ml index 2ea8bb00..407f512a 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -52,6 +52,8 @@ open Ast open Ast_util open Value + + type gstate = { registers : value Bindings.t; allow_registers : bool; (* For some uses we want to forbid touching any registers. *) @@ -123,8 +125,19 @@ type 'a response = | Exception of value | Assertion_failed of string | Call of id * value list * (return_value -> 'a) - | Gets of (state -> 'a) - | Puts of state * (unit -> 'a) + | Fail of string + (* TODO *) + (* | Read_mem of Sail2_instr_kinds.read_kind * (\* address : *\) value * (\* length : *\) value * (value -> 'a) + * | Write_ea of Sail2_instr_kinds.write_kind * (\* address : *\) value * (\* length : *\) value * (unit -> 'a) + * | Excl_res of (bool -> 'a) + * | Write_memv of value * (bool -> 'a) + * | Barrier of Sail2_instr_kinds.barrier_kind * (unit -> 'a) *) + | Read_reg of string * (value -> 'a) + | Write_reg of string * value * (unit -> 'a) + | Get_primop of string * ((value list -> value) -> 'a) + | Get_local of string * (value -> 'a) + | Put_local of string * value * (unit -> 'a) + | Get_global_letbinds of ((Type_check.tannot letbind) list -> 'a) and 'a monad = | Pure of 'a @@ -134,9 +147,20 @@ let map_response f = function | Early_return v -> Early_return v | Exception v -> Exception v | Assertion_failed str -> Assertion_failed str - | Gets g -> Gets (fun s -> f (g s)) - | Puts (s, cont) -> Puts (s, fun () -> f (cont ())) | Call (id, vals, cont) -> Call (id, vals, fun v -> f (cont v)) + | Fail s -> Fail s + (* TODO *) + (* | Read_mem (rk, addr, len, cont) -> Read_mem (rk, addr, len, fun v -> f (cont v)) + * | Write_ea (wk, addr, len, cont) -> Write_ea (wk, addr, len, fun () -> f (cont ())) + * | Excl_res cont -> Excl_res (fun b -> f (cont b)) + * | Write_memv (v, cont) -> Write_memv (v, fun b -> f (cont b)) + * | Barrier (bk, cont) -> Barrier (bk, fun () -> f (cont ())) *) + | Read_reg (name, cont) -> Read_reg (name, fun v -> f (cont v)) + | Write_reg (name, v, cont) -> Write_reg (name, v, fun () -> f (cont ())) + | Get_primop (name, cont) -> Get_primop (name, fun op -> f (cont op)) + | Get_local (name, cont) -> Get_local (name, fun v -> f (cont v)) + | Put_local (name, v, cont) -> Put_local (name, v, fun () -> f (cont ())) + | Get_global_letbinds cont -> Get_global_letbinds (fun lbs -> f (cont lbs)) let rec liftM f = function | Pure x -> Pure (f x) @@ -170,12 +194,43 @@ 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 gets : state monad = - Yield (Gets (fun s -> Pure s)) - -let puts (s : state) : unit monad = - Yield (Puts (s, fun () -> Pure ())) - +(* TODO *) +(* let read_mem (rk, addr, len) : value monad = + * Yield (Read_mem (rk, addr, len, (fun v -> Pure v))) + * + * let write_ea (wk, addr, len) : unit monad = + * Yield (Write_ea (wk, addr, len, (fun () -> Pure ()))) + * + * let excl_res () : bool monad = + * Yield (Excl_res (fun b -> Pure b)) + * + * let write_memv v : bool monad = + * Yield (Write_memv (v, fun b -> Pure b)) + * + * let barrier bk : unit monad = + * Yield (Barrier (bk, fun () -> Pure ())) *) + +let read_reg name : value monad = + Yield (Read_reg (name, fun v -> Pure v)) + +let write_reg name v : unit monad = + Yield (Write_reg (name, v, fun () -> Pure ())) + +let fail s = + Yield (Fail s) + +let get_primop name : (value list -> value) monad = + Yield (Get_primop (name, fun op -> Pure op)) + +let get_local name : value monad = + Yield (Get_local (name, fun v -> Pure v)) + +let put_local name v : unit monad = + Yield (Put_local (name, v, fun () -> Pure ())) + +let get_global_letbinds () : (Type_check.tannot letbind) list monad = + Yield (Get_global_letbinds (fun lbs -> Pure lbs)) + let early_return v = Yield (Early_return v) let assertion_failed msg = Yield (Assertion_failed msg) @@ -278,7 +333,7 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = if matched then return (List.fold_left (fun body (id, v) -> subst id v body) body (Bindings.bindings bindings)) else - failwith "Match failure" + fail "Match failure" | E_vector_subrange (vec, n, m) -> wrap (E_app (mk_id "vector_subrange_dec", [vec; n; m])) @@ -306,14 +361,9 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = let extern = get_interpreter_extern id (env_of_annot annot) in if extern = "reg_deref" then let regname = List.hd evaluated |> value_of_exp |> coerce_ref in - gets >>= fun (_, gstate) -> - if gstate.allow_registers - then return (exp_of_value (Bindings.find (mk_id regname) gstate.registers)) - else raise Not_found + read_reg regname >>= fun v -> return (exp_of_value v) else - gets >>= fun (_, gstate) -> - let primop = try StringMap.find extern gstate.primops with Not_found -> failwith ("No primop " ^ extern) in - return (exp_of_value (primop (List.map value_of_exp evaluated))) + get_primop extern >>= fun op -> return (exp_of_value (op (List.map value_of_exp evaluated))) end | [] -> call id (List.map value_of_exp evaluated) >>= @@ -370,33 +420,23 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = | E_exit exp -> step exp >>= fun exp' -> wrap (E_exit exp') | E_ref id -> - gets >>= fun (lstate, gstate) -> - if Bindings.mem id gstate.registers && gstate.allow_registers then - return (exp_of_value (V_ref (string_of_id id))) - else - failwith ("Could not find register " ^ string_of_id id) + return (exp_of_value (V_ref (string_of_id id))) | E_id id -> begin let open Type_check in - gets >>= fun (lstate, gstate) -> match Env.lookup_id id (env_of_annot annot) with - | Register _ when gstate.allow_registers -> - let exp = - try exp_of_value (Bindings.find id gstate.registers) with - | Not_found -> - (* Replace with error message? *) - let exp = mk_exp (E_app (mk_id ("undefined_" ^ string_of_typ (typ_of orig_exp)), [mk_exp (E_lit (mk_lit (L_unit)))])) in - Type_check.check_exp (env_of_annot annot) exp (typ_of orig_exp) - in - return exp - | Local (Mutable, _) -> return (local_variable id lstate gstate) + | Register _ -> + read_reg (string_of_id id) >>= fun v -> return (exp_of_value v) + | Local (Mutable, _) -> get_local (string_of_id id) >>= fun v -> return (exp_of_value v) | Local (Immutable, _) -> - let chain = build_letchain id gstate.letbinds orig_exp in + (* if we get here without already having substituted, it must be a top-level letbind *) + get_global_letbinds () >>= fun lbs -> + let chain = build_letchain id lbs orig_exp in return chain | Enum _ -> return (exp_of_value (V_ctor (string_of_id id, []))) - | _ -> failwith ("Coudln't find id " ^ string_of_id id) + | _ -> fail ("Couldn't find id " ^ string_of_id id) end | E_record (FES_aux (FES_Fexps (fexps, flag), fes_annot)) -> @@ -458,25 +498,18 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = | E_assign (LEXP_aux (LEXP_id id, _), exp) | E_assign (LEXP_aux (LEXP_cast (_, id), _), exp) -> begin let open Type_check in - gets >>= fun (lstate, gstate) -> match Env.lookup_id id (env_of_annot annot) with - | Register _ when gstate.allow_registers -> - puts (lstate, { gstate with registers = Bindings.add id (value_of_exp exp) gstate.registers }) >> wrap unit_exp + | Register _ -> + write_reg (string_of_id id) (value_of_exp exp) >> wrap unit_exp | Local (Mutable, _) | Unbound -> - begin - puts ({ locals = Bindings.add id (value_of_exp exp) lstate.locals }, gstate) >> wrap unit_exp - end + put_local (string_of_id id) (value_of_exp exp) >> wrap unit_exp | _ -> failwith "Assign" end | E_assign (LEXP_aux (LEXP_deref reference, annot), exp) when not (is_value reference) -> step reference >>= fun reference' -> wrap (E_assign (LEXP_aux (LEXP_deref reference', annot), exp)) | E_assign (LEXP_aux (LEXP_deref reference, annot), exp) -> let name = coerce_ref (value_of_exp reference) in - gets >>= fun (lstate, gstate) -> - if Bindings.mem (mk_id name) gstate.registers && gstate.allow_registers then - puts (lstate, { gstate with registers = Bindings.add (mk_id name) (value_of_exp exp) gstate.registers }) >> wrap unit_exp - else - failwith "Assign to nonexistent register" + write_reg name (value_of_exp exp) >> wrap unit_exp | E_assign (LEXP_aux (LEXP_tup lexps, annot), exp) -> failwith "Tuple assignment" | E_assign (LEXP_aux (LEXP_vector_concat lexps, annot), exp) -> failwith "Vector concat assignment" (* @@ -640,34 +673,78 @@ let rec eval_frame' = function | Done (state, v) -> Done (state, v) | Break frame -> Break frame | Step (out, state, m, stack) -> + let lstate, gstate = state in match (m, stack) with | Pure v, [] when is_value v -> Done (state, value_of_exp v) | Pure v, (head :: stack') when is_value v -> - Step (stack_string head, (stack_state head, snd state), stack_cont head (Return_ok (value_of_exp v)), stack') + Step (stack_string head, (stack_state head, gstate), stack_cont head (Return_ok (value_of_exp v)), stack') | Pure exp', _ -> let out' = lazy (Pretty_print_sail.to_string (Pretty_print_sail.doc_exp exp')) in Step (out', state, step exp', stack) | Yield (Call(id, vals, cont)), _ when string_of_id id = "break" -> let arg = if List.length vals != 1 then tuple_value vals else List.hd vals in - let body = exp_of_fundef (Bindings.find id (snd state).fundefs) arg in - Break (Step (lazy "", (initial_lstate, snd state), return body, (out, fst state, cont) :: stack)) + let body = exp_of_fundef (Bindings.find id gstate.fundefs) arg in + Break (Step (lazy "", (initial_lstate, gstate), return body, (out, lstate, cont) :: stack)) | Yield (Call(id, vals, cont)), _ -> let arg = if List.length vals != 1 then tuple_value vals else List.hd vals in - let body = exp_of_fundef (Bindings.find id (snd state).fundefs) arg in - Step (lazy "", (initial_lstate, snd state), return body, (out, fst state, cont) :: stack) - | Yield (Gets cont), _ -> - eval_frame' (Step (out, state, cont state, stack)) - | Yield (Puts (state', cont)), _ -> + let body = exp_of_fundef (Bindings.find id gstate.fundefs) arg in + Step (lazy "", (initial_lstate, gstate), return body, (out, lstate, cont) :: stack) + + | Yield (Read_reg (name, cont)), _ -> + begin + let gstate = gstate in + if gstate.allow_registers then + try + eval_frame' (Step (out, state, cont (Bindings.find (mk_id name) gstate.registers), stack)) + with Not_found -> + eval_frame' (Step (out, state, fail ("Read of nonexistent register: " ^ name), stack)) + else + eval_frame' (Step (out, state, fail ("Register read disallowed by allow_registers setting: " ^ name), stack)) + end + | Yield (Write_reg (name, v, cont)), _ -> + begin + let id = mk_id name in + let gstate = gstate in + if gstate.allow_registers then + (* TODO: check existence of register? would then need to initialise all to undefined below or similar *) + (* if Bindings.mem id gstate.registers then *) + let state' = (lstate, { gstate with registers = Bindings.add id v gstate.registers }) in + eval_frame' (Step (out, state', cont (), stack)) + (* else + * eval_frame' (Step (out, state, fail ("Write of nonexistent register: " ^ name), stack)) *) + else + eval_frame' (Step (out, state, fail ("Register write disallowed by allow_registers setting: " ^ name), stack)) + end + | Yield (Get_primop (name, cont)), _ -> + begin + try + let op = StringMap.find name 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)) + end + | Yield (Get_local (name, cont)), _ -> + begin + try + eval_frame' (Step (out, state, cont (Bindings.find (mk_id name) lstate.locals), stack)) + with Not_found -> + eval_frame' (Step (out, state, fail ("Local not found: " ^ name), stack)) + end + | Yield (Put_local (name, v, cont)), _ -> + let state' = ({ locals = Bindings.add (mk_id name) v lstate.locals }, gstate) in eval_frame' (Step (out, state', cont (), stack)) + | Yield (Get_global_letbinds cont), _ -> + eval_frame' (Step (out, state, cont gstate.letbinds, stack)) + | Yield (Early_return v), [] -> Done (state, v) | Yield (Early_return v), (head :: stack') -> - Step (stack_string head, (stack_state head, snd state), stack_cont head (Return_ok v), stack') - | Yield (Assertion_failed msg), _ -> + Step (stack_string head, (stack_state head, gstate), stack_cont head (Return_ok v), stack') + | Yield (Assertion_failed msg), _ | Yield (Fail msg), _ -> failwith msg | Yield (Exception v), [] -> failwith ("Uncaught Exception" |> Util.cyan |> Util.clear) | Yield (Exception v), (head :: stack') -> - Step (stack_string head, (stack_state head, snd state), stack_cont head (Return_exception v), stack') + Step (stack_string head, (stack_state head, gstate), stack_cont head (Return_exception v), stack') let eval_frame frame = try eval_frame' frame with -- cgit v1.2.3 From 73697a01478a61e7fa5385f881731c9111dcd9a4 Mon Sep 17 00:00:00 2001 From: Jon French Date: Mon, 15 Oct 2018 14:35:18 +0100 Subject: Interpreter: add new command :bin to load raw binary into memory --- src/elf_loader.ml | 18 ++++++++++++++++++ src/isail.ml | 14 +++++++++++++- 2 files changed, 31 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/elf_loader.ml b/src/elf_loader.ml index 88fcfddb..c6fb0589 100644 --- a/src/elf_loader.ml +++ b/src/elf_loader.ml @@ -149,6 +149,24 @@ let load_elf ?writer:(writer=write_sail_lib) name = opt_elf_tohost := tohost_addr); List.iter (load_segment ~writer:writer) segments +let load_binary ?writer:(writer=write_sail_lib) addr name = + let f = open_in_bin name in + let buf = Buffer.create 1024 in + try + while true do + let char = input_char f in + Buffer.add_char buf char; + done; + assert false + with + | End_of_file -> begin + Bytes.iteri (fun i ch -> writer addr i (int_of_char ch)) (Buffer.to_bytes buf); + close_in f + end + | exc -> + close_in f; + raise exc + (* The sail model can access this by externing a unit -> int function as Elf_loader.elf_entry. *) let elf_entry () = !opt_elf_entry diff --git a/src/isail.ml b/src/isail.ml index c3f869a3..4e237943 100644 --- a/src/isail.ml +++ b/src/isail.ml @@ -179,6 +179,8 @@ let help = function ":help - Get a description of . Commands are prefixed with a colon, e.g. :help :type." | ":elf" -> ":elf - Load an ELF file." + | ":bin" -> + ":bin
- Load a binary file at the given address." | ":r" | ":run" -> "(:r | :run) - Completely evaluate the currently evaluating expression." | ":s" | ":step" -> @@ -256,7 +258,7 @@ let handle_input' input = | ":commands" -> let commands = [ "Universal commands - :(t)ype :(i)nfer :(q)uit :(v)erbose :clear :commands :help :output :option"; - "Normal mode commands - :elf :(l)oad :(u)nload"; + "Normal mode commands - :elf :bin :(l)oad :(u)nload"; "Evaluation mode commands - :(r)un :(s)tep :(n)ormal"; ""; ":(c)ommand can be called as either :c or :command." ] @@ -320,6 +322,16 @@ let handle_input' input = begin match cmd with | ":elf" -> Elf_loader.load_elf arg + | ":bin" -> + begin + let args = Util.split_on_char ' ' arg in + match args with + | [addr_s; filename] -> + let addr = Big_int.of_string addr_s in + Elf_loader.load_binary addr filename + | _ -> + print_endline "Invalid argument for :bin, expected " + end | ":l" | ":load" -> let files = Util.split_on_char ' ' arg in let (_, ast, env) = load_files !interactive_env files in -- cgit v1.2.3 From 45ce9105ce90efeccb9d0a183390027cdb1536af Mon Sep 17 00:00:00 2001 From: Jon French Date: Mon, 15 Oct 2018 16:47:41 +0100 Subject: Ocaml backend: omit function definitions for externs --- src/ocaml_backend.ml | 124 +++++++++++++++++++++++++++------------------------ 1 file changed, 65 insertions(+), 59 deletions(-) (limited to 'src') diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index 5df41a80..cdc6a730 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -455,70 +455,76 @@ let ocaml_funcls ctx = function | [] -> failwith "Ocaml: empty function" | [FCL_aux (FCL_Funcl (id, pexp),_)] -> - let typ1, typ2 = - match Bindings.find id ctx.val_specs with - | Typ_aux (Typ_fn (typ1, typ2, _), _) -> (typ1, typ2) - | _ -> failwith "Found val spec which was not a function!" - in - (* Any remaining type variables after simple_typ rewrite should - indicate Type-polymorphism. If we have it, we need to generate - explicit type signatures with universal quantification. *) - let kids = KidSet.union (tyvars_of_typ typ1) (tyvars_of_typ typ2) in - let pat_sym = gensym () in - let pat, exp = - match pexp with - | Pat_aux (Pat_exp (pat, exp),_) -> pat,exp - | Pat_aux (Pat_when (pat, wh, exp),_) -> failwith "OCaml: top-level pattern guards not supported" - in - let annot_pat = - let pat = + if Bindings.mem id ctx.externs + then string ("(* Omitting externed function " ^ string_of_id id ^ " *)") ^^ hardline + else + let typ1, typ2 = + match Bindings.find id ctx.val_specs with + | Typ_aux (Typ_fn (typ1, typ2, _), _) -> (typ1, typ2) + | _ -> failwith "Found val spec which was not a function!" + in + (* Any remaining type variables after simple_typ rewrite should + indicate Type-polymorphism. If we have it, we need to generate + explicit type signatures with universal quantification. *) + let kids = KidSet.union (tyvars_of_typ typ1) (tyvars_of_typ typ2) in + let pat_sym = gensym () in + let pat, exp = + match pexp with + | Pat_aux (Pat_exp (pat, exp),_) -> pat,exp + | Pat_aux (Pat_when (pat, wh, exp),_) -> failwith "OCaml: top-level pattern guards not supported" + in + let annot_pat = + let pat = + if KidSet.is_empty kids then + parens (ocaml_pat ctx pat ^^ space ^^ colon ^^ space ^^ ocaml_typ ctx typ1) + else + ocaml_pat ctx pat + in + if !opt_trace_ocaml + then parens (separate space [pat; string "as"; pat_sym]) + else pat + in + let call_header = function_header () in + let arg_sym, string_of_arg, ret_sym, string_of_ret = trace_info typ1 typ2 in + let call = if KidSet.is_empty kids then - parens (ocaml_pat ctx pat ^^ space ^^ colon ^^ space ^^ ocaml_typ ctx typ1) + separate space [call_header; zencode ctx id; + annot_pat; colon; ocaml_typ ctx typ2; equals; + sail_call id arg_sym pat_sym ret_sym; string "(fun r ->"] + ^//^ ocaml_exp ctx exp + ^^ rparen else - ocaml_pat ctx pat + separate space [call_header; zencode ctx id; colon; + separate space (List.map zencode_kid (KidSet.elements kids)) ^^ dot; + ocaml_typ ctx typ1; string "->"; ocaml_typ ctx typ2; equals; + string "fun"; annot_pat; string "->"; + sail_call id arg_sym pat_sym ret_sym; string "(fun r ->"] + ^//^ ocaml_exp ctx exp + ^^ rparen in - if !opt_trace_ocaml - then parens (separate space [pat; string "as"; pat_sym]) - else pat - in - let call_header = function_header () in - let arg_sym, string_of_arg, ret_sym, string_of_ret = trace_info typ1 typ2 in - let call = - if KidSet.is_empty kids then - separate space [call_header; zencode ctx id; - annot_pat; colon; ocaml_typ ctx typ2; equals; - sail_call id arg_sym pat_sym ret_sym; string "(fun r ->"] - ^//^ ocaml_exp ctx exp - ^^ rparen - else - separate space [call_header; zencode ctx id; colon; - separate space (List.map zencode_kid (KidSet.elements kids)) ^^ dot; - ocaml_typ ctx typ1; string "->"; ocaml_typ ctx typ2; equals; - string "fun"; annot_pat; string "->"; - sail_call id arg_sym pat_sym ret_sym; string "(fun r ->"] - ^//^ ocaml_exp ctx exp - ^^ rparen - in - ocaml_funcl call string_of_arg string_of_ret + ocaml_funcl call string_of_arg string_of_ret | funcls -> let id = funcls_id funcls in - let typ1, typ2 = - match Bindings.find id ctx.val_specs with - | Typ_aux (Typ_fn (typ1, typ2, _), _) -> (typ1, typ2) - | _ -> failwith "Found val spec which was not a function!" - in - let kids = KidSet.union (tyvars_of_typ typ1) (tyvars_of_typ typ2) in - if not (KidSet.is_empty kids) then failwith "Cannot handle polymorphic multi-clause function in OCaml backend" else (); - let pat_sym = gensym () in - let call_header = function_header () in - let arg_sym, string_of_arg, ret_sym, string_of_ret = trace_info typ1 typ2 in - let call = - separate space [call_header; zencode ctx id; parens (pat_sym ^^ space ^^ colon ^^ space ^^ ocaml_typ ctx typ1); equals; - sail_call id arg_sym pat_sym ret_sym; string "(fun r ->"] - ^//^ (separate space [string "match"; pat_sym; string "with"] ^^ hardline ^^ ocaml_funcl_matches ctx funcls) - ^^ rparen - in - ocaml_funcl call string_of_arg string_of_ret + if Bindings.mem id ctx.externs + then string ("(* Omitting externed function " ^ string_of_id id ^ " *)") ^^ hardline + else + let typ1, typ2 = + match Bindings.find id ctx.val_specs with + | Typ_aux (Typ_fn (typ1, typ2, _), _) -> (typ1, typ2) + | _ -> failwith "Found val spec which was not a function!" + in + let kids = KidSet.union (tyvars_of_typ typ1) (tyvars_of_typ typ2) in + if not (KidSet.is_empty kids) then failwith "Cannot handle polymorphic multi-clause function in OCaml backend" else (); + let pat_sym = gensym () in + let call_header = function_header () in + let arg_sym, string_of_arg, ret_sym, string_of_ret = trace_info typ1 typ2 in + let call = + separate space [call_header; zencode ctx id; parens (pat_sym ^^ space ^^ colon ^^ space ^^ ocaml_typ ctx typ1); equals; + sail_call id arg_sym pat_sym ret_sym; string "(fun r ->"] + ^//^ (separate space [string "match"; pat_sym; string "with"] ^^ hardline ^^ ocaml_funcl_matches ctx funcls) + ^^ rparen + in + ocaml_funcl call string_of_arg string_of_ret let ocaml_fundef ctx (FD_aux (FD_function (_, _, _, funcls), _)) = ocaml_funcls ctx funcls -- cgit v1.2.3 From 6d90d18e460450b604cbfbd3f5bbe6db6cf6a61a Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 24 Oct 2018 11:32:54 +0100 Subject: Interpreter: don't silently use OCaml externs, only interpreter externs (Adds 'interpreter' externs as appropriate.) --- src/interpreter.ml | 5 ++--- src/value.ml | 31 +++++++++++++++++++++++++++++++ 2 files changed, 33 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/interpreter.ml b/src/interpreter.ml index 407f512a..e355b6d3 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -266,12 +266,11 @@ let rec build_letchain id lbs (E_aux (_, annot) as exp) = let is_interpreter_extern id env = let open Type_check in - Env.is_extern id env "interpreter" || Env.is_extern id env "ocaml" + Env.is_extern id env "interpreter" let get_interpreter_extern id env = let open Type_check in - try Env.get_extern id env "interpreter" with - | Type_error _ -> Env.get_extern id env "ocaml" + Env.get_extern id env "interpreter" let rec step (E_aux (e_aux, annot) as orig_exp) = let wrap e_aux' = return (E_aux (e_aux', annot)) in diff --git a/src/value.ml b/src/value.ml index 157c16fc..90f6d947 100644 --- a/src/value.ml +++ b/src/value.ml @@ -274,6 +274,10 @@ let value_or_vec = function | [v1; v2] -> mk_vector (Sail_lib.or_vec (coerce_bv v1, coerce_bv v2)) | _ -> failwith "value not_vec" +let value_xor_vec = function + | [v1; v2] -> mk_vector (Sail_lib.xor_vec (coerce_bv v1, coerce_bv v2)) + | _ -> failwith "value xor_vec" + let value_uint = function | [v] -> V_int (Sail_lib.uint (coerce_bv v)) | _ -> failwith "value uint" @@ -407,6 +411,14 @@ let value_shiftr = function | [v1; v2] -> mk_vector (Sail_lib.shiftr (coerce_bv v1, coerce_int v2)) | _ -> failwith "value shiftr" +let value_shift_bits_left = function + | [v1; v2] -> mk_vector (Sail_lib.shift_bits_left (coerce_bv v1, coerce_bv v2)) + | _ -> failwith "value shift_bits_left" + +let value_shift_bits_right = function + | [v1; v2] -> mk_vector (Sail_lib.shift_bits_right (coerce_bv v1, coerce_bv v2)) + | _ -> failwith "value shift_bits_right" + let value_vector_truncate = function | [v1; v2] -> mk_vector (Sail_lib.vector_truncate (coerce_bv v1, coerce_int v2)) | _ -> failwith "value vector_truncate" @@ -498,6 +510,14 @@ let value_round_down = function | [v] -> V_int (Sail_lib.round_down (coerce_real v)) | _ -> failwith "value round_down" +let value_quot_round_zero = function + | [v1; v2] -> V_int (Sail_lib.quot_round_zero (coerce_int v1, coerce_int v2)) + | _ -> failwith "value quot_round_zero" + +let value_rem_round_zero = function + | [v1; v2] -> V_int (Sail_lib.rem_round_zero (coerce_int v1, coerce_int v2)) + | _ -> failwith "value rem_round_zero" + let value_eq_real = function | [v1; v2] -> V_bool (Sail_lib.eq_real (coerce_real v1, coerce_real v2)) | _ -> failwith "value eq_real" @@ -522,6 +542,10 @@ let value_string_append = function | [v1; v2] -> V_string (Sail_lib.string_append (coerce_string v1, coerce_string v2)) | _ -> failwith "value string_append" +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) @@ -536,6 +560,7 @@ let primops = ("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); @@ -568,6 +593,7 @@ let primops = ("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); @@ -579,6 +605,8 @@ let primops = ("zeros", value_zeros); ("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); ("div_int", value_quotient); @@ -610,6 +638,8 @@ let primops = ("gteq_real", value_gt_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); ("undefined_unit", fun _ -> V_unit); ("undefined_bit", fun _ -> V_bit Sail_lib.B0); @@ -625,4 +655,5 @@ let primops = ("string_length", value_string_length); ("string_startswith", value_string_startswith); ("string_drop", value_string_drop); + ("skip", fun _ -> V_unit); ] -- cgit v1.2.3 From 90d4cc654a0833e8c7dac4831be0fa94a0d10192 Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 24 Oct 2018 11:42:33 +0100 Subject: src/Makefile: add isail.byte target for debugging interpreter --- src/Makefile | 3 +++ 1 file changed, 3 insertions(+) (limited to 'src') diff --git a/src/Makefile b/src/Makefile index 3e9d6f63..f4e0c967 100644 --- a/src/Makefile +++ b/src/Makefile @@ -105,6 +105,9 @@ sail.native: sail sail.byte: ast.ml bytecode.ml share_directory.ml ocamlbuild -use-ocamlfind -cflag -g sail.byte +isail.byte: ast.ml bytecode.ml share_directory.ml + ocamlbuild -use-ocamlfind isail.byte + interpreter: lem_interp/interp_ast.lem ocamlbuild -use-ocamlfind lem_interp/extract.cmxa ocamlbuild -use-ocamlfind lem_interp/extract.cma -- cgit v1.2.3 From d16665e1a3c7d70884d8b48f31f47a4c15cfbd1a Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 24 Oct 2018 11:45:56 +0100 Subject: Interpreter: improve error handling/messages --- src/interpreter.ml | 120 ++++++++++++++++++++++++++++++++++------------------- 1 file changed, 77 insertions(+), 43 deletions(-) (limited to 'src') diff --git a/src/interpreter.ml b/src/interpreter.ml index e355b6d3..3b050089 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -93,7 +93,8 @@ let value_of_lit (L_aux (l_aux, _)) = V_real (Rational.add whole frac) | _ -> failwith "could not parse real literal" end - | _ -> failwith "Unimplemented value_of_lit" (* TODO *) + | L_undef -> failwith "value_of_lit of undefined" + let is_value = function | (E_aux (E_internal_value _, _)) -> true @@ -281,7 +282,11 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = | E_block (exp :: exps) -> step exp >>= fun exp' -> wrap (E_block (exp' :: exps)) - | E_lit lit -> return (exp_of_value (value_of_lit lit)) + | E_lit lit -> + begin + try return (exp_of_value (value_of_lit lit)) + with Failure s -> fail ("Failure: " ^ s) + end | E_if (exp, then_exp, else_exp) when is_true exp -> return then_exp | E_if (exp, then_exp, else_exp) when is_false exp -> return else_exp @@ -293,7 +298,7 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = | E_assert (exp, msg) when is_true exp -> wrap unit_exp | E_assert (exp, msg) when is_false exp && is_value msg -> - failwith (coerce_string (value_of_exp msg)) + assertion_failed (coerce_string (value_of_exp msg)) | E_assert (exp, msg) when is_false exp -> step msg >>= fun msg' -> wrap (E_assert (exp, msg')) | E_assert (exp, msg) -> @@ -392,22 +397,28 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = | E_case (exp, pexps) when not (is_value exp) -> step exp >>= fun exp' -> wrap (E_case (exp', pexps)) - | E_case (_, []) -> failwith "Pattern matching failed" + | E_case (_, []) -> fail "Pattern matching failed" | E_case (exp, Pat_aux (Pat_exp (pat, body), _) :: pexps) -> - let matched, bindings = pattern_match (Type_check.env_of body) pat (value_of_exp exp) in - if matched then - return (List.fold_left (fun body (id, v) -> subst id v body) body (Bindings.bindings bindings)) - else - wrap (E_case (exp, pexps)) + begin try + let matched, bindings = pattern_match (Type_check.env_of body) pat (value_of_exp exp) in + if matched then + return (List.fold_left (fun body (id, v) -> subst id v body) body (Bindings.bindings bindings)) + else + wrap (E_case (exp, pexps)) + with Failure s -> fail ("Failure: " ^ s) + end | E_case (exp, Pat_aux (Pat_when (pat, guard, body), pat_annot) :: pexps) when not (is_value guard) -> - let matched, bindings = pattern_match (Type_check.env_of body) pat (value_of_exp exp) in - if matched then - let guard = List.fold_left (fun guard (id, v) -> subst id v guard) guard (Bindings.bindings bindings) in - let body = List.fold_left (fun body (id, v) -> subst id v body) body (Bindings.bindings bindings) in - step guard >>= fun guard' -> - wrap (E_case (exp, Pat_aux (Pat_when (pat, guard', body), pat_annot) :: pexps)) - else - wrap (E_case (exp, pexps)) + begin try + let matched, bindings = pattern_match (Type_check.env_of body) pat (value_of_exp exp) in + if matched then + let guard = List.fold_left (fun guard (id, v) -> subst id v guard) guard (Bindings.bindings bindings) in + let body = List.fold_left (fun body (id, v) -> subst id v body) body (Bindings.bindings bindings) in + step guard >>= fun guard' -> + wrap (E_case (exp, Pat_aux (Pat_when (pat, guard', body), pat_annot) :: pexps)) + else + wrap (E_case (exp, pexps)) + with Failure s -> fail ("Failure: " ^ s) + end | E_case (exp, Pat_aux (Pat_when (pat, guard, body), pat_annot) :: pexps) when is_true guard -> return body | E_case (exp, Pat_aux (Pat_when (pat, guard, body), pat_annot) :: pexps) when is_false guard -> wrap (E_case (exp, pexps)) @@ -479,38 +490,51 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = | E_assign (lexp, exp) when not (is_value exp) -> step exp >>= fun exp' -> wrap (E_assign (lexp, exp')) | E_assign (LEXP_aux (LEXP_memory (id, args), _), exp) -> wrap (E_app (id, args @ [exp])) | E_assign (LEXP_aux (LEXP_field (lexp, id), ul), exp) -> - let open Type_check in - let lexp_exp = infer_exp (env_of_annot annot) (exp_of_lexp (strip_lexp lexp)) in - let exp' = E_aux (E_record_update (lexp_exp, FES_aux (FES_Fexps ([FE_aux (FE_Fexp (id, exp), ul)], false), ul)), ul) in - wrap (E_assign (lexp, exp')) + begin try + let open Type_check in + let lexp_exp = infer_exp (env_of_annot annot) (exp_of_lexp (strip_lexp lexp)) in + let exp' = E_aux (E_record_update (lexp_exp, FES_aux (FES_Fexps ([FE_aux (FE_Fexp (id, exp), ul)], false), ul)), ul) in + wrap (E_assign (lexp, exp')) + with Failure s -> fail ("Failure: " ^ s) + end | E_assign (LEXP_aux (LEXP_vector (vec, n), lexp_annot), exp) -> - let open Type_check in - let vec_exp = infer_exp (env_of_annot annot) (exp_of_lexp (strip_lexp vec)) in - let exp' = E_aux (E_vector_update (vec_exp, n, exp), lexp_annot) in - wrap (E_assign (vec, exp')) + begin try + let open Type_check in + let vec_exp = infer_exp (env_of_annot annot) (exp_of_lexp (strip_lexp vec)) in + let exp' = E_aux (E_vector_update (vec_exp, n, exp), lexp_annot) in + wrap (E_assign (vec, exp')) + with Failure s -> fail ("Failure: " ^ s) + end | E_assign (LEXP_aux (LEXP_vector_range (vec, n, m), lexp_annot), exp) -> - let open Type_check in - let vec_exp = infer_exp (env_of_annot annot) (exp_of_lexp (strip_lexp vec)) in - (* FIXME: let the type checker check this *) - let exp' = E_aux (E_vector_update_subrange (vec_exp, n, m, exp), lexp_annot) in - wrap (E_assign (vec, exp')) + begin try + let open Type_check in + let vec_exp = infer_exp (env_of_annot annot) (exp_of_lexp (strip_lexp vec)) in + (* FIXME: let the type checker check this *) + let exp' = E_aux (E_vector_update_subrange (vec_exp, n, m, exp), lexp_annot) in + wrap (E_assign (vec, exp')) + with Failure s -> fail ("Failure: " ^ s) + end | E_assign (LEXP_aux (LEXP_id id, _), exp) | E_assign (LEXP_aux (LEXP_cast (_, id), _), exp) -> begin let open Type_check in + let name = string_of_id id in match Env.lookup_id id (env_of_annot annot) with | Register _ -> - write_reg (string_of_id id) (value_of_exp exp) >> wrap unit_exp + write_reg name (value_of_exp exp) >> wrap unit_exp | Local (Mutable, _) | Unbound -> - put_local (string_of_id id) (value_of_exp exp) >> wrap unit_exp - | _ -> failwith "Assign" + put_local name (value_of_exp exp) >> wrap unit_exp + | Local (Immutable, _) -> + fail ("Assignment to immutable local: " ^ name) + | Enum _ -> + fail ("Assignment to union constructor: " ^ name) end | E_assign (LEXP_aux (LEXP_deref reference, annot), exp) when not (is_value reference) -> step reference >>= fun reference' -> wrap (E_assign (LEXP_aux (LEXP_deref reference', annot), exp)) | E_assign (LEXP_aux (LEXP_deref reference, annot), exp) -> let name = coerce_ref (value_of_exp reference) in write_reg name (value_of_exp exp) >> wrap unit_exp - | E_assign (LEXP_aux (LEXP_tup lexps, annot), exp) -> failwith "Tuple assignment" - | E_assign (LEXP_aux (LEXP_vector_concat lexps, annot), exp) -> failwith "Vector concat assignment" + | E_assign (LEXP_aux (LEXP_tup lexps, annot), exp) -> fail "Tuple assignment" + | E_assign (LEXP_aux (LEXP_vector_concat lexps, annot), exp) -> fail "Vector concat assignment" (* let values = coerce_tuple (value_of_exp exp) in wrap (E_block (List.map2 (fun lexp v -> E_aux (E_assign (lexp, exp_of_value v), (Parse_ast.Unknown, None))) lexps values)) @@ -544,7 +568,7 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = wrap (E_block [subst id v_from body; E_aux (E_for (id, exp_of_value (value_sub_int [v_from; v_step]), exp_to, exp_step, ord, body), annot)]) | _ -> assert false end - | Ord_aux (Ord_var _, _) -> failwith "Polymorphic order in foreach" + | Ord_aux (Ord_var _, _) -> fail "Polymorphic order in foreach" end | E_for (id, exp_from, exp_to, exp_step, ord, body) when is_value exp_to && is_value exp_step -> step exp_from >>= fun exp_from' -> wrap (E_for (id, exp_from', exp_to, exp_step, ord, body)) @@ -555,7 +579,7 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = | E_sizeof _ | E_constraint _ -> assert false (* Must be re-written before interpreting *) - | _ -> failwith ("Unimplemented " ^ string_of_exp orig_exp) + | _ -> fail ("Unimplemented " ^ string_of_exp orig_exp) and combine _ v1 v2 = match (v1, v2) with @@ -681,13 +705,23 @@ let rec eval_frame' = function let out' = lazy (Pretty_print_sail.to_string (Pretty_print_sail.doc_exp exp')) in Step (out', state, step exp', stack) | Yield (Call(id, vals, cont)), _ when string_of_id id = "break" -> - let arg = if List.length vals != 1 then tuple_value vals else List.hd vals in - let body = exp_of_fundef (Bindings.find id gstate.fundefs) arg in - Break (Step (lazy "", (initial_lstate, gstate), return body, (out, lstate, cont) :: stack)) + begin + let arg = if List.length vals != 1 then tuple_value vals else List.hd vals in + try + let body = exp_of_fundef (Bindings.find id gstate.fundefs) arg in + Break (Step (lazy "", (initial_lstate, gstate), return body, (out, lstate, cont) :: stack)) + with Not_found -> + Step (out, state, fail ("Fundef not found: " ^ string_of_id id), stack) + end | Yield (Call(id, vals, cont)), _ -> - let arg = if List.length vals != 1 then tuple_value vals else List.hd vals in - let body = exp_of_fundef (Bindings.find id gstate.fundefs) arg in - Step (lazy "", (initial_lstate, gstate), return body, (out, lstate, cont) :: stack) + begin + let arg = if List.length vals != 1 then tuple_value vals else List.hd vals in + try + let body = exp_of_fundef (Bindings.find id gstate.fundefs) arg in + Step (lazy "", (initial_lstate, gstate), return body, (out, lstate, cont) :: stack) + with Not_found -> + Step (out, state, fail ("Fundef not found: " ^ string_of_id id), stack) + end | Yield (Read_reg (name, cont)), _ -> begin -- cgit v1.2.3 From 05ee2df552204309defe9cb8044f13127d46c482 Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 24 Oct 2018 11:50:07 +0100 Subject: Interpreter: add handling of undefs and sizeofs, and initialize registers to undefined on startup --- src/interpreter.ml | 31 ++++++++++++++++++++++++++----- src/type_check.mli | 2 ++ 2 files changed, 28 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/interpreter.ml b/src/interpreter.ml index 3b050089..f7168132 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -282,6 +282,15 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = | E_block (exp :: exps) -> step exp >>= fun exp' -> wrap (E_block (exp' :: exps)) + | E_lit (L_aux (L_undef, _)) -> + begin + let env = Type_check.env_of_annot annot in + let typ = Type_check.typ_of_annot annot in + let undef_exp = Ast_util.undefined_of_typ false Parse_ast.Unknown (fun _ -> ()) typ in + let undef_exp = Type_check.check_exp env undef_exp typ in + return undef_exp + end + | E_lit lit -> begin try return (exp_of_value (value_of_lit lit)) @@ -577,7 +586,12 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = | E_for (id, exp_from, exp_to, exp_step, ord, body) -> step exp_step >>= fun exp_step' -> wrap (E_for (id, exp_from, exp_to, exp_step', ord, body)) - | E_sizeof _ | E_constraint _ -> assert false (* Must be re-written before interpreting *) + | E_sizeof nexp -> + begin + match Type_check.big_int_of_nexp nexp with + | Some n -> return (exp_of_value (V_int n)) + | None -> fail "Sizeof unevaluable nexp" + end | _ -> fail ("Unimplemented " ^ string_of_exp orig_exp) @@ -739,12 +753,11 @@ let rec eval_frame' = function let id = mk_id name in let gstate = gstate in if gstate.allow_registers then - (* TODO: check existence of register? would then need to initialise all to undefined below or similar *) - (* if Bindings.mem id gstate.registers then *) + if Bindings.mem id gstate.registers then let state' = (lstate, { gstate with registers = Bindings.add id v gstate.registers }) in eval_frame' (Step (out, state', cont (), stack)) - (* else - * eval_frame' (Step (out, state, fail ("Write of nonexistent register: " ^ name), stack)) *) + else + eval_frame' (Step (out, state, fail ("Write of nonexistent register: " ^ name), stack)) else eval_frame' (Step (out, state, fail ("Register write disallowed by allow_registers setting: " ^ name), stack)) end @@ -805,6 +818,14 @@ let initial_gstate primops ast = let rec initialize_registers gstate = let process_def = function + | DEF_reg_dec (DEC_aux (DEC_reg (typ, id), annot)) -> + begin + let env = Type_check.env_of_annot annot in + let typ = Type_check.Env.expand_synonyms env typ in + let exp = mk_exp (E_cast (typ, mk_exp (E_lit (mk_lit (L_undef))))) in + let exp = Type_check.check_exp env exp typ in + { gstate with registers = Bindings.add id (eval_exp (initial_lstate, gstate) exp) gstate.registers } + end | DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp), _)) -> { gstate with registers = Bindings.add id (eval_exp (initial_lstate, gstate) exp) gstate.registers } | DEF_fundef fdef -> diff --git a/src/type_check.mli b/src/type_check.mli index 4fe6711c..0e0137db 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -386,6 +386,8 @@ val propagate_exp_effect : tannot exp -> tannot exp val propagate_pexp_effect : tannot pexp -> tannot pexp * effect +val big_int_of_nexp : nexp -> Big_int.num option + (** {2 Checking full AST} *) (** Fully type-check an AST -- cgit v1.2.3 From 6305947a929778bb7781056124913c4c2ac23d5c Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 24 Oct 2018 12:31:08 +0100 Subject: Interpreter, RISC-V: move memory actions to parts of the interpreter response and refactor RISC-V model accordingly --- src/interpreter.ml | 188 ++++++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 156 insertions(+), 32 deletions(-) (limited to 'src') diff --git a/src/interpreter.ml b/src/interpreter.ml index f7168132..64ea9374 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -60,6 +60,7 @@ type gstate = primops : (value list -> value) StringMap.t; letbinds : (Type_check.tannot letbind) list; fundefs : (Type_check.tannot fundef) Bindings.t; + last_write_ea : (value * value * value) option; } type lstate = @@ -127,12 +128,11 @@ type 'a response = | Assertion_failed of string | Call of id * value list * (return_value -> 'a) | Fail of string - (* TODO *) - (* | Read_mem of Sail2_instr_kinds.read_kind * (\* address : *\) value * (\* length : *\) value * (value -> 'a) - * | Write_ea of Sail2_instr_kinds.write_kind * (\* address : *\) value * (\* length : *\) value * (unit -> 'a) - * | Excl_res of (bool -> 'a) - * | Write_memv of value * (bool -> 'a) - * | Barrier of Sail2_instr_kinds.barrier_kind * (unit -> 'a) *) + | Read_mem of (* read_kind : *) value * (* address : *) value * (* length : *) value * (value -> 'a) + | Write_ea of (* write_kind : *) value * (* address : *) value * (* length : *) value * (unit -> 'a) + | Excl_res of (bool -> 'a) + | Write_memv of value * (bool -> 'a) + | Barrier of (* barrier_kind : *) value * (unit -> 'a) | Read_reg of string * (value -> 'a) | Write_reg of string * value * (unit -> 'a) | Get_primop of string * ((value list -> value) -> 'a) @@ -150,12 +150,11 @@ let map_response f = function | Assertion_failed str -> Assertion_failed str | Call (id, vals, cont) -> Call (id, vals, fun v -> f (cont v)) | Fail s -> Fail s - (* TODO *) - (* | Read_mem (rk, addr, len, cont) -> Read_mem (rk, addr, len, fun v -> f (cont v)) - * | Write_ea (wk, addr, len, cont) -> Write_ea (wk, addr, len, fun () -> f (cont ())) - * | Excl_res cont -> Excl_res (fun b -> f (cont b)) - * | Write_memv (v, cont) -> Write_memv (v, fun b -> f (cont b)) - * | Barrier (bk, cont) -> Barrier (bk, fun () -> f (cont ())) *) + | Read_mem (rk, addr, len, cont) -> Read_mem (rk, addr, len, fun v -> f (cont v)) + | Write_ea (wk, addr, len, cont) -> Write_ea (wk, addr, len, fun () -> f (cont ())) + | Excl_res cont -> Excl_res (fun b -> f (cont b)) + | Write_memv (v, cont) -> Write_memv (v, fun b -> f (cont b)) + | Barrier (bk, cont) -> Barrier (bk, fun () -> f (cont ())) | Read_reg (name, cont) -> Read_reg (name, fun v -> f (cont v)) | Write_reg (name, v, cont) -> Write_reg (name, v, fun () -> f (cont ())) | Get_primop (name, cont) -> Get_primop (name, fun op -> f (cont op)) @@ -195,21 +194,21 @@ let throw v = Yield (Exception v) let call (f : id) (args : value list) : return_value monad = Yield (Call (f, args, fun v -> Pure v)) -(* TODO *) -(* let read_mem (rk, addr, len) : value monad = - * Yield (Read_mem (rk, addr, len, (fun v -> Pure v))) - * - * let write_ea (wk, addr, len) : unit monad = - * Yield (Write_ea (wk, addr, len, (fun () -> Pure ()))) - * - * let excl_res () : bool monad = - * Yield (Excl_res (fun b -> Pure b)) - * - * let write_memv v : bool monad = - * Yield (Write_memv (v, fun b -> Pure b)) - * - * let barrier bk : unit monad = - * Yield (Barrier (bk, fun () -> Pure ())) *) + +let read_mem rk addr len : value monad = + Yield (Read_mem (rk, addr, len, (fun v -> Pure v))) + +let write_ea wk addr len : unit monad = + Yield (Write_ea (wk, addr, len, (fun () -> Pure ()))) + +let excl_res () : bool monad = + Yield (Excl_res (fun b -> Pure b)) + +let write_memv v : bool monad = + Yield (Write_memv (v, fun b -> Pure b)) + +let barrier bk : unit monad = + Yield (Barrier (bk, fun () -> Pure ())) let read_reg name : value monad = Yield (Read_reg (name, fun v -> Pure v)) @@ -372,11 +371,47 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = | [] when is_interpreter_extern id (env_of_annot annot) -> begin let extern = get_interpreter_extern id (env_of_annot annot) in - if extern = "reg_deref" then - let regname = List.hd evaluated |> value_of_exp |> coerce_ref in - read_reg regname >>= fun v -> return (exp_of_value v) - else - get_primop extern >>= fun op -> return (exp_of_value (op (List.map value_of_exp evaluated))) + match extern with + | "reg_deref" -> + let regname = List.hd evaluated |> value_of_exp |> coerce_ref in + read_reg regname >>= fun v -> return (exp_of_value v) + | "read_mem" -> + begin match evaluated with + | [rk; addr; len] -> + read_mem (value_of_exp rk) (value_of_exp addr) (value_of_exp len) >>= fun v -> return (exp_of_value v) + | _ -> + fail "Wrong number of parameters to read_mem intrinsic" + end + | "write_ea" -> + begin match evaluated with + | [wk; addr; len] -> + write_ea (value_of_exp wk) (value_of_exp addr) (value_of_exp len) >> wrap unit_exp + | _ -> + fail "Wrong number of parameters to write_ea intrinsic" + end + | "excl_res" -> + begin match evaluated with + | [] -> + excl_res () >>= fun b -> return (exp_of_value (V_bool b)) + | _ -> + fail "Wrong number of parameters to excl_res intrinsic" + end + | "write_memv" -> + begin match evaluated with + | [v] -> + write_memv (value_of_exp v) >>= fun b -> return (exp_of_value (V_bool b)) + | _ -> + fail "Wrong number of parameters to write_memv intrinsic" + end + | "barrier" -> + begin match evaluated with + | [bk] -> + barrier (value_of_exp bk) >> wrap unit_exp + | _ -> + fail "Wrong number of parameters to barrier intrinsic" + end + | _ -> + get_primop extern >>= fun op -> return (exp_of_value (op (List.map value_of_exp evaluated))) end | [] -> call id (List.map value_of_exp evaluated) >>= @@ -694,6 +729,61 @@ let rec ast_letbinds (Defs defs) = | DEF_val lb :: defs -> lb :: ast_letbinds (Defs defs) | _ :: defs -> ast_letbinds (Defs defs) +let rk_of_string = function + | "Read_plain" -> Sail2_instr_kinds.Read_plain + | "Read_reserve" -> Sail2_instr_kinds.Read_reserve + | "Read_acquire" -> Sail2_instr_kinds.Read_acquire + | "Read_exclusive" -> Sail2_instr_kinds.Read_exclusive + | "Read_exclusive_acquire" -> Sail2_instr_kinds.Read_exclusive_acquire + | "Read_stream" -> Sail2_instr_kinds.Read_stream + | "Read_RISCV_acquire" -> Sail2_instr_kinds.Read_RISCV_acquire + | "Read_RISCV_strong_acquire" -> Sail2_instr_kinds.Read_RISCV_strong_acquire + | "Read_RISCV_reserved" -> Sail2_instr_kinds.Read_RISCV_reserved + | "Read_RISCV_reserved_acquire" -> Sail2_instr_kinds.Read_RISCV_reserved_acquire + | "Read_RISCV_reserved_strong_acquire" -> Sail2_instr_kinds.Read_RISCV_reserved_strong_acquire + | "Read_X86_locked" -> Sail2_instr_kinds.Read_X86_locked + | s -> failwith ("Unknown read kind: " ^ s) + +let wk_of_string = function + | "Write_plain" -> Sail2_instr_kinds.Write_plain + | "Write_conditional" -> Sail2_instr_kinds.Write_conditional + | "Write_release" -> Sail2_instr_kinds.Write_release + | "Write_exclusive" -> Sail2_instr_kinds.Write_exclusive + | "Write_exclusive_release" -> Sail2_instr_kinds.Write_exclusive_release + | "Write_RISCV_release" -> Sail2_instr_kinds.Write_RISCV_release + | "Write_RISCV_strong_release" -> Sail2_instr_kinds.Write_RISCV_strong_release + | "Write_RISCV_conditional" -> Sail2_instr_kinds.Write_RISCV_conditional + | "Write_RISCV_conditional_release" -> Sail2_instr_kinds.Write_RISCV_conditional_release + | "Write_RISCV_conditional_strong_release" -> Sail2_instr_kinds.Write_RISCV_conditional_strong_release + | "Write_X86_locked" -> Sail2_instr_kinds.Write_X86_locked + | s -> failwith ("Unknown write kind: " ^ s) + +let bk_of_string = function + | "Barrier_Sync" -> Sail2_instr_kinds.Barrier_Sync + | "Barrier_LwSync" -> Sail2_instr_kinds.Barrier_LwSync + | "Barrier_Eieio" -> Sail2_instr_kinds.Barrier_Eieio + | "Barrier_Isync" -> Sail2_instr_kinds.Barrier_Isync + | "Barrier_DMB" -> Sail2_instr_kinds.Barrier_DMB + | "Barrier_DMB_ST" -> Sail2_instr_kinds.Barrier_DMB_ST + | "Barrier_DMB_LD" -> Sail2_instr_kinds.Barrier_DMB_LD + | "Barrier_DSB" -> Sail2_instr_kinds.Barrier_DSB + | "Barrier_DSB_ST" -> Sail2_instr_kinds.Barrier_DSB_ST + | "Barrier_DSB_LD" -> Sail2_instr_kinds.Barrier_DSB_LD + | "Barrier_ISB" -> Sail2_instr_kinds.Barrier_ISB + | "Barrier_MIPS_SYNC" -> Sail2_instr_kinds.Barrier_MIPS_SYNC + | "Barrier_RISCV_rw_rw" -> Sail2_instr_kinds.Barrier_RISCV_rw_rw + | "Barrier_RISCV_r_rw" -> Sail2_instr_kinds.Barrier_RISCV_r_rw + | "Barrier_RISCV_r_r" -> Sail2_instr_kinds.Barrier_RISCV_r_r + | "Barrier_RISCV_rw_w" -> Sail2_instr_kinds.Barrier_RISCV_rw_w + | "Barrier_RISCV_w_w" -> Sail2_instr_kinds.Barrier_RISCV_w_w + | "Barrier_RISCV_w_rw" -> Sail2_instr_kinds.Barrier_RISCV_w_rw + | "Barrier_RISCV_rw_r" -> Sail2_instr_kinds.Barrier_RISCV_rw_r + | "Barrier_RISCV_r_w" -> Sail2_instr_kinds.Barrier_RISCV_r_w + | "Barrier_RISCV_w_r" -> Sail2_instr_kinds.Barrier_RISCV_w_r + | "Barrier_RISCV_i" -> Sail2_instr_kinds.Barrier_RISCV_i + | "Barrier_x86_MFENCE" -> Sail2_instr_kinds.Barrier_x86_MFENCE + | s -> failwith ("Unknown barrier kind: " ^ s) + let initial_lstate = { locals = Bindings.empty } @@ -781,6 +871,39 @@ let rec eval_frame' = function eval_frame' (Step (out, state', cont (), stack)) | Yield (Get_global_letbinds cont), _ -> eval_frame' (Step (out, state, cont gstate.letbinds, stack)) + | Yield (Read_mem (rk, addr, len, cont)), _ -> + (* all read-kinds treated the same in single-threaded interpreter *) + let addr' = coerce_bv addr in + let len' = coerce_int len in + let result = mk_vector (Sail_lib.read_ram (List.length addr', len', [], addr')) in + eval_frame' (Step (out, state, cont result, stack)) + | Yield (Write_ea (wk, addr, len, cont)), _ -> + (* just store the values for the next Write_memv *) + let state' = (lstate, { gstate with last_write_ea = Some (wk, addr, len) }) in + eval_frame' (Step (out, state', cont (), stack)) + | Yield (Excl_res cont), _ -> + (* always succeeds in single-threaded interpreter *) + eval_frame' (Step (out, state, cont true, stack)) + | Yield (Write_memv (v, cont)), _ -> + begin + match gstate.last_write_ea with + | Some (wk, addr, len) -> + let state' = (lstate, { gstate with last_write_ea = None }) in + (* all write-kinds treated the same in single-threaded interpreter *) + let addr' = coerce_bv addr in + let len' = coerce_int len in + let v' = coerce_bv v in + if Big_int.mul len' (Big_int.of_int 8) = Big_int.of_int (List.length v') then + let b = Sail_lib.write_ram (List.length addr', len', [], addr', v') in + eval_frame' (Step (out, state', cont b, stack)) + else + eval_frame' (Step (out, state, fail "Write_memv with length mismatch to preceding Write_ea", stack)) + | None -> + eval_frame' (Step (out, state, fail "Write_memv without preceding Write_ea", stack)) + end + | Yield (Barrier (bk, cont)), _ -> + (* no-op in single-threaded interpreter *) + eval_frame' (Step (out, state, cont (), stack)) | Yield (Early_return v), [] -> Done (state, v) | Yield (Early_return v), (head :: stack') -> @@ -814,6 +937,7 @@ let initial_gstate primops ast = primops = primops; letbinds = ast_letbinds ast; fundefs = Bindings.empty; + last_write_ea = None; } let rec initialize_registers gstate = -- cgit v1.2.3 From d47313c00011be39ed1c2e411d401bb759ed65bf Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 1 Nov 2018 10:39:56 +0000 Subject: Interpreter: last couple of builtins to get RISC-V working --- src/value.ml | 10 ++++++++++ 1 file changed, 10 insertions(+) (limited to 'src') diff --git a/src/value.ml b/src/value.ml index 90f6d947..8e920377 100644 --- a/src/value.ml +++ b/src/value.ml @@ -317,6 +317,14 @@ let value_negate = function | [v1] -> V_int (Sail_lib.negate (coerce_int v1)) | _ -> failwith "value negate" +let value_pow2 = function + | [v1] -> V_int (Sail_lib.pow2 (coerce_int v1)) + | _ -> failwith "value pow2" + +let value_int_power = function + | [v1; v2] -> V_int (Sail_lib.int_power (coerce_int v1, coerce_int v2)) + | _ -> failwith "value int_power" + let value_mult = function | [v1; v2] -> V_int (Sail_lib.mult (coerce_int v1, coerce_int v2)) | _ -> failwith "value mult" @@ -615,6 +623,8 @@ let primops = ("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); -- cgit v1.2.3 From 9d2c973d97f10060344f623d8392f56a437b2d04 Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 14 Nov 2018 11:10:30 +0000 Subject: interpreter: abstract effect requests into an Effect_request arm of frame type --- src/interpreter.ml | 135 +++++++++++++++++++++++++++++++++-------------------- src/isail.ml | 25 ++++++++++ 2 files changed, 109 insertions(+), 51 deletions(-) (limited to 'src') diff --git a/src/interpreter.ml b/src/interpreter.ml index 64ea9374..b2b91583 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -122,6 +122,7 @@ type return_value = | Return_ok of value | Return_exception of value +(* when changing effect arms remember to also update effect_request type below *) type 'a response = | Early_return of value | Exception of value @@ -795,10 +796,22 @@ type frame = | Done of state * value | Step of string Lazy.t * state * (Type_check.tannot exp) monad * (string Lazy.t * lstate * (return_value -> (Type_check.tannot exp) monad)) list | Break of frame + | Effect_request of state * effect_request + +(* when changing effect_request remember to also update response type above *) +and effect_request = + | Read_mem of (* read_kind : *) value * (* address : *) value * (* length : *) value * (value -> state -> frame) + | Write_ea of (* write_kind : *) value * (* address : *) value * (* length : *) value * (unit -> state -> frame) + | Excl_res of (bool -> state -> frame) + | Write_memv of value * (bool -> state -> frame) + | Barrier of (* barrier_kind : *) value * (unit -> state -> frame) + | Read_reg of string * (value -> state -> frame) + | Write_reg of string * value * (unit -> state -> frame) let rec eval_frame' = function | Done (state, v) -> Done (state, v) | Break frame -> Break frame + | Effect_request (state, eff) -> Effect_request (state, eff) | Step (out, state, m, stack) -> let lstate, gstate = state in match (m, stack) with @@ -828,29 +841,9 @@ let rec eval_frame' = function end | Yield (Read_reg (name, cont)), _ -> - begin - let gstate = gstate in - if gstate.allow_registers then - try - eval_frame' (Step (out, state, cont (Bindings.find (mk_id name) gstate.registers), stack)) - with Not_found -> - eval_frame' (Step (out, state, fail ("Read of nonexistent register: " ^ name), stack)) - else - eval_frame' (Step (out, state, fail ("Register read disallowed by allow_registers setting: " ^ name), stack)) - end + Effect_request (state, Read_reg (name, fun v state' -> eval_frame' (Step (out, state', cont v, stack)))) | Yield (Write_reg (name, v, cont)), _ -> - begin - let id = mk_id name in - let gstate = gstate in - if gstate.allow_registers then - if Bindings.mem id gstate.registers then - let state' = (lstate, { gstate with registers = Bindings.add id v gstate.registers }) in - eval_frame' (Step (out, state', cont (), stack)) - else - eval_frame' (Step (out, state, fail ("Write of nonexistent register: " ^ name), stack)) - else - eval_frame' (Step (out, state, fail ("Register write disallowed by allow_registers setting: " ^ name), stack)) - end + Effect_request (state, Write_reg (name, v, fun () state' -> eval_frame' (Step (out, state', cont (), stack)))) | Yield (Get_primop (name, cont)), _ -> begin try @@ -872,39 +865,15 @@ let rec eval_frame' = function | Yield (Get_global_letbinds cont), _ -> eval_frame' (Step (out, state, cont gstate.letbinds, stack)) | Yield (Read_mem (rk, addr, len, cont)), _ -> - (* all read-kinds treated the same in single-threaded interpreter *) - let addr' = coerce_bv addr in - let len' = coerce_int len in - let result = mk_vector (Sail_lib.read_ram (List.length addr', len', [], addr')) in - eval_frame' (Step (out, state, cont result, stack)) + Effect_request (state, Read_mem (rk, addr, len, fun result state' -> eval_frame' (Step (out, state', cont result, stack)))) | Yield (Write_ea (wk, addr, len, cont)), _ -> - (* just store the values for the next Write_memv *) - let state' = (lstate, { gstate with last_write_ea = Some (wk, addr, len) }) in - eval_frame' (Step (out, state', cont (), stack)) + Effect_request (state, Write_ea (wk, addr, len, fun () state' -> eval_frame' (Step (out, state', cont (), stack)))) | Yield (Excl_res cont), _ -> - (* always succeeds in single-threaded interpreter *) - eval_frame' (Step (out, state, cont true, stack)) + Effect_request (state, Excl_res (fun b state' -> eval_frame' (Step (out, state', cont b, stack)))) | Yield (Write_memv (v, cont)), _ -> - begin - match gstate.last_write_ea with - | Some (wk, addr, len) -> - let state' = (lstate, { gstate with last_write_ea = None }) in - (* all write-kinds treated the same in single-threaded interpreter *) - let addr' = coerce_bv addr in - let len' = coerce_int len in - let v' = coerce_bv v in - if Big_int.mul len' (Big_int.of_int 8) = Big_int.of_int (List.length v') then - let b = Sail_lib.write_ram (List.length addr', len', [], addr', v') in - eval_frame' (Step (out, state', cont b, stack)) - else - eval_frame' (Step (out, state, fail "Write_memv with length mismatch to preceding Write_ea", stack)) - | None -> - eval_frame' (Step (out, state, fail "Write_memv without preceding Write_ea", stack)) - end + Effect_request (state, Write_memv (v, fun b state' -> eval_frame' (Step (out, state', cont b, stack)))) | Yield (Barrier (bk, cont)), _ -> - (* no-op in single-threaded interpreter *) - eval_frame' (Step (out, state, cont (), stack)) - + Effect_request (state, Barrier (bk, fun () state' -> eval_frame' (Step (out, state', cont (), stack)))) | Yield (Early_return v), [] -> Done (state, v) | Yield (Early_return v), (head :: stack') -> Step (stack_string head, (stack_state head, gstate), stack_cont head (Return_ok v), stack') @@ -920,6 +889,68 @@ let eval_frame frame = | Type_check.Type_error (l, err) -> raise (Reporting_basic.err_typ l (Type_error.string_of_type_error err)) +let default_effect_interp state eff = + let lstate, gstate = state in + match eff with + | Read_mem (rk, addr, len, cont) -> + (* all read-kinds treated the same in single-threaded interpreter *) + let addr' = coerce_bv addr in + let len' = coerce_int len in + let result = mk_vector (Sail_lib.read_ram (List.length addr', len', [], addr')) in + cont result state + | Write_ea (wk, addr, len, cont) -> + (* just store the values for the next Write_memv *) + let state' = (lstate, { gstate with last_write_ea = Some (wk, addr, len) }) in + cont () state' + | Excl_res cont -> + (* always succeeds in single-threaded interpreter *) + cont true state + | Write_memv (v, cont) -> + begin + match gstate.last_write_ea with + | Some (wk, addr, len) -> + let state' = (lstate, { gstate with last_write_ea = None }) in + (* all write-kinds treated the same in single-threaded interpreter *) + let addr' = coerce_bv addr in + let len' = coerce_int len in + let v' = coerce_bv v in + if Big_int.mul len' (Big_int.of_int 8) = Big_int.of_int (List.length v') then + let b = Sail_lib.write_ram (List.length addr', len', [], addr', v') in + cont b state + else + failwith "Write_memv with length mismatch to preceding Write_ea" + | None -> + failwith "Write_memv without preceding Write_ea" + end + | Barrier (bk, cont) -> + (* no-op in single-threaded interpreter *) + cont () state + | Read_reg (name, cont) -> + begin + if gstate.allow_registers then + try + cont (Bindings.find (mk_id name) gstate.registers) state + with Not_found -> + failwith ("Read of nonexistent register: " ^ name) + else + failwith ("Register read disallowed by allow_registers setting: " ^ name) + end + | Write_reg (name, v, cont) -> + begin + let id = mk_id name in + if gstate.allow_registers then + 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) + else + failwith ("Register write disallowed by allow_registers setting: " ^ name) + end + + + + let rec run_frame frame = match frame with | Done (state, v) -> v @@ -927,6 +958,8 @@ let rec run_frame frame = run_frame (eval_frame frame) | Break frame -> run_frame (eval_frame frame) + | Effect_request (state, eff) -> + run_frame (default_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 4e237943..bdf4777d 100644 --- a/src/isail.ml +++ b/src/isail.ml @@ -137,6 +137,14 @@ let rec run () = | Break frame -> print_endline "Breakpoint"; current_mode := Evaluation frame + | Effect_request (state, eff) -> + begin + try + current_mode := Evaluation (Interpreter.default_effect_interp state eff) + with + | Failure str -> print_endline str; current_mode := Normal + end; + run () end let rec run_steps n = @@ -162,6 +170,14 @@ let rec run_steps n = | Break frame -> print_endline "Breakpoint"; current_mode := Evaluation frame + | Effect_request (state, eff) -> + begin + try + current_mode := Evaluation (Interpreter.default_effect_interp state eff) + with + | Failure str -> print_endline str; current_mode := Normal + end; + run_steps (n - 1) end let help = function @@ -395,6 +411,15 @@ let handle_input' input = | Break frame -> print_endline "Breakpoint"; current_mode := Evaluation frame + | Effect_request (state, eff) -> + begin + try + interactive_state := state; + current_mode := Evaluation (Interpreter.default_effect_interp state eff); + print_program () + with + | Failure str -> print_endline str; current_mode := Normal + end end end -- cgit v1.2.3 From 13169ab85604d926e5dae44202622ec445697793 Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 27 Dec 2018 12:14:32 +0000 Subject: pass typechecking environment around interpreter and rewriters --- src/constant_fold.ml | 10 +++++----- src/interpreter.ml | 6 ++++-- src/isail.ml | 12 ++++++------ src/process_file.ml | 8 ++++---- src/process_file.mli | 16 ++++++++-------- src/sail.ml | 14 +++++++------- 6 files changed, 34 insertions(+), 32 deletions(-) (limited to 'src') diff --git a/src/constant_fold.ml b/src/constant_fold.ml index 407bd69a..d5fffbbe 100644 --- a/src/constant_fold.ml +++ b/src/constant_fold.ml @@ -141,13 +141,13 @@ let rec run frame = - Throws an exception that isn't caught. *) -let rec rewrite_constant_function_calls' ast = +let rec rewrite_constant_function_calls' env ast = let rewrite_count = ref 0 in let ok () = incr rewrite_count in let not_ok () = decr rewrite_count in let lstate, gstate = - Interpreter.initial_state ast safe_primops + Interpreter.initial_state ast env safe_primops in let gstate = { gstate with Interpreter.allow_registers = false } in @@ -202,11 +202,11 @@ let rec rewrite_constant_function_calls' ast = 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' ast + then rewrite_constant_function_calls' env ast else ast -let rewrite_constant_function_calls ast = +let rewrite_constant_function_calls env ast = if !optimize_constant_fold then - rewrite_constant_function_calls' ast + rewrite_constant_function_calls' env ast else ast diff --git a/src/interpreter.ml b/src/interpreter.ml index b2b91583..167c66f5 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -61,6 +61,7 @@ type gstate = letbinds : (Type_check.tannot letbind) list; fundefs : (Type_check.tannot fundef) Bindings.t; last_write_ea : (value * value * value) option; + typecheck_env : Type_check.Env.t; } type lstate = @@ -964,13 +965,14 @@ let rec run_frame frame = let eval_exp state exp = run_frame (Step (lazy "", state, return exp, [])) -let initial_gstate primops ast = +let initial_gstate primops ast env = { registers = Bindings.empty; allow_registers = true; primops = primops; letbinds = ast_letbinds ast; fundefs = Bindings.empty; last_write_ea = None; + typecheck_env = env; } let rec initialize_registers gstate = @@ -994,4 +996,4 @@ let rec initialize_registers gstate = initialize_registers (process_def def) (Defs defs) | Defs [] -> gstate -let initial_state ast primops = initial_lstate, initialize_registers (initial_gstate primops ast) ast +let initial_state ast env primops = initial_lstate, initialize_registers (initial_gstate primops ast env) ast diff --git a/src/isail.ml b/src/isail.ml index bdf4777d..863c4b1c 100644 --- a/src/isail.ml +++ b/src/isail.ml @@ -103,7 +103,7 @@ let sail_logo = let vs_ids = ref (Initial_check.val_spec_ids !interactive_ast) -let interactive_state = ref (initial_state !interactive_ast Value.primops) +let interactive_state = ref (initial_state !interactive_ast !interactive_env Value.primops) let print_program () = match !current_mode with @@ -301,13 +301,13 @@ let handle_input' input = let ast, env = Specialize.specialize !interactive_ast !interactive_env in interactive_ast := ast; interactive_env := env; - interactive_state := initial_state !interactive_ast Value.primops + interactive_state := initial_state !interactive_ast !interactive_env Value.primops | ":pretty" -> print_endline (Pretty_print_sail.to_string (Latex.latex_defs "sail_latex" !interactive_ast)) | ":bytecode" -> let open PPrint in let open C_backend in - let ast = Process_file.rewrite_ast_c !interactive_ast in + let ast = Process_file.rewrite_ast_c !interactive_env !interactive_ast in let ast, env = Specialize.specialize ast !interactive_env in let ctx = initial_ctx env in let byte_ast = bytecode_ast ctx (List.map flatten_instrs) ast in @@ -351,15 +351,15 @@ let handle_input' input = | ":l" | ":load" -> let files = Util.split_on_char ' ' arg in let (_, ast, env) = load_files !interactive_env files in - let ast = Process_file.rewrite_ast_interpreter ast in + let ast = Process_file.rewrite_ast_interpreter env ast in interactive_ast := append_ast !interactive_ast ast; - interactive_state := initial_state !interactive_ast Value.primops; + interactive_state := initial_state !interactive_ast !interactive_env Value.primops; interactive_env := env; vs_ids := Initial_check.val_spec_ids !interactive_ast | ":u" | ":unload" -> interactive_ast := Ast.Defs []; interactive_env := Type_check.initial_env; - interactive_state := initial_state !interactive_ast Value.primops; + interactive_state := initial_state !interactive_ast !interactive_env Value.primops; vs_ids := Initial_check.val_spec_ids !interactive_ast; (* See initial_check.mli for an explanation of why we need this. *) Initial_check.have_undefined_builtins := false diff --git a/src/process_file.ml b/src/process_file.ml index 2dfd9571..344c7921 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -375,7 +375,7 @@ let rewrite_step defs (name,rewriter) = | _ -> () in defs -let rewrite rewriters defs = +let rewrite rewriters env defs = try List.fold_left rewrite_step defs rewriters with | Type_check.Type_error (l, err) -> raise (Reporting_basic.err_typ l (Type_error.string_of_type_error err)) @@ -385,10 +385,10 @@ let rewrite_undefined bitvectors = rewrite [("undefined", fun x -> Rewrites.rewr let rewrite_ast_lem = rewrite Rewrites.rewrite_defs_lem let rewrite_ast_coq = rewrite Rewrites.rewrite_defs_coq let rewrite_ast_ocaml = rewrite Rewrites.rewrite_defs_ocaml -let rewrite_ast_c ast = +let rewrite_ast_c env ast = ast - |> rewrite Rewrites.rewrite_defs_c - |> rewrite [("constant_fold", Constant_fold.rewrite_constant_function_calls)] + |> rewrite Rewrites.rewrite_defs_c env + |> rewrite [("constant_fold", Constant_fold.rewrite_constant_function_calls env)] env let rewrite_ast_interpreter = rewrite Rewrites.rewrite_defs_interpreter let rewrite_ast_check = rewrite Rewrites.rewrite_defs_check diff --git a/src/process_file.mli b/src/process_file.mli index 1ebb3014..7862c121 100644 --- a/src/process_file.mli +++ b/src/process_file.mli @@ -55,14 +55,14 @@ val parse_file : ?loc:Parse_ast.l -> string -> Parse_ast.defs val convert_ast : Ast.order -> Parse_ast.defs -> unit Ast.defs val preprocess_ast : (Arg.key * Arg.spec * Arg.doc) list -> Parse_ast.defs -> Parse_ast.defs val check_ast: Type_check.Env.t -> unit Ast.defs -> Type_check.tannot Ast.defs * Type_check.Env.t -val rewrite_ast: Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs -val rewrite_undefined: bool -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs -val rewrite_ast_lem : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs -val rewrite_ast_coq : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs -val rewrite_ast_ocaml : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs -val rewrite_ast_c : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs -val rewrite_ast_interpreter : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs -val rewrite_ast_check : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs +val rewrite_ast: Type_check.Env.t -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs +val rewrite_undefined: bool -> Type_check.Env.t -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs +val rewrite_ast_lem : Type_check.Env.t -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs +val rewrite_ast_coq : Type_check.Env.t -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs +val rewrite_ast_ocaml : Type_check.Env.t -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs +val rewrite_ast_c : Type_check.Env.t -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs +val rewrite_ast_interpreter : Type_check.Env.t -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs +val rewrite_ast_check : Type_check.Env.t -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs 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 diff --git a/src/sail.ml b/src/sail.ml index c1c965fe..2748cb81 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -271,7 +271,7 @@ let load_files type_envs files = let (ast, type_envs) = check_ast type_envs ast in - let ast = rewrite_ast ast in + let ast = rewrite_ast type_envs ast in let out_name = match !opt_file_out with | None when parsed = [] -> "out.sail" @@ -316,11 +316,11 @@ let main() = begin (if !(opt_interactive) then - (interactive_ast := Process_file.rewrite_ast_interpreter ast; interactive_env := type_envs) + (interactive_ast := Process_file.rewrite_ast_interpreter type_envs ast; interactive_env := type_envs) else ()); (if !(opt_sanity) then - let _ = rewrite_ast_check ast in + let _ = rewrite_ast_check type_envs ast in () else ()); (if !(opt_print_verbose) @@ -328,13 +328,13 @@ let main() = else ()); (if !(opt_print_ocaml) then - let ast_ocaml = rewrite_ast_ocaml ast in + let ast_ocaml = rewrite_ast_ocaml type_envs ast in let out = match !opt_file_out with None -> "out" | Some s -> s in Ocaml_backend.ocaml_compile out ast_ocaml ocaml_generator_info else ()); (if !(opt_print_c) then - let ast_c = rewrite_ast_c ast in + let ast_c = rewrite_ast_c type_envs ast in let ast_c, type_envs = Specialize.specialize ast_c type_envs in let ast_c = Spec_analysis.top_sort_defs ast_c in Util.opt_warnings := true; @@ -344,13 +344,13 @@ let main() = then let mwords = !Pretty_print_lem.opt_mwords in let type_envs, ast_lem = State.add_regstate_defs mwords type_envs ast in - let ast_lem = rewrite_ast_lem ast_lem in + let ast_lem = rewrite_ast_lem type_envs ast_lem in output "" (Lem_out (!opt_libs_lem)) [out_name,ast_lem] else ()); (if !(opt_print_coq) then let type_envs, ast_coq = State.add_regstate_defs true type_envs ast in - let ast_coq = rewrite_ast_coq ast_coq in + let ast_coq = rewrite_ast_coq type_envs ast_coq in output "" (Coq_out (!opt_libs_coq)) [out_name,ast_coq] else ()); (if !(opt_print_latex) -- cgit v1.2.3 From fbcc27ca1bd3801beac0338e657b933d6a9c8f95 Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 27 Dec 2018 12:19:44 +0000 Subject: refactor val-spec AST to store externs as an assoc-list rather than a function (preparing for marshalling) --- src/ast_util.ml | 10 ++++++++++ src/ast_util.mli | 3 +++ src/initial_check.ml | 12 ++++++------ src/ocaml_backend.ml | 4 ++-- src/parse_ast.ml | 2 +- src/parser.mly | 22 +++++++++++----------- src/pretty_print_coq.ml | 4 ++-- src/pretty_print_lem.ml | 2 +- src/pretty_print_sail.ml | 4 +--- src/rewrites.ml | 16 ++++++++-------- src/type_check.ml | 22 +++++++++++----------- 11 files changed, 56 insertions(+), 45 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index 9966742e..3d13c5c3 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -1488,3 +1488,13 @@ and locate_fexps : 'a. l -> 'a fexps -> 'a fexps = fun l (FES_aux (FES_Fexps (fe and locate_fexp : 'a. l -> 'a fexp -> 'a fexp = fun l (FE_aux (FE_Fexp (id, exp), (_, annot))) -> FE_aux (FE_Fexp (locate_id l id, locate l exp), (l, annot)) + + +let extern_assoc backend exts = + try + try + Some (List.assoc backend exts) + with Not_found -> + Some (List.assoc "_" exts) + with Not_found -> + None diff --git a/src/ast_util.mli b/src/ast_util.mli index ea287190..54f18ae8 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -366,3 +366,6 @@ val locate_pat : l -> 'a pat -> 'a pat val locate_lexp : l -> 'a lexp -> 'a lexp val locate_typ : l -> typ -> typ + + +val extern_assoc : string -> (string * string) list -> string option diff --git a/src/initial_check.ml b/src/initial_check.ml index 36513ba1..36c60f2e 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -1078,8 +1078,8 @@ let typschm_of_string order str = let (typschm, _, _) = to_ast_typschm initial_kind_env order typschm in typschm -let extern_of_string order id str = mk_val_spec (VS_val_spec (typschm_of_string order str, id, (fun _ -> Some (string_of_id id)), false)) -let val_spec_of_string order id str = mk_val_spec (VS_val_spec (typschm_of_string order str, id, (fun _ -> None), false)) +let extern_of_string order id str = mk_val_spec (VS_val_spec (typschm_of_string order str, id, [("_", string_of_id id)], false)) +let val_spec_of_string order id str = mk_val_spec (VS_val_spec (typschm_of_string order str, id, [], false)) let val_spec_ids (Defs defs) = let val_spec_id (VS_aux (vs_aux, _)) = @@ -1154,7 +1154,7 @@ let generate_undefineds vs_ids (Defs defs) = let undefined_td = function | TD_enum (id, _, ids, _) when not (IdSet.mem (prepend_id "undefined_" id) vs_ids) -> let typschm = typschm_of_string dec_ord ("unit -> " ^ string_of_id id ^ " effect {undef}") in - [mk_val_spec (VS_val_spec (typschm, prepend_id "undefined_" id, (fun _ -> None), false)); + [mk_val_spec (VS_val_spec (typschm, prepend_id "undefined_" id, [], false)); mk_fundef [mk_funcl (prepend_id "undefined_" id) (mk_pat (P_lit (mk_lit L_unit))) (if !opt_fast_undefined && List.length ids > 0 then @@ -1164,7 +1164,7 @@ let generate_undefineds vs_ids (Defs defs) = [mk_exp (E_list (List.map (fun id -> mk_exp (E_id id)) ids))])))]] | TD_record (id, _, typq, fields, _) when not (IdSet.mem (prepend_id "undefined_" id) vs_ids) -> let pat = p_tup (quant_items typq |> List.map quant_item_param |> List.concat |> List.map (fun id -> mk_pat (P_id id))) in - [mk_val_spec (VS_val_spec (undefined_typschm id typq, prepend_id "undefined_" id, (fun _ -> None), false)); + [mk_val_spec (VS_val_spec (undefined_typschm id typq, prepend_id "undefined_" id, [], false)); mk_fundef [mk_funcl (prepend_id "undefined_" id) pat (mk_exp (E_record (mk_fexps (List.map (fun (_, id) -> mk_fexp id (mk_lit_exp L_undef)) fields))))]] @@ -1212,7 +1212,7 @@ let generate_undefineds vs_ids (Defs defs) = (mk_exp (E_app (mk_id "internal_pick", [mk_exp (E_list (List.map (make_constr typ_to_var) constr_args))]))) letbinds in - [mk_val_spec (VS_val_spec (undefined_typschm id typq, prepend_id "undefined_" id, (fun _ -> None), false)); + [mk_val_spec (VS_val_spec (undefined_typschm id typq, prepend_id "undefined_" id, [], false)); mk_fundef [mk_funcl (prepend_id "undefined_" id) pat body]] @@ -1248,7 +1248,7 @@ let generate_enum_functions vs_ids (Defs defs) = let rec gen_enums = function | DEF_type (TD_aux (TD_enum (id, _, elems, _), _)) as enum :: defs -> let enum_val_spec name quants typ = - mk_val_spec (VS_val_spec (mk_typschm (mk_typquant quants) typ, name, (fun _ -> None), !opt_enum_casts)) + mk_val_spec (VS_val_spec (mk_typschm (mk_typquant quants) typ, name, [], !opt_enum_casts)) in let range_constraint kid = nc_and (nc_lteq (nint 0) (nvar kid)) (nc_lteq (nvar kid) (nint (List.length elems - 1))) in diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index 4828398f..2a1fae15 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -615,8 +615,8 @@ let ocaml_typedef ctx (TD_aux (td_aux, _)) = | _ -> failwith "Unsupported typedef" let get_externs (Defs defs) = - let extern_id (VS_aux (VS_val_spec (typschm, id, ext, _), _)) = - match ext "ocaml" with + let extern_id (VS_aux (VS_val_spec (typschm, id, exts, _), _)) = + match Ast_util.extern_assoc "ocaml" exts with | None -> [] | Some ext -> [(id, mk_id ext)] in diff --git a/src/parse_ast.ml b/src/parse_ast.ml index 3317c196..db8f9939 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -488,7 +488,7 @@ type_def_aux = (* Type definition body *) type val_spec_aux = (* Value type specification *) - VS_val_spec of typschm * id * (string -> string option) * bool + VS_val_spec of typschm * id * (string * string) list * bool type diff --git a/src/parser.mly b/src/parser.mly index 070dee50..b2df5176 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -1316,31 +1316,31 @@ let_def: externs: | id Colon String - { ([(string_of_id $1, $3)], None) } + { [(string_of_id $1, $3)] } | Under Colon String - { ([], Some $3) } + { [("_", $3)] } | id Colon String Comma externs - { cons_fst (string_of_id $1, $3) $5 } + { (string_of_id $1, $3) :: $5 } val_spec_def: | Doc val_spec_def { doc_vs $1 $2 } | Val id Colon typschm - { mk_vs (VS_val_spec ($4, $2, (fun _ -> None), false)) $startpos $endpos } + { mk_vs (VS_val_spec ($4, $2, [], false)) $startpos $endpos } | Val Cast id Colon typschm - { mk_vs (VS_val_spec ($5, $3, (fun _ -> None), true)) $startpos $endpos } + { mk_vs (VS_val_spec ($5, $3, [], true)) $startpos $endpos } | Val id Eq String Colon typschm - { mk_vs (VS_val_spec ($6, $2, (fun _ -> Some $4), false)) $startpos $endpos } + { mk_vs (VS_val_spec ($6, $2, [], false)) $startpos $endpos } | Val Cast id Eq String Colon typschm - { mk_vs (VS_val_spec ($7, $3, (fun _ -> Some $5), true)) $startpos $endpos } + { mk_vs (VS_val_spec ($7, $3, [("_", $5)], true)) $startpos $endpos } | Val String Colon typschm - { mk_vs (VS_val_spec ($4, mk_id (Id $2) $startpos($2) $endpos($2), (fun _ -> Some $2), false)) $startpos $endpos } + { mk_vs (VS_val_spec ($4, mk_id (Id $2) $startpos($2) $endpos($2), [("_", $2)], false)) $startpos $endpos } | Val Cast String Colon typschm - { mk_vs (VS_val_spec ($5, mk_id (Id $3) $startpos($3) $endpos($3), (fun _ -> Some $3), true)) $startpos $endpos } + { mk_vs (VS_val_spec ($5, mk_id (Id $3) $startpos($3) $endpos($3), [("_", $3)], true)) $startpos $endpos } | Val id Eq Lcurly externs Rcurly Colon typschm - { mk_vs (VS_val_spec ($8, $2, (fun backend -> (assoc_opt backend $5)), false)) $startpos $endpos } + { mk_vs (VS_val_spec ($8, $2, $5, false)) $startpos $endpos } | Val Cast id Eq Lcurly externs Rcurly Colon typschm - { mk_vs (VS_val_spec ($9, $3, (fun backend -> (assoc_opt backend $6)), true)) $startpos $endpos } + { mk_vs (VS_val_spec ($9, $3, $6, true)) $startpos $endpos } register_def: | Register id Colon typ diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index f1726ce4..ccbde5cd 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -2235,8 +2235,8 @@ let find_exc_typ defs = let find_unimplemented defs = let adjust_def unimplemented = function - | DEF_spec (VS_aux (VS_val_spec (_,id,ext,_),_)) -> begin - match ext "coq" with + | DEF_spec (VS_aux (VS_val_spec (_,id,exts,_),_)) -> begin + match Ast_util.extern_assoc "coq" exts with | Some _ -> unimplemented | None -> IdSet.add id unimplemented end diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index 68825c8f..ba2b797b 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -1349,7 +1349,7 @@ let doc_dec_lem (DEC_aux (reg, ((l, _) as annot))) = let doc_spec_lem (VS_aux (valspec,annot)) = match valspec with - | VS_val_spec (typschm,id,ext,_) when ext "lem" = None -> + | VS_val_spec (typschm,id,exts,_) when Ast_util.extern_assoc "lem" exts = None -> (* let (TypSchm_aux (TypSchm_ts (tq, typ), _)) = typschm in if contains_t_pp_var typ then empty else *) doc_docstring_lem annot ^^ diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index 0b0a8305..179ef208 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -538,9 +538,7 @@ let doc_typdef (TD_aux(td,_)) = match td with let doc_spec (VS_aux (v, annot)) = let doc_extern ext = - let doc_backend b = Util.option_map (fun id -> string (b ^ ":") ^^ space ^^ - utf8string ("\"" ^ String.escaped id ^ "\"")) (ext b) in - let docs = Util.option_these (List.map doc_backend ["ocaml"; "lem"; "smt"; "interpreter"; "c"]) in + let docs = List.map (fun (backend, rep) -> string (backend ^ ":") ^^ space ^^ utf8string ("\"" ^ String.escaped rep ^ "\"")) ext in if docs = [] then empty else equals ^^ space ^^ braces (separate (comma ^^ space) docs) in match v with diff --git a/src/rewrites.ml b/src/rewrites.ml index c470d906..f1d22720 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2212,7 +2212,7 @@ let rewrite_split_fun_constr_pats fun_name (Defs defs) = in let val_spec = VS_aux (VS_val_spec - (mk_typschm typquant fun_typ, id, (fun _ -> None), false), + (mk_typschm typquant fun_typ, id, [], false), (Parse_ast.Unknown, empty_tannot)) in let fundef = FD_aux (FD_function (r_o, t_o, e_o, funcls), fdannot) in @@ -3152,7 +3152,7 @@ let construct_toplevel_string_append_func env f_id pat = ), unk)] in let fun_typ = (mk_typ (Typ_fn ([string_typ], option_typ, no_effect))) in - let new_val_spec = VS_aux (VS_val_spec (mk_typschm (TypQ_aux (TypQ_no_forall, unk)) fun_typ, f_id, (fun _ -> None), false), unkt) in + let new_val_spec = VS_aux (VS_val_spec (mk_typschm (TypQ_aux (TypQ_no_forall, unk)) fun_typ, f_id, [], false), unkt) in let new_val_spec, env = Type_check.check_val_spec env new_val_spec in let non_rec = (Rec_aux (Rec_nonrec, Parse_ast.Unknown)) in let no_tannot = (Typ_annot_opt_aux (Typ_annot_opt_none, Parse_ast.Unknown)) in @@ -4345,10 +4345,10 @@ let rewrite_defs_realise_mappings (Defs defs) = 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, (fun _ -> None), false), (Parse_ast.Unknown,())) in - let backwards_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_typ, backwards_id, (fun _ -> None), false), (Parse_ast.Unknown,())) in - let forwards_matches_spec = VS_aux (VS_val_spec (mk_typschm typq forwards_matches_typ, forwards_matches_id, (fun _ -> None), false), (Parse_ast.Unknown,())) in - let backwards_matches_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_matches_typ, backwards_matches_id, (fun _ -> None), false), (Parse_ast.Unknown,())) 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 @@ -4382,7 +4382,7 @@ 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") [Typ_arg_aux (Typ_arg_typ (tuple_typ [typ2; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in - let forwards_prefix_spec = VS_aux (VS_val_spec (mk_typschm typq forwards_prefix_typ, prefix_id, (fun _ -> None), false), (Parse_ast.Unknown,())) in + let forwards_prefix_spec = 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_pure, [mk_funcl prefix_id arg_pat forwards_prefix_match]), (l, ()))) in @@ -4392,7 +4392,7 @@ let rewrite_defs_realise_mappings (Defs defs) = else if subtype_check env typ2 string_typ && subtype_check env string_typ typ2 then let backwards_prefix_typ = Typ_aux (Typ_fn ([typ2], app_typ (mk_id "option") [Typ_arg_aux (Typ_arg_typ (tuple_typ [typ1; nat_typ]), Parse_ast.Unknown)], no_effect), Parse_ast.Unknown) in - let backwards_prefix_spec = VS_aux (VS_val_spec (mk_typschm typq backwards_prefix_typ, prefix_id, (fun _ -> None), false), (Parse_ast.Unknown,())) in + let backwards_prefix_spec = 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_pure, [mk_funcl prefix_id arg_pat backwards_prefix_match]), (l, ()))) in diff --git a/src/type_check.ml b/src/type_check.ml index cf1d8ef9..16690696 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -392,7 +392,7 @@ module Env : sig val add_overloads : id -> id list -> t -> t val get_overloads : id -> t -> id list val is_extern : id -> t -> string -> bool - val add_extern : id -> (string -> string option) -> t -> t + val add_extern : id -> (string * string) list -> t -> t val get_extern : id -> t -> string -> string val get_default_order : t -> order val set_default_order : order_aux -> t -> t @@ -459,7 +459,7 @@ end = struct enums : IdSet.t Bindings.t; records : (typquant * (typ * id) list) Bindings.t; accessors : (typquant * typ) Bindings.t; - externs : (string -> string option) Bindings.t; + externs : (string * string) list Bindings.t; smt_ops : string Bindings.t; constraint_synonyms : (kid list * n_constraint) Bindings.t; casts : id list; @@ -1073,7 +1073,7 @@ end = struct | Not_found -> typ_error (id_loc id) ("No register binding found for " ^ string_of_id id) let is_extern id env backend = - try not (Bindings.find id env.externs backend = None) with + try not (Ast_util.extern_assoc backend (Bindings.find id env.externs) = None) with | Not_found -> false (* Bindings.mem id env.externs *) @@ -1082,7 +1082,7 @@ end = struct let get_extern id env backend = try - match Bindings.find id env.externs backend with + match Ast_util.extern_assoc backend (Bindings.find id env.externs) with | Some ext -> ext | None -> typ_error (id_loc id) ("No extern binding found for " ^ string_of_id id) with @@ -4353,7 +4353,7 @@ let mk_val_spec env typq typ id = | Typ_aux (Typ_fn (_,_,eff),_) -> eff | _ -> no_effect in - DEF_spec (VS_aux (VS_val_spec (TypSchm_aux (TypSchm_ts (typq, typ), Parse_ast.Unknown), id, (fun _ -> None), false), (Parse_ast.Unknown, Some ((env,typ,eff),None)))) + DEF_spec (VS_aux (VS_val_spec (TypSchm_aux (TypSchm_ts (typq, typ), Parse_ast.Unknown), id, [], false), (Parse_ast.Unknown, Some ((env,typ,eff),None)))) let check_tannotopt env typq ret_typ = function | Typ_annot_opt_aux (Typ_annot_opt_none, _) -> () @@ -4449,16 +4449,16 @@ let check_mapdef env (MD_aux (MD_mapping (id, tannot_opt, mapcls), (l, _)) as md let check_val_spec env (VS_aux (vs, (l, _))) = let annotate vs typ eff = DEF_spec (VS_aux (vs, (l, Some ((env, typ, eff), None)))) in let vs, id, typq, typ, env = match vs with - | VS_val_spec (TypSchm_aux (TypSchm_ts (typq, typ), ts_l) as typschm, id, ext_opt, is_cast) -> + | VS_val_spec (TypSchm_aux (TypSchm_ts (typq, typ), ts_l) as typschm, id, exts, is_cast) -> typ_print (lazy (Util.("Check val spec " |> cyan |> clear) ^ string_of_id id ^ " : " ^ string_of_typschm typschm)); - let env = match (ext_opt "smt", ext_opt "#") with + let env = match (Ast_util.extern_assoc "smt" exts, Ast_util.extern_assoc "#" exts) with | Some op, None -> Env.add_smt_op id op env | _, _ -> env in - let env = Env.add_extern id ext_opt env in + let env = Env.add_extern id exts env in let env = if is_cast then Env.add_cast id env else env in let typq, typ = expand_bind_synonyms ts_l env (typq, typ) in - let vs = VS_val_spec (TypSchm_aux (TypSchm_ts (typq, typ), ts_l), id, ext_opt, is_cast) in + let vs = VS_val_spec (TypSchm_aux (TypSchm_ts (typq, typ), ts_l), id, exts, is_cast) in (vs, id, typq, typ, env) in let eff = @@ -4626,13 +4626,13 @@ let initial_env = (* |> Env.add_val_spec (mk_id "int") * (TypQ_aux (TypQ_no_forall, Parse_ast.Unknown), Typ_aux (Typ_bidir (int_typ, string_typ), Parse_ast.Unknown)) *) - |> Env.add_extern (mk_id "size_itself_int") (fun _ -> Some "size_itself_int") + |> Env.add_extern (mk_id "size_itself_int") [("_", "size_itself_int")] |> Env.add_val_spec (mk_id "size_itself_int") (TypQ_aux (TypQ_tq [QI_aux (QI_id (KOpt_aux (KOpt_none (mk_kid "n"),Parse_ast.Unknown)), Parse_ast.Unknown)],Parse_ast.Unknown), function_typ [app_typ (mk_id "itself") [mk_typ_arg (Typ_arg_nexp (nvar (mk_kid "n")))]] (atom_typ (nvar (mk_kid "n"))) no_effect) - |> Env.add_extern (mk_id "make_the_value") (fun _ -> Some "make_the_value") + |> Env.add_extern (mk_id "make_the_value") [("_", "make_the_value")] |> Env.add_val_spec (mk_id "make_the_value") (TypQ_aux (TypQ_tq [QI_aux (QI_id (KOpt_aux (KOpt_none (mk_kid "n"),Parse_ast.Unknown)), Parse_ast.Unknown)],Parse_ast.Unknown), -- cgit v1.2.3 From 130adb593568faaed49fd640750d94a8da37a24e Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 27 Dec 2018 12:20:25 +0000 Subject: basic Sail-side support for rmem use of interpreter --- src/interpreter.ml | 44 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) (limited to 'src') diff --git a/src/interpreter.ml b/src/interpreter.ml index 167c66f5..83f8b14e 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -997,3 +997,47 @@ let rec initialize_registers gstate = | Defs [] -> gstate let initial_state ast env primops = initial_lstate, initialize_registers (initial_gstate primops ast env) ast + +type value_result = + | Value_success of value + | Value_error of exn + +let decode_instruction state bv = + try + let env = (snd state).typecheck_env in + let untyped = mk_exp (E_app ((mk_id "decode"), [mk_exp (E_vector (List.map mk_lit_exp bv))])) in + let typed = Type_check.check_exp + env untyped (app_typ (mk_id "option") + [Typ_arg_aux (Typ_arg_typ (mk_typ (Typ_id (mk_id "ast"))), Parse_ast.Unknown)]) in + let evaled = eval_exp state typed in + match evaled with + | V_ctor ("Some", [v]) -> Value_success v + | V_ctor ("None", _) -> failwith "decode returned None" + | _ -> failwith "decode returned wrong value type" + with _ as exn -> + Value_error exn + +let annot_exp_effect e_aux l env typ effect = E_aux (e_aux, (l, Type_check.mk_tannot env typ effect)) +let annot_exp e_aux l env typ = annot_exp_effect e_aux l env typ no_effect +let id_typ id = mk_typ (Typ_id (mk_id id)) + +let analyse_instruction state ast = + try + let env = (snd state).typecheck_env in + let unk = Parse_ast.Unknown in + let typed = annot_exp + (E_app (mk_id "initial_analysis", [annot_exp (E_internal_value ast) unk env (id_typ "ast")])) unk env + (tuple_typ [id_typ "regfps"; id_typ "regfps"; id_typ "regfps"; id_typ "niafps"; id_typ "diafp"; id_typ "instruction_kind"]) + in + let evaled = eval_exp state typed in + Value_success evaled + with _ as exn -> + Value_error exn + +let execute_instruction state ast = + let env = (snd state).typecheck_env in + let unk = Parse_ast.Unknown in + let typed = annot_exp + (E_app (mk_id "execute", [annot_exp (E_internal_value ast) unk env (id_typ "ast")])) unk env unit_typ + in + Step (lazy (Pretty_print_sail.to_string (Pretty_print_sail.doc_exp typed)), state, return typed, []) -- cgit v1.2.3 From e6054bed8375003594edb076ad8be7950b09c5c3 Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 27 Dec 2018 12:22:53 +0000 Subject: remove unused previous-version-of-flow-typing functions from typechecker (they store flow-typing info as functions; preparing for marshalling) --- src/type_check.ml | 22 ++-------------------- 1 file changed, 2 insertions(+), 20 deletions(-) (limited to 'src') diff --git a/src/type_check.ml b/src/type_check.ml index 16690696..88d33569 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -368,9 +368,6 @@ module Env : sig val add_variant : id -> typquant * type_union list -> t -> t val add_mapping : id -> typquant * typ * typ -> t -> t val add_union_id : id -> typquant * typ -> t -> t - val add_flow : id -> (typ -> typ) -> t -> t - val get_flow : id -> t -> typ -> typ - val remove_flow : id -> t -> t val is_register : id -> t -> bool val get_register : id -> t -> effect * effect * typ val add_register : id -> effect -> effect -> typ -> t -> t @@ -455,7 +452,6 @@ end = struct typ_synonyms : (t -> typ_arg list -> typ) Bindings.t; num_defs : nexp Bindings.t; overloads : (id list) Bindings.t; - flow : (typ -> typ) Bindings.t; enums : IdSet.t Bindings.t; records : (typquant * (typ * id) list) Bindings.t; accessors : (typquant * typ) Bindings.t; @@ -485,7 +481,6 @@ end = struct typ_synonyms = Bindings.empty; num_defs = Bindings.empty; overloads = Bindings.empty; - flow = Bindings.empty; enums = Bindings.empty; records = Bindings.empty; accessors = Bindings.empty; @@ -1053,18 +1048,6 @@ end = struct { env with union_ids = Bindings.add id bind env.union_ids } end - let get_flow id env = - try Bindings.find id env.flow with - | Not_found -> fun typ -> typ - - let add_flow id f env = - typ_print (lazy (adding ^ "flow constraints for " ^ string_of_id id)); - { env with flow = Bindings.add id (fun typ -> f (get_flow id env typ)) env.flow } - - let remove_flow id env = - typ_print (lazy ("Removing flow constraints for " ^ string_of_id id)); - { env with flow = Bindings.remove id env.flow } - let is_register id env = Bindings.mem id env.registers @@ -1105,8 +1088,7 @@ end = struct let lookup_id ?raw:(raw=false) id env = try let (mut, typ) = Bindings.find id env.locals in - let flow = get_flow id env in - Local (mut, if raw then typ else flow typ) + Local (mut, typ) with | Not_found -> try @@ -3114,7 +3096,7 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = begin match Env.lookup_id ~raw:true v env with | Local (Immutable, _) | Enum _ -> typ_error l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v) - | Local (Mutable, vtyp) -> subtyp l env typ vtyp; annot_lexp (LEXP_id v) typ, Env.remove_flow v env + | Local (Mutable, vtyp) -> subtyp l env typ vtyp; annot_lexp (LEXP_id v) typ, env | Register (_, weff, vtyp) -> subtyp l env typ vtyp; annot_lexp_effect (LEXP_id v) typ weff, env | Unbound -> annot_lexp (LEXP_id v) typ, Env.add_local v (Mutable, typ) env end -- cgit v1.2.3 From 4f804dc5d80b422d1822c9aec5221ada7b395fc7 Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 27 Dec 2018 12:24:24 +0000 Subject: new command line option -marshal to marshal out rewritten AST to a file Adds new dependency: base64 --- src/_tags | 6 +++--- src/sail.ml | 16 ++++++++++++++++ 2 files changed, 19 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/_tags b/src/_tags index c5f4e127..6b2bf716 100644 --- a/src/_tags +++ b/src/_tags @@ -1,12 +1,12 @@ true: -traverse, debug, use_menhir <**/*.ml>: bin_annot, annot -: package(zarith), package(linksem), package(lem), use_pprint -: package(zarith), package(linenoise), package(linksem), package(lem), use_pprint +: package(zarith), package(linksem), package(lem), package(base64), use_pprint +: package(zarith), package(linenoise), package(linksem), package(lem), package(base64), use_pprint : package(linenoise) : package(linksem) -<**/*.m{l,li}>: package(lem) +<**/*.m{l,li}>: package(lem), package(base64) : include or : include diff --git a/src/sail.ml b/src/sail.ml index 2748cb81..5deaa340 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -72,6 +72,7 @@ let opt_libs_coq = ref ([]:string list) let opt_file_arguments = ref ([]:string list) let opt_process_elf : string option ref = ref None let opt_ocaml_generators = ref ([]:string list) +let opt_marshal_defs = ref false let options = Arg.align ([ ( "-o", @@ -111,6 +112,9 @@ let options = Arg.align ([ ( "-latex", Arg.Set opt_print_latex, " pretty print the input to latex"); + ( "-marshal", + Arg.Set opt_marshal_defs, + " OCaml-marshal out the rewritten AST to a file"); ( "-c", Arg.Tuple [Arg.Set opt_print_c; Arg.Set Initial_check.opt_undefined_gen], " output a C translated version of the input"); @@ -368,6 +372,18 @@ let main() = close_out chan end else ()); + (if !(opt_marshal_defs) + then + begin + let ast_marshal = rewrite_ast_ocaml type_envs ast in + let out_filename = match !opt_file_out with None -> "out" | Some s -> s in + let f = open_out_bin (out_filename ^ ".defs") in + Marshal.to_string ast_marshal [Marshal.No_sharing; Marshal.Compat_32] + |> B64.encode + |> output_string f; + close_out f + end + else ()); end let _ = try -- cgit v1.2.3 From 9f6a95882e1d3d057bcb83d098ba1b63925a4d1f Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 27 Dec 2018 16:20:31 +0000 Subject: fix missed case in refactored val-spec extern parser --- src/parser.mly | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/parser.mly b/src/parser.mly index b2df5176..0fe99280 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -1330,7 +1330,7 @@ val_spec_def: | Val Cast id Colon typschm { mk_vs (VS_val_spec ($5, $3, [], true)) $startpos $endpos } | Val id Eq String Colon typschm - { mk_vs (VS_val_spec ($6, $2, [], false)) $startpos $endpos } + { mk_vs (VS_val_spec ($6, $2, [("_", $4)], false)) $startpos $endpos } | Val Cast id Eq String Colon typschm { mk_vs (VS_val_spec ($7, $3, [("_", $5)], true)) $startpos $endpos } | Val String Colon typschm -- cgit v1.2.3 From 3506f72e7c360a1a7502fb6196a1efd65b819c27 Mon Sep 17 00:00:00 2001 From: Jon French Date: Fri, 28 Dec 2018 15:18:31 +0000 Subject: Remove opt_spc_matches_prefix from sail.h (fixes C tests) --- src/interpreter.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/interpreter.ml b/src/interpreter.ml index 74333122..96ef80f0 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -1008,7 +1008,7 @@ let decode_instruction state bv = let untyped = mk_exp (E_app ((mk_id "decode"), [mk_exp (E_vector (List.map mk_lit_exp bv))])) in let typed = Type_check.check_exp env untyped (app_typ (mk_id "option") - [Typ_arg_aux (Typ_arg_typ (mk_typ (Typ_id (mk_id "ast"))), Parse_ast.Unknown)]) in + [A_aux (A_typ (mk_typ (Typ_id (mk_id "ast"))), Parse_ast.Unknown)]) in let evaled = eval_exp state typed in match evaled with | V_ctor ("Some", [v]) -> Value_success v -- cgit v1.2.3 From dd5ac9c9b814e0e0c502b4959f8c5c0746ffefd8 Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 2 Jan 2019 12:39:34 +0000 Subject: restore V_attempted_read behaviour after merge --- src/constant_fold.ml | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/constant_fold.ml b/src/constant_fold.ml index acae4581..a46f2765 100644 --- a/src/constant_fold.ml +++ b/src/constant_fold.ml @@ -78,7 +78,9 @@ and exp_of_value = | V_tuple vs -> mk_exp (E_tuple (List.map exp_of_value vs)) | V_unit -> mk_lit_exp L_unit - | V_attempted_read str -> mk_exp (E_id (mk_id str)) + | V_attempted_read str -> + prerr_endline ("constant_fold folding away V_attempted_read " ^ str); + mk_exp (E_id (mk_id str)) | _ -> failwith "No expression for value" (* We want to avoid evaluating things like print statements at compile @@ -126,6 +128,14 @@ let rec run frame = run (Interpreter.eval_frame frame) | Interpreter.Break frame -> run (Interpreter.eval_frame frame) + | Interpreter.Effect_request (st, Interpreter.Read_reg (reg, cont)) -> + (* return a dummy value to read_reg requests which we handle above + if an expression finally evals to it, but the interpreter + will fail if it tries to actually use. See value.ml *) + prerr_endline ("constant_fold returned V_attempted_read " ^ reg ^ "\n"); + run (cont (Value.V_attempted_read reg) st) + | Interpreter.Effect_request _ -> + assert false (* effectful, raise exception to abort constant folding *) (** This rewriting pass looks for function applications (E_app) expressions where every argument is a literal. It passes these -- cgit v1.2.3 From bce4ee6000254c368fc83cdf62bdcdb9374b9691 Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 2 Jan 2019 12:40:34 +0000 Subject: ...without debug printing --- src/constant_fold.ml | 2 -- 1 file changed, 2 deletions(-) (limited to 'src') diff --git a/src/constant_fold.ml b/src/constant_fold.ml index a46f2765..f232067c 100644 --- a/src/constant_fold.ml +++ b/src/constant_fold.ml @@ -79,7 +79,6 @@ and exp_of_value = mk_exp (E_tuple (List.map exp_of_value vs)) | V_unit -> mk_lit_exp L_unit | V_attempted_read str -> - prerr_endline ("constant_fold folding away V_attempted_read " ^ str); mk_exp (E_id (mk_id str)) | _ -> failwith "No expression for value" @@ -132,7 +131,6 @@ let rec run frame = (* return a dummy value to read_reg requests which we handle above if an expression finally evals to it, but the interpreter will fail if it tries to actually use. See value.ml *) - prerr_endline ("constant_fold returned V_attempted_read " ^ reg ^ "\n"); run (cont (Value.V_attempted_read reg) st) | Interpreter.Effect_request _ -> assert false (* effectful, raise exception to abort constant folding *) -- cgit v1.2.3 From f0252315d529f9b2efe65bea726c2ae0a3261de6 Mon Sep 17 00:00:00 2001 From: Jon French Date: Tue, 19 Feb 2019 15:49:39 +0000 Subject: Progress on toFromInterp backend from-interp generation Produces vaguely-correct-looking-but-untested code for riscv duopod --- src/sail.ml | 10 +++ src/toFromInterp_backend.ml | 159 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 169 insertions(+) create mode 100644 src/toFromInterp_backend.ml (limited to 'src') diff --git a/src/sail.ml b/src/sail.ml index 82c1244b..f481eb7b 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -59,6 +59,7 @@ let opt_print_version = ref false let opt_print_initial_env = ref false let opt_print_verbose = ref false let opt_print_lem = ref false +let opt_print_tofrominterp = ref false let opt_print_ocaml = ref false let opt_print_c = ref false let opt_print_latex = ref false @@ -95,6 +96,9 @@ let options = Arg.align ([ ( "-no_warn", Arg.Clear Util.opt_warnings, " do not print warnings"); + ( "-tofrominterp", + Arg.Set opt_print_tofrominterp, + " output OCaml functions to translate between shallow embedding and interpreter"); ( "-ocaml", Arg.Tuple [Arg.Set opt_print_ocaml; Arg.Set Initial_check.opt_undefined_gen], " output an OCaml translated version of the input"); @@ -398,6 +402,12 @@ let main() = let out = match !opt_file_out with None -> "out" | Some s -> s in Ocaml_backend.ocaml_compile out ast_ocaml ocaml_generator_info else ()); + (if !opt_print_tofrominterp + then + let ast = rewrite_ast_interpreter type_envs ast in + let out = match !opt_file_out with None -> "out" | Some s -> s in + ToFromInterp_backend.tofrominterp_output out ast + else ()); (if !(opt_print_c) then let ast_c = rewrite_ast_c type_envs ast in diff --git a/src/toFromInterp_backend.ml b/src/toFromInterp_backend.ml new file mode 100644 index 00000000..524de94c --- /dev/null +++ b/src/toFromInterp_backend.ml @@ -0,0 +1,159 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Ast_util +open PPrint +open Type_check +open Util +open Pretty_print_common +open Ocaml_backend + +let frominterp_typedef (TD_aux (td_aux, (l, _))) = + let fromValueArgs (Typ_aux (typ_aux, _)) = match typ_aux with + | Typ_tup typs -> brackets (separate (semi ^^ space) (List.mapi (fun i _ -> string ("v" ^ (string_of_int i))) typs)) + | _ -> brackets (string "v0") + in + let fromValueKid (Kid_aux ((Var name), _)) = + string ("typq_" ^ name) + in + let fromValueNexp (Nexp_aux (nexp_aux, _)) = match nexp_aux with + | Nexp_constant num -> parens (separate space [string "Big_int.of_string"; dquotes (string (Nat_big_num.to_string num))]) + | Nexp_var var -> fromValueKid var + | _ -> string "NEXP" + in + let rec fromValueTypArg (A_aux (a_aux, _)) = match a_aux with + | A_typ typ -> fromValueTyp typ "" + | A_nexp nexp -> fromValueNexp nexp + | A_order order -> string ("Order_" ^ (string_of_order order)) + | _ -> string "TYP_ARG" + and fromValueTyp ((Typ_aux (typ_aux, l)) as typ) arg_name = match typ_aux with + | Typ_id id -> parens (concat [string (zencode_string (string_of_id id)); string ("FromInterpValue"); space; string arg_name]) + | Typ_app (typ_id, typ_args) -> + assert (typ_args <> []); + parens (separate space ([string (zencode_string (string_of_id typ_id) ^ "FromInterpValue")] @ List.map fromValueTypArg typ_args @ [string arg_name])) + | Typ_var kid -> parens (separate space [fromValueKid kid; string arg_name]) + | Typ_fn _ -> parens (string "failwith \"fromValueTyp: Typ_fn arm unimplemented\"") + | _ -> parens (string "failwith \"fromValueTyp: type arm unimplemented\"") + in + let fromValueVals ((Typ_aux (typ_aux, l)) as typ) = match typ_aux with + | Typ_tup typs -> parens (separate comma_sp (List.mapi (fun i typ -> fromValueTyp typ ("v" ^ (string_of_int i))) typs)) + | _ -> fromValueTyp typ "v0" + in + let fromValueTypq (QI_aux (qi_aux, _)) = match qi_aux with + | QI_id (KOpt_aux (KOpt_kind (K_aux (kind_aux, _), kid), _)) -> fromValueKid kid + | QI_const _ -> empty + in + let fromValueTypqs (TypQ_aux (typq_aux, _)) = match typq_aux with + | TypQ_no_forall -> [empty] + | TypQ_tq quants -> List.map fromValueTypq quants + in + match td_aux with + | TD_variant (id, typq, arms, _) -> + begin match id with + | Id_aux ((Id "read_kind"),_) -> empty + | Id_aux ((Id "write_kind"),_) -> empty + | Id_aux ((Id "barrier_kind"),_) -> empty + | Id_aux ((Id "trans_kind"),_) -> empty + | Id_aux ((Id "instruction_kind"),_) -> empty + (* | Id_aux ((Id "regfp"),_) -> empty + | Id_aux ((Id "niafp"),_) -> empty + | Id_aux ((Id "diafp"),_) -> empty *) + (* | Id_aux ((Id "option"),_) -> empty *) + | _ -> + let fromInterpValueName = concat [string (zencode_string (string_of_id id)); string "FromInterpValue"] in + let fromFallback = separate space [pipe; underscore; arrow; string "failwith"; + dquotes (string ("invalid interpreter value for " ^ (string_of_id id)))] in + let fromInterpValue = + prefix 2 1 + (separate space [string "let"; fromInterpValueName; separate space (fromValueTypqs typq @ [string "v"]); equals; string "match v with"]) + ((separate_map hardline + (fun (Tu_aux (Tu_ty_id (typ, ctor_id), _)) -> + print_endline (string_of_typ typ); + separate space + [pipe; string "V_ctor"; parens (concat [dquotes (string (string_of_id ctor_id)); comma_sp; + fromValueArgs typ + ]); + arrow; string (zencode_upper_string (string_of_id ctor_id)); fromValueVals typ + ] + ) + arms) + ^^ hardline ^^ fromFallback) + in + fromInterpValue ^^ (twice hardline) + end + | TD_abbrev (id, typq, typ_arg) -> + let fromInterpValueName = concat [string (zencode_string (string_of_id id)); string "FromInterpValue"] in + let fromInterpValue = + (separate space [string "let"; fromInterpValueName; separate space (fromValueTypqs typq); equals; fromValueTypArg typ_arg]) + in + fromInterpValue ^^ (twice hardline) + | _ -> empty + +let tointerp_typedef td = empty + +let tofrominterp_def def = match def with + | DEF_type td -> group (frominterp_typedef td ^^ twice hardline ^^ tointerp_typedef td) + | _ -> empty + +let tofrominterp_defs (Defs defs) = + (string "open Sail_lib;;" ^^ hardline) + ^^ (string "open Value;;" ^^ hardline) + ^^ (string "open Interpreter;;" ^^ hardline) + ^^ (string "module Big_int = Nat_big_num" ^^ ocaml_def_end) + ^^ concat (List.map tofrominterp_def defs) + +let tofrominterp_pp_defs f defs = + ToChannel.pretty 1. 80 f (tofrominterp_defs defs) + +let tofrominterp_output name defs = + let out_chan = open_out (name ^ "_toFromInterp.ml") in + tofrominterp_pp_defs out_chan defs; + close_out out_chan -- cgit v1.2.3 From a8a5308e4981b3d09fb2bf0c59d592ef6ae4417e Mon Sep 17 00:00:00 2001 From: Jon French Date: Fri, 22 Feb 2019 15:30:59 +0000 Subject: Progress on toFromInterp backend Now builds for riscv duopod --- src/ocaml_backend.ml | 2 + src/toFromInterp_backend.ml | 122 +++++++++++++++++++++++++++++++++++++++++--- src/toFromInterp_lib.ml | 46 +++++++++++++++++ 3 files changed, 162 insertions(+), 8 deletions(-) create mode 100644 src/toFromInterp_lib.ml (limited to 'src') diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index 2cbdfab2..ba21dd0a 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -990,6 +990,8 @@ let ocaml_compile spec defs generator_types = let _ = Unix.system ("cp -r " ^ sail_dir ^ "/src/elf_loader.ml .") in let _ = Unix.system ("cp -r " ^ sail_dir ^ "/src/sail_lib.ml .") in let _ = Unix.system ("cp -r " ^ sail_dir ^ "/src/util.ml .") in + let _ = Unix.system ("cp -r " ^ sail_dir ^ "/src/value.ml .") in + let _ = Unix.system ("cp -r " ^ sail_dir ^ "/src/toFromInterp_lib.ml .") in let tags_file = if !opt_ocaml_coverage then "_tags_coverage" else "_tags" in let _ = Unix.system ("cp -r " ^ sail_dir ^ "/lib/" ^ tags_file ^ " _tags") in let out_chan = open_out (spec ^ ".ml") in diff --git a/src/toFromInterp_backend.ml b/src/toFromInterp_backend.ml index 524de94c..85708712 100644 --- a/src/toFromInterp_backend.ml +++ b/src/toFromInterp_backend.ml @@ -116,7 +116,6 @@ let frominterp_typedef (TD_aux (td_aux, (l, _))) = (separate space [string "let"; fromInterpValueName; separate space (fromValueTypqs typq @ [string "v"]); equals; string "match v with"]) ((separate_map hardline (fun (Tu_aux (Tu_ty_id (typ, ctor_id), _)) -> - print_endline (string_of_typ typ); separate space [pipe; string "V_ctor"; parens (concat [dquotes (string (string_of_id ctor_id)); comma_sp; fromValueArgs typ @@ -135,25 +134,132 @@ let frominterp_typedef (TD_aux (td_aux, (l, _))) = (separate space [string "let"; fromInterpValueName; separate space (fromValueTypqs typq); equals; fromValueTypArg typ_arg]) in fromInterpValue ^^ (twice hardline) + | TD_enum (id, ids, _) -> + let fromInterpValueName = concat [string (zencode_string (string_of_id id)); string "FromInterpValue"] in + let fromFallback = separate space [pipe; underscore; arrow; string "failwith"; + dquotes (string ("invalid interpreter value for " ^ (string_of_id id)))] in + let fromInterpValue = + prefix 2 1 + (separate space [string "let"; fromInterpValueName; string "v"; equals; string "match v with"]) + ((separate_map hardline + (fun id -> + separate space + [pipe; string "V_ctor"; parens (concat [dquotes (string (string_of_id id)); comma_sp; string "[]"]); + arrow; string (zencode_upper_string (string_of_id id))] + ) + ids) + ^^ hardline ^^ fromFallback) + in + fromInterpValue ^^ (twice hardline) + | _ -> empty + +let tointerp_typedef (TD_aux (td_aux, (l, _))) = + let toValueArgs (Typ_aux (typ_aux, _)) = match typ_aux with + | Typ_tup typs -> parens (separate comma_sp (List.mapi (fun i _ -> string ("v" ^ (string_of_int i))) typs)) + | _ -> parens (string "v0") + in + let toValueKid (Kid_aux ((Var name), _)) = + string ("typq_" ^ name) + in + let toValueNexp (Nexp_aux (nexp_aux, _)) = match nexp_aux with + | Nexp_constant num -> parens (separate space [string "Big_int.of_string"; dquotes (string (Nat_big_num.to_string num))]) + | Nexp_var var -> toValueKid var + | _ -> string "NEXP" + in + let rec toValueTypArg (A_aux (a_aux, _)) = match a_aux with + | A_typ typ -> toValueTyp typ "" + | A_nexp nexp -> toValueNexp nexp + | A_order order -> string ("Order_" ^ (string_of_order order)) + | _ -> string "TYP_ARG" + and toValueTyp ((Typ_aux (typ_aux, l)) as typ) arg_name = match typ_aux with + | Typ_id id -> parens (concat [string (zencode_string (string_of_id id)); string "ToInterpValue"; space; string arg_name]) + | Typ_app (typ_id, typ_args) -> + assert (typ_args <> []); + parens (separate space ([string ((zencode_string (string_of_id typ_id)) ^ "ToInterpValue")] @ List.map toValueTypArg typ_args @ [string arg_name])) + | Typ_var kid -> parens (separate space [toValueKid kid; string arg_name]) + | _ -> parens (string "failwith \"toValueTyp: type arm unimplemented\"") + in + let toValueVals ((Typ_aux (typ_aux, _)) as typ) = match typ_aux with + | Typ_tup typs -> brackets (separate (semi ^^ space) (List.mapi (fun i typ -> toValueTyp typ ("v" ^ (string_of_int i))) typs)) + | _ -> brackets (toValueTyp typ "v0") + in + let toValueTypq (QI_aux (qi_aux, _)) = match qi_aux with + | QI_id (KOpt_aux (KOpt_kind (K_aux (kind_aux, _), kid), _)) -> toValueKid kid + | QI_const _ -> empty + in + let toValueTypqs (TypQ_aux (typq_aux, _)) = match typq_aux with + | TypQ_no_forall -> [empty] + | TypQ_tq quants -> List.map toValueTypq quants + in + match td_aux with + | TD_variant (id, typq, arms, _) -> + begin match id with + | Id_aux ((Id "read_kind"),_) -> empty + | Id_aux ((Id "write_kind"),_) -> empty + | Id_aux ((Id "barrier_kind"),_) -> empty + | Id_aux ((Id "trans_kind"),_) -> empty + | Id_aux ((Id "instruction_kind"),_) -> empty + (* | Id_aux ((Id "regfp"),_) -> empty + | Id_aux ((Id "niafp"),_) -> empty + | Id_aux ((Id "diafp"),_) -> empty *) + (* | Id_aux ((Id "option"),_) -> empty *) + | _ -> + let toInterpValueName = concat [string (zencode_string (string_of_id id)); string "ToInterpValue"] in + let toInterpValue = + prefix 2 1 + (separate space [string "let"; toInterpValueName; separate space (toValueTypqs typq @ [string "v"]); equals; string "match v with"]) + ((separate_map hardline + (fun (Tu_aux (Tu_ty_id (typ, ctor_id), _)) -> + separate space + [pipe; string (zencode_upper_string (string_of_id ctor_id)); toValueArgs typ; + arrow; string "V_ctor"; parens (concat [dquotes (string (string_of_id ctor_id)); comma_sp; toValueVals typ]) + ] + ) + arms)) + in + toInterpValue ^^ (twice hardline) + end + | TD_abbrev (id, typq, typ_arg) -> + let toInterpValueName = concat [string (zencode_string (string_of_id id)); string "ToInterpValue"] in + let toInterpValue = + (separate space [string "let"; toInterpValueName; separate space (toValueTypqs typq); equals; toValueTypArg typ_arg]) + in + toInterpValue ^^ (twice hardline) + | TD_enum (id, ids, _) -> + let toInterpValueName = concat [string (zencode_string (string_of_id id)); string "ToInterpValue"] in + let toInterpValue = + prefix 2 1 + (separate space [string "let"; toInterpValueName; string "v"; equals; string "match v with"]) + ((separate_map hardline + (fun id -> + separate space + [pipe; string (zencode_upper_string (string_of_id id)); + arrow; string "V_ctor"; parens (concat [dquotes (string (string_of_id id)); comma_sp; string "[]"])] + ) + ids)) + in + toInterpValue ^^ (twice hardline) | _ -> empty -let tointerp_typedef td = empty let tofrominterp_def def = match def with - | DEF_type td -> group (frominterp_typedef td ^^ twice hardline ^^ tointerp_typedef td) + | DEF_type td -> group (frominterp_typedef td ^^ twice hardline ^^ tointerp_typedef td ^^ twice hardline) | _ -> empty -let tofrominterp_defs (Defs defs) = +let tofrominterp_defs name (Defs defs) = (string "open Sail_lib;;" ^^ hardline) ^^ (string "open Value;;" ^^ hardline) - ^^ (string "open Interpreter;;" ^^ hardline) + ^^ (string "open ToFromInterp_lib;;" ^^ hardline) + ^^ (string ("open " ^ String.capitalize_ascii name ^ ";;") ^^ hardline) ^^ (string "module Big_int = Nat_big_num" ^^ ocaml_def_end) ^^ concat (List.map tofrominterp_def defs) -let tofrominterp_pp_defs f defs = - ToChannel.pretty 1. 80 f (tofrominterp_defs defs) +let tofrominterp_pp_defs name f defs = + ToChannel.pretty 1. 80 f (tofrominterp_defs name defs) let tofrominterp_output name defs = let out_chan = open_out (name ^ "_toFromInterp.ml") in - tofrominterp_pp_defs out_chan defs; + tofrominterp_pp_defs name out_chan defs; close_out out_chan + + diff --git a/src/toFromInterp_lib.ml b/src/toFromInterp_lib.ml new file mode 100644 index 00000000..b045e4e8 --- /dev/null +++ b/src/toFromInterp_lib.ml @@ -0,0 +1,46 @@ +(************************************************************) +(* Support for toFromInterp *) +(************************************************************) + +open Sail_lib;; +open Value;; + +type vector_order = + | Order_inc + | Order_dec + + +let zunitFromInterpValue v = match v with + | V_unit -> () + | _ -> failwith "invalid interpreter value for unit" + +let zunitToInterpValue () = V_unit + + +let zatomFromInterpValue typq_'n v = match v with + | V_int i -> + assert (typq_'n = i); + i + | _ -> failwith "invalid interpreter value for atom" + +let zatomToInterpValue typq_'n v = + assert (typq_'n = v); + V_int v + + +let zvectorFromInterpValue typq_'n typq_'ord typq_'a v = match v with + | V_vector vs -> + assert (Big_int.of_int (List.length vs) = typq_'n); + List.map typq_'a vs + | _ -> failwith "invalid interpreter value for vector" + +let zvectorToInterpValue typq_'n typq_'ord typq_'a v = + assert (Big_int.of_int (List.length v) = typq_'n); + V_vector (List.map typq_'a v) + + +let zbitFromInterpValue v = match v with + | V_bit b -> b + | _ -> failwith "invalid interpreter value for bit" + +let zbitToInterpValue v = V_bit v -- cgit v1.2.3 From 2e8e7c7ed813f3d8cdf94cdec57953511be5d814 Mon Sep 17 00:00:00 2001 From: Jon French Date: Tue, 26 Feb 2019 13:00:12 +0000 Subject: Further work on toFromInterp backend --- src/sail.ml | 9 ++++++- src/toFromInterp_backend.ml | 65 ++++++++++++++++++++++++++++++++------------- src/toFromInterp_lib.ml | 61 +++++++++++++++++++++++++++++++++++++++--- 3 files changed, 113 insertions(+), 22 deletions(-) (limited to 'src') diff --git a/src/sail.ml b/src/sail.ml index edf1bda4..a801ad81 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -60,6 +60,7 @@ let opt_print_initial_env = ref false let opt_print_verbose = ref false let opt_print_lem = ref false let opt_print_tofrominterp = ref false +let opt_tofrominterp_output_dir : string option ref = ref None let opt_print_ocaml = ref false let opt_print_c = ref false let opt_print_latex = ref false @@ -99,6 +100,12 @@ let options = Arg.align ([ ( "-tofrominterp", Arg.Set opt_print_tofrominterp, " output OCaml functions to translate between shallow embedding and interpreter"); + ( "-tofrominterp_lem", + Arg.Set ToFromInterp_backend.lem_mode, + " output embedding translation for the Lem backend rather than the OCaml backend"); + ( "-tofrominterp_output_dir", + Arg.String (fun dir -> opt_tofrominterp_output_dir := Some dir), + " set a custom directory to output embedding translation OCaml"); ( "-ocaml", Arg.Tuple [Arg.Set opt_print_ocaml; Arg.Set Initial_check.opt_undefined_gen], " output an OCaml translated version of the input"); @@ -415,7 +422,7 @@ let main() = then let ast = rewrite_ast_interpreter type_envs ast in let out = match !opt_file_out with None -> "out" | Some s -> s in - ToFromInterp_backend.tofrominterp_output out ast + ToFromInterp_backend.tofrominterp_output !opt_tofrominterp_output_dir out ast else ()); (if !(opt_print_c) then diff --git a/src/toFromInterp_backend.ml b/src/toFromInterp_backend.ml index 85708712..5a03ca83 100644 --- a/src/toFromInterp_backend.ml +++ b/src/toFromInterp_backend.ml @@ -56,6 +56,11 @@ open Util open Pretty_print_common open Ocaml_backend +let lem_mode = ref false + +let maybe_zencode s = if !lem_mode then s else zencode_string s +let maybe_zencode_upper s = if !lem_mode then String.capitalize_ascii s else zencode_upper_string s + let frominterp_typedef (TD_aux (td_aux, (l, _))) = let fromValueArgs (Typ_aux (typ_aux, _)) = match typ_aux with | Typ_tup typs -> brackets (separate (semi ^^ space) (List.mapi (fun i _ -> string ("v" ^ (string_of_int i))) typs)) @@ -75,10 +80,10 @@ let frominterp_typedef (TD_aux (td_aux, (l, _))) = | A_order order -> string ("Order_" ^ (string_of_order order)) | _ -> string "TYP_ARG" and fromValueTyp ((Typ_aux (typ_aux, l)) as typ) arg_name = match typ_aux with - | Typ_id id -> parens (concat [string (zencode_string (string_of_id id)); string ("FromInterpValue"); space; string arg_name]) + | Typ_id id -> parens (concat [string (maybe_zencode (string_of_id id)); string ("FromInterpValue"); space; string arg_name]) | Typ_app (typ_id, typ_args) -> assert (typ_args <> []); - parens (separate space ([string (zencode_string (string_of_id typ_id) ^ "FromInterpValue")] @ List.map fromValueTypArg typ_args @ [string arg_name])) + parens (separate space ([string (maybe_zencode (string_of_id typ_id) ^ "FromInterpValue")] @ List.map fromValueTypArg typ_args @ [string arg_name])) | Typ_var kid -> parens (separate space [fromValueKid kid; string arg_name]) | Typ_fn _ -> parens (string "failwith \"fromValueTyp: Typ_fn arm unimplemented\"") | _ -> parens (string "failwith \"fromValueTyp: type arm unimplemented\"") @@ -108,7 +113,7 @@ let frominterp_typedef (TD_aux (td_aux, (l, _))) = | Id_aux ((Id "diafp"),_) -> empty *) (* | Id_aux ((Id "option"),_) -> empty *) | _ -> - let fromInterpValueName = concat [string (zencode_string (string_of_id id)); string "FromInterpValue"] in + let fromInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "FromInterpValue"] in let fromFallback = separate space [pipe; underscore; arrow; string "failwith"; dquotes (string ("invalid interpreter value for " ^ (string_of_id id)))] in let fromInterpValue = @@ -120,7 +125,7 @@ let frominterp_typedef (TD_aux (td_aux, (l, _))) = [pipe; string "V_ctor"; parens (concat [dquotes (string (string_of_id ctor_id)); comma_sp; fromValueArgs typ ]); - arrow; string (zencode_upper_string (string_of_id ctor_id)); fromValueVals typ + arrow; string (maybe_zencode_upper (string_of_id ctor_id)); fromValueVals typ ] ) arms) @@ -129,13 +134,13 @@ let frominterp_typedef (TD_aux (td_aux, (l, _))) = fromInterpValue ^^ (twice hardline) end | TD_abbrev (id, typq, typ_arg) -> - let fromInterpValueName = concat [string (zencode_string (string_of_id id)); string "FromInterpValue"] in + let fromInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "FromInterpValue"] in let fromInterpValue = (separate space [string "let"; fromInterpValueName; separate space (fromValueTypqs typq); equals; fromValueTypArg typ_arg]) in fromInterpValue ^^ (twice hardline) | TD_enum (id, ids, _) -> - let fromInterpValueName = concat [string (zencode_string (string_of_id id)); string "FromInterpValue"] in + let fromInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "FromInterpValue"] in let fromFallback = separate space [pipe; underscore; arrow; string "failwith"; dquotes (string ("invalid interpreter value for " ^ (string_of_id id)))] in let fromInterpValue = @@ -145,12 +150,26 @@ let frominterp_typedef (TD_aux (td_aux, (l, _))) = (fun id -> separate space [pipe; string "V_ctor"; parens (concat [dquotes (string (string_of_id id)); comma_sp; string "[]"]); - arrow; string (zencode_upper_string (string_of_id id))] + arrow; string (maybe_zencode_upper (string_of_id id))] ) ids) ^^ hardline ^^ fromFallback) in fromInterpValue ^^ (twice hardline) + | TD_record (id, typq, fields, _) -> + let fromInterpField (typ, id) = + separate space [string (maybe_zencode (string_of_id id)); equals; fromValueTyp typ ("(StringMap.find \"" ^ (string_of_id id) ^ "\" fs)")] + in + let fromInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "FromInterpValue"] in + let fromFallback = separate space [pipe; underscore; arrow; string "failwith"; + dquotes (string ("invalid interpreter value for " ^ (string_of_id id)))] in + let fromInterpValue = + prefix 2 1 + (separate space [string "let"; fromInterpValueName; separate space (fromValueTypqs typq @ [string "v"]); equals; string "match v with"]) + ((separate space [pipe; string "V_record fs"; arrow; braces (separate_map (semi ^^ space) fromInterpField fields)]) + ^^ hardline ^^ fromFallback) + in + fromInterpValue ^^ (twice hardline) | _ -> empty let tointerp_typedef (TD_aux (td_aux, (l, _))) = @@ -172,10 +191,10 @@ let tointerp_typedef (TD_aux (td_aux, (l, _))) = | A_order order -> string ("Order_" ^ (string_of_order order)) | _ -> string "TYP_ARG" and toValueTyp ((Typ_aux (typ_aux, l)) as typ) arg_name = match typ_aux with - | Typ_id id -> parens (concat [string (zencode_string (string_of_id id)); string "ToInterpValue"; space; string arg_name]) + | Typ_id id -> parens (concat [string (maybe_zencode (string_of_id id)); string "ToInterpValue"; space; string arg_name]) | Typ_app (typ_id, typ_args) -> assert (typ_args <> []); - parens (separate space ([string ((zencode_string (string_of_id typ_id)) ^ "ToInterpValue")] @ List.map toValueTypArg typ_args @ [string arg_name])) + parens (separate space ([string ((maybe_zencode (string_of_id typ_id)) ^ "ToInterpValue")] @ List.map toValueTypArg typ_args @ [string arg_name])) | Typ_var kid -> parens (separate space [toValueKid kid; string arg_name]) | _ -> parens (string "failwith \"toValueTyp: type arm unimplemented\"") in @@ -204,14 +223,14 @@ let tointerp_typedef (TD_aux (td_aux, (l, _))) = | Id_aux ((Id "diafp"),_) -> empty *) (* | Id_aux ((Id "option"),_) -> empty *) | _ -> - let toInterpValueName = concat [string (zencode_string (string_of_id id)); string "ToInterpValue"] in + let toInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "ToInterpValue"] in let toInterpValue = prefix 2 1 (separate space [string "let"; toInterpValueName; separate space (toValueTypqs typq @ [string "v"]); equals; string "match v with"]) ((separate_map hardline (fun (Tu_aux (Tu_ty_id (typ, ctor_id), _)) -> separate space - [pipe; string (zencode_upper_string (string_of_id ctor_id)); toValueArgs typ; + [pipe; string (maybe_zencode_upper (string_of_id ctor_id)); toValueArgs typ; arrow; string "V_ctor"; parens (concat [dquotes (string (string_of_id ctor_id)); comma_sp; toValueVals typ]) ] ) @@ -220,25 +239,36 @@ let tointerp_typedef (TD_aux (td_aux, (l, _))) = toInterpValue ^^ (twice hardline) end | TD_abbrev (id, typq, typ_arg) -> - let toInterpValueName = concat [string (zencode_string (string_of_id id)); string "ToInterpValue"] in + let toInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "ToInterpValue"] in let toInterpValue = (separate space [string "let"; toInterpValueName; separate space (toValueTypqs typq); equals; toValueTypArg typ_arg]) in toInterpValue ^^ (twice hardline) | TD_enum (id, ids, _) -> - let toInterpValueName = concat [string (zencode_string (string_of_id id)); string "ToInterpValue"] in + let toInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "ToInterpValue"] in let toInterpValue = prefix 2 1 (separate space [string "let"; toInterpValueName; string "v"; equals; string "match v with"]) ((separate_map hardline (fun id -> separate space - [pipe; string (zencode_upper_string (string_of_id id)); + [pipe; string (maybe_zencode_upper (string_of_id id)); arrow; string "V_ctor"; parens (concat [dquotes (string (string_of_id id)); comma_sp; string "[]"])] ) ids)) in toInterpValue ^^ (twice hardline) + | TD_record (id, typq, fields, _) -> + let toInterpField (typ, id) = + parens (separate comma_sp [dquotes (string (string_of_id id)); toValueTyp typ ("r." ^ (maybe_zencode (string_of_id id)))]) + in + let toInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "ToInterpValue"] in + let toInterpValue = + prefix 2 1 + (separate space [string "let"; toInterpValueName; separate space (toValueTypqs typq @ [string "r"]); equals]) + (separate space [string "V_record"; parens (separate space [string "List.fold_left (fun m (k, v) -> StringMap.add k v m) StringMap.empty"; (brackets (separate_map (semi ^^ space) toInterpField fields))])]) + in + toInterpValue ^^ (twice hardline) | _ -> empty @@ -257,9 +287,8 @@ let tofrominterp_defs name (Defs defs) = let tofrominterp_pp_defs name f defs = ToChannel.pretty 1. 80 f (tofrominterp_defs name defs) -let tofrominterp_output name defs = - let out_chan = open_out (name ^ "_toFromInterp.ml") in +let tofrominterp_output maybe_dir name defs = + let dir = match maybe_dir with Some dir -> dir | None -> "." in + let out_chan = open_out (Filename.concat dir (name ^ "_toFromInterp.ml")) in tofrominterp_pp_defs name out_chan defs; close_out out_chan - - diff --git a/src/toFromInterp_lib.ml b/src/toFromInterp_lib.ml index b045e4e8..5e776853 100644 --- a/src/toFromInterp_lib.ml +++ b/src/toFromInterp_lib.ml @@ -16,17 +16,67 @@ let zunitFromInterpValue v = match v with let zunitToInterpValue () = V_unit +let unitFromInterpValue = zunitFromInterpValue +let unitToInterpValue = zunitToInterpValue let zatomFromInterpValue typq_'n v = match v with - | V_int i -> - assert (typq_'n = i); - i + | V_int i when typq_'n = i -> i | _ -> failwith "invalid interpreter value for atom" let zatomToInterpValue typq_'n v = assert (typq_'n = v); V_int v +let atomFromInterpValue = zatomFromInterpValue +let atomToInterpValue = zatomToInterpValue + +let zintFromInterpValue v = match v with + | V_int i -> i + | _ -> failwith "invalid interpreter value for int" + +let zintToInterpValue v = V_int v + +let intFromInterpValue = zintFromInterpValue +let intToInterpValue = zintToInterpValue + +let znatFromInterpValue v = match v with + | V_int i when i >= Big_int.zero -> i + | _ -> failwith "invalid interpreter value for nat" + +let znatToInterpValue v = + assert (v >= Big_int.zero); + V_int v + +let natFromInterpValue = znatFromInterpValue +let natToInterpValue = znatToInterpValue + + +let zboolFromInterpValue v = match v with + | V_bool b -> b + | _ -> failwith "invalid interpreter value for bool" + +let zboolToInterpValue v = V_bool v + +let boolFromInterpValue = zboolFromInterpValue +let boolToInterpValue = zboolToInterpValue + +let zstringFromInterpValue v = match v with + | V_string s -> s + | _ -> failwith "invalid interpreter value for string" + +let zstringToInterpValue v = V_string v + +let stringFromInterpValue = zstringFromInterpValue +let stringToInterpValue = zstringToInterpValue + +let zlistFromInterpValue typq_'a v = match v with + | V_list vs -> List.map typq_'a vs + | _ -> failwith "invalid interpreter value for list" + +let zlistToInterpValue typq_'a v = V_list (List.map typq_'a v) + +let listFromInterpValue = zlistFromInterpValue +let listToInterpValue = zlistToInterpValue let zvectorFromInterpValue typq_'n typq_'ord typq_'a v = match v with | V_vector vs -> @@ -38,9 +88,14 @@ let zvectorToInterpValue typq_'n typq_'ord typq_'a v = assert (Big_int.of_int (List.length v) = typq_'n); V_vector (List.map typq_'a v) +let vectorFromInterpValue = zvectorFromInterpValue +let vectorToInterpValue = zvectorToInterpValue let zbitFromInterpValue v = match v with | V_bit b -> b | _ -> failwith "invalid interpreter value for bit" let zbitToInterpValue v = V_bit v + +let bitFromInterpValue = zbitFromInterpValue +let bitToInterpValue = zbitToInterpValue -- cgit v1.2.3 From a7a3402ce155f13234d2d3e5198e5dbf6e0e8b82 Mon Sep 17 00:00:00 2001 From: Jon French Date: Mon, 4 Mar 2019 14:19:44 +0000 Subject: Type_check: make prover reference in env an option defaulting to None Also: * Rename add_prover to set_prover * Make set_prover public This is to support being able to marshal out typecheck envs. RMEM (or other users) can temporarily set the prover reference to None to avoid attempting to marshal a functional value, and then reset it to Some (Type_check.prove ...) on unmarshalling. --- src/type_check.ml | 12 ++++++------ src/type_check.mli | 2 ++ 2 files changed, 8 insertions(+), 6 deletions(-) (limited to 'src') diff --git a/src/type_check.ml b/src/type_check.ml index b43e17ed..1923a885 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -124,7 +124,7 @@ type env = default_order : order option; ret_typ : typ option; poly_undefineds : bool; - prove : env -> n_constraint -> bool; + prove : (env -> n_constraint -> bool) option; allow_unknowns : bool; } @@ -449,7 +449,7 @@ module Env : sig which is defined below. To break the circularity this would cause (as the prove code depends on the environment), we add a reference to the prover to the initial environment. *) - val add_prover : (t -> n_constraint -> bool) -> t -> t + val set_prover : (t -> n_constraint -> bool) option -> t -> t (* This must not be exported, initial_env sets up a correct initial environment. *) @@ -484,11 +484,11 @@ end = struct default_order = None; ret_typ = None; poly_undefineds = false; - prove = (fun _ _ -> false); + prove = None; allow_unknowns = false; } - let add_prover f env = { env with prove = f } + let set_prover f env = { env with prove = f } let allow_unknowns env = env.allow_unknowns let set_allow_unknowns b env = { env with allow_unknowns = b } @@ -582,7 +582,7 @@ end = struct | _, _ -> typ_error env Parse_ast.Unknown ("Error when processing type quantifer arguments " ^ string_of_typquant typq) in let ncs = subst_args kopts args in - if List.for_all (env.prove env) ncs + if (match env.prove with Some prover -> List.for_all (prover env) ncs | None -> false) then () else typ_error env (id_loc id) ("Could not prove " ^ string_of_list ", " string_of_n_constraint ncs ^ " for type constructor " ^ string_of_id id) @@ -4945,7 +4945,7 @@ and check_with_envs : 'a. Env.t -> 'a def list -> (tannot def list * Env.t) list let initial_env = Env.empty - |> Env.add_prover (prove __POS__) + |> Env.set_prover (Some (prove __POS__)) (* |> Env.add_typ_synonym (mk_id "atom") (fun _ args -> mk_typ (Typ_app (mk_id "range", args @ args))) *) (* Internal functions for Monomorphise.AtomToItself *) diff --git a/src/type_check.mli b/src/type_check.mli index 5ab986d0..ba7521fa 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -212,6 +212,8 @@ module Env : sig val builtin_typs : typquant Bindings.t val get_union_id : id -> t -> typquant * typ + + val set_prover : (t -> n_constraint -> bool) option -> t -> t end (** Push all the type variables and constraints from a typquant into -- cgit v1.2.3 From 22b7df6b4c0bc19331dfdf826a6c81131318820a Mon Sep 17 00:00:00 2001 From: Jon French Date: Mon, 4 Mar 2019 14:28:56 +0000 Subject: fix old extern type usage in Specialize --- src/specialize.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/specialize.ml b/src/specialize.ml index 19c5df7a..17d04a46 100644 --- a/src/specialize.ml +++ b/src/specialize.ml @@ -60,7 +60,7 @@ let is_typ_ord_arg = function type specialization = { is_polymorphic : kinded_id -> bool; instantiation_filter : kid -> typ_arg -> bool; - extern_filter : (string -> string option) -> bool + extern_filter : (string * string) list -> bool } let typ_ord_specialization = { @@ -72,7 +72,7 @@ let typ_ord_specialization = { let int_specialization = { is_polymorphic = is_int_kopt; instantiation_filter = (fun _ arg -> match arg with A_aux (A_nexp _, _) -> true | _ -> false); - extern_filter = (fun externs -> match externs "c" with Some _ -> true | None -> false) + extern_filter = (fun externs -> match Ast_util.extern_assoc "c" externs with Some _ -> true | None -> false) } let int_specialization_with_externs = { -- cgit v1.2.3 From af554830c63856f211e9d8245cc2dd7312957021 Mon Sep 17 00:00:00 2001 From: Jon French Date: Mon, 4 Mar 2019 16:13:54 +0000 Subject: Interpreter: remove useless string-to-rk/wk/bk functions, they're much better suited in RMEM --- src/interpreter.ml | 55 ------------------------------------------------------ 1 file changed, 55 deletions(-) (limited to 'src') diff --git a/src/interpreter.ml b/src/interpreter.ml index 737f937e..b9cc9191 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -740,61 +740,6 @@ let rec ast_letbinds (Defs defs) = | DEF_val lb :: defs -> lb :: ast_letbinds (Defs defs) | _ :: defs -> ast_letbinds (Defs defs) -let rk_of_string = function - | "Read_plain" -> Sail2_instr_kinds.Read_plain - | "Read_reserve" -> Sail2_instr_kinds.Read_reserve - | "Read_acquire" -> Sail2_instr_kinds.Read_acquire - | "Read_exclusive" -> Sail2_instr_kinds.Read_exclusive - | "Read_exclusive_acquire" -> Sail2_instr_kinds.Read_exclusive_acquire - | "Read_stream" -> Sail2_instr_kinds.Read_stream - | "Read_RISCV_acquire" -> Sail2_instr_kinds.Read_RISCV_acquire - | "Read_RISCV_strong_acquire" -> Sail2_instr_kinds.Read_RISCV_strong_acquire - | "Read_RISCV_reserved" -> Sail2_instr_kinds.Read_RISCV_reserved - | "Read_RISCV_reserved_acquire" -> Sail2_instr_kinds.Read_RISCV_reserved_acquire - | "Read_RISCV_reserved_strong_acquire" -> Sail2_instr_kinds.Read_RISCV_reserved_strong_acquire - | "Read_X86_locked" -> Sail2_instr_kinds.Read_X86_locked - | s -> failwith ("Unknown read kind: " ^ s) - -let wk_of_string = function - | "Write_plain" -> Sail2_instr_kinds.Write_plain - | "Write_conditional" -> Sail2_instr_kinds.Write_conditional - | "Write_release" -> Sail2_instr_kinds.Write_release - | "Write_exclusive" -> Sail2_instr_kinds.Write_exclusive - | "Write_exclusive_release" -> Sail2_instr_kinds.Write_exclusive_release - | "Write_RISCV_release" -> Sail2_instr_kinds.Write_RISCV_release - | "Write_RISCV_strong_release" -> Sail2_instr_kinds.Write_RISCV_strong_release - | "Write_RISCV_conditional" -> Sail2_instr_kinds.Write_RISCV_conditional - | "Write_RISCV_conditional_release" -> Sail2_instr_kinds.Write_RISCV_conditional_release - | "Write_RISCV_conditional_strong_release" -> Sail2_instr_kinds.Write_RISCV_conditional_strong_release - | "Write_X86_locked" -> Sail2_instr_kinds.Write_X86_locked - | s -> failwith ("Unknown write kind: " ^ s) - -let bk_of_string = function - | "Barrier_Sync" -> Sail2_instr_kinds.Barrier_Sync - | "Barrier_LwSync" -> Sail2_instr_kinds.Barrier_LwSync - | "Barrier_Eieio" -> Sail2_instr_kinds.Barrier_Eieio - | "Barrier_Isync" -> Sail2_instr_kinds.Barrier_Isync - | "Barrier_DMB" -> Sail2_instr_kinds.Barrier_DMB - | "Barrier_DMB_ST" -> Sail2_instr_kinds.Barrier_DMB_ST - | "Barrier_DMB_LD" -> Sail2_instr_kinds.Barrier_DMB_LD - | "Barrier_DSB" -> Sail2_instr_kinds.Barrier_DSB - | "Barrier_DSB_ST" -> Sail2_instr_kinds.Barrier_DSB_ST - | "Barrier_DSB_LD" -> Sail2_instr_kinds.Barrier_DSB_LD - | "Barrier_ISB" -> Sail2_instr_kinds.Barrier_ISB - | "Barrier_MIPS_SYNC" -> Sail2_instr_kinds.Barrier_MIPS_SYNC - | "Barrier_RISCV_rw_rw" -> Sail2_instr_kinds.Barrier_RISCV_rw_rw - | "Barrier_RISCV_r_rw" -> Sail2_instr_kinds.Barrier_RISCV_r_rw - | "Barrier_RISCV_r_r" -> Sail2_instr_kinds.Barrier_RISCV_r_r - | "Barrier_RISCV_rw_w" -> Sail2_instr_kinds.Barrier_RISCV_rw_w - | "Barrier_RISCV_w_w" -> Sail2_instr_kinds.Barrier_RISCV_w_w - | "Barrier_RISCV_w_rw" -> Sail2_instr_kinds.Barrier_RISCV_w_rw - | "Barrier_RISCV_rw_r" -> Sail2_instr_kinds.Barrier_RISCV_rw_r - | "Barrier_RISCV_r_w" -> Sail2_instr_kinds.Barrier_RISCV_r_w - | "Barrier_RISCV_w_r" -> Sail2_instr_kinds.Barrier_RISCV_w_r - | "Barrier_RISCV_i" -> Sail2_instr_kinds.Barrier_RISCV_i - | "Barrier_x86_MFENCE" -> Sail2_instr_kinds.Barrier_x86_MFENCE - | s -> failwith ("Unknown barrier kind: " ^ s) - let initial_lstate = { locals = Bindings.empty } -- cgit v1.2.3 From 48266097a2ffc005bb6005328e7ea1e52df904eb Mon Sep 17 00:00:00 2001 From: Jon French Date: Mon, 4 Mar 2019 16:14:15 +0000 Subject: Marshalling: remove prover before marshalling --- src/sail.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/sail.ml b/src/sail.ml index eb25f56d..d97cbd22 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -487,10 +487,10 @@ let main() = (if !(opt_marshal_defs) then begin - let ast_marshal = rewrite_ast_ocaml type_envs ast in + let ast_marshal = rewrite_ast_interpreter type_envs ast in let out_filename = match !opt_file_out with None -> "out" | Some s -> s in let f = open_out_bin (out_filename ^ ".defs") in - Marshal.to_string ast_marshal [Marshal.No_sharing; Marshal.Compat_32] + Marshal.to_string (ast_marshal, Type_check.Env.set_prover None type_envs) [Marshal.No_sharing; Marshal.Compat_32] |> B64.encode |> output_string f; close_out f -- cgit v1.2.3 From 686c874d22ab3446024897098de5c4abf713563c Mon Sep 17 00:00:00 2001 From: Jon French Date: Mon, 4 Mar 2019 17:17:12 +0000 Subject: Type_check: functions env/typ_of_tannot --- src/type_check.ml | 8 ++++++++ src/type_check.mli | 2 ++ 2 files changed, 10 insertions(+) (limited to 'src') diff --git a/src/type_check.ml b/src/type_check.ml index 37a152d4..25ebb24e 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -2392,6 +2392,14 @@ let env_of_annot (l, tannot) = match tannot with | Some t -> t.env | None -> raise (Reporting.err_unreachable l __POS__ "no type annotation") +let env_of_tannot tannot = match tannot with + | Some t -> t.env + | None -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "no type annotation") + +let typ_of_tannot tannot = match tannot with + | Some t -> t.typ + | None -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "no type annotation") + let env_of (E_aux (_, (l, tannot))) = env_of_annot (l, tannot) let typ_of_annot (l, tannot) = match tannot with diff --git a/src/type_check.mli b/src/type_check.mli index bd4c88dc..048f5cb4 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -347,9 +347,11 @@ val typ_error : Env.t -> Ast.l -> string -> 'a val env_of : tannot exp -> Env.t val env_of_annot : Ast.l * tannot -> Env.t +val env_of_tannot : tannot -> Env.t val typ_of : tannot exp -> typ val typ_of_annot : Ast.l * tannot -> typ +val typ_of_tannot : tannot -> typ val typ_of_pat : tannot pat -> typ val env_of_pat : tannot pat -> Env.t -- cgit v1.2.3 From 1fc69968a831305f2db43544b503fffc9b4106cc Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 13 Mar 2019 16:14:06 +0000 Subject: package and install Sail as an ocamlfind library --- src/META | 6 ++++++ src/Makefile | 3 ++- src/libsail.mllib | 57 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 65 insertions(+), 1 deletion(-) create mode 100644 src/META create mode 100644 src/libsail.mllib (limited to 'src') diff --git a/src/META b/src/META new file mode 100644 index 00000000..80194d98 --- /dev/null +++ b/src/META @@ -0,0 +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" +version = "0.8" +archive(byte) = "libsail.cma" +archive(native) = "libsail.cmxa" diff --git a/src/Makefile b/src/Makefile index abf49423..146addbe 100644 --- a/src/Makefile +++ b/src/Makefile @@ -103,7 +103,8 @@ sail: ast.ml bytecode.ml manifest.ml ocamlbuild -use-ocamlfind sail.native sail_lib.cma sail_lib.cmxa isail: ast.ml bytecode.ml manifest.ml - ocamlbuild -use-ocamlfind isail.native + ocamlbuild -use-ocamlfind isail.native sail_lib.cma sail_lib.cmxa libsail.cma libsail.cmxa + coverage: ast.ml bytecode.ml manifest.ml BISECT_COVERAGE=YES ocamlbuild -use-ocamlfind -plugin-tag 'package(bisect_ppx-ocamlbuild)' isail.native diff --git a/src/libsail.mllib b/src/libsail.mllib new file mode 100644 index 00000000..c85ddba3 --- /dev/null +++ b/src/libsail.mllib @@ -0,0 +1,57 @@ +Anf +Ast +Ast_util +Bitfield +Bytecode +Bytecode_interpreter +Bytecode_util +C_backend +Cgen_backend +Constant_fold +Constraint +Elf_loader +Error_format +Graph +Initial_check +Interactive +Interpreter +Isail +Latex +Lexer +Manifest +Monomorphise +Nl_flow +Ocaml_backend +Optimize +Parse_ast +Parser +Pattern_completeness +PPrint +PPrintCombinators +PPrintEngine +PPrintRenderer +PPrintOCaml +Pretty_print +Pretty_print_common +Pretty_print_coq +Pretty_print_lem +Pretty_print_sail +Process_file +Profile +Reporting +Rewriter +Rewrites +Sail +Sail2_values +Sail_lib +Scattered +Share_directory +Spec_analysis +Specialize +State +ToFromInterp_backend +ToFromInterp_lib +Type_check +Type_error +Util +Value -- cgit v1.2.3 From 76fd5c893e71a018d62007fa434155ee7eb6932b Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 13 Mar 2019 16:34:01 +0000 Subject: Remove prover reference from typecheck env when marshalling out defs --- src/ast_util.ml | 74 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/ast_util.mli | 10 ++++++++ src/sail.ml | 10 ++++++-- 3 files changed, 92 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index 548cd15e..526d3845 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -619,6 +619,80 @@ and map_lexp_annot_aux f = function | LEXP_vector_range (lexp, exp1, exp2) -> LEXP_vector_range (map_lexp_annot f lexp, map_exp_annot f exp1, map_exp_annot f exp2) | LEXP_field (lexp, id) -> LEXP_field (map_lexp_annot f lexp, id) +and map_typedef_annot f = function + | TD_aux (td_aux, annot) -> TD_aux (td_aux, f annot) + +and map_fundef_annot f = function + | FD_aux (fd_aux, annot) -> FD_aux (map_fundef_annot_aux f fd_aux, f annot) +and map_fundef_annot_aux f = function + | FD_function (rec_opt, tannot_opt, eff_opt, funcls) -> FD_function (map_recopt_annot f rec_opt, tannot_opt, eff_opt, + List.map (map_funcl_annot f) funcls) +and map_funcl_annot f = function + | FCL_aux (fcl, annot) -> FCL_aux (map_funcl_annot_aux f fcl, f annot) +and map_funcl_annot_aux f = function + | FCL_Funcl (id, pexp) -> FCL_Funcl (id, map_pexp_annot f pexp) +and map_recopt_annot f = function + | Rec_aux (rec_aux, l) -> Rec_aux (map_recopt_annot_aux f rec_aux, l) +and map_recopt_annot_aux f = function + | Rec_nonrec -> Rec_nonrec + | Rec_rec -> Rec_rec + | Rec_measure (pat, exp) -> Rec_measure (map_pat_annot f pat, map_exp_annot f exp) + +and map_mapdef_annot f = function + | MD_aux (md_aux, annot) -> MD_aux (map_mapdef_annot_aux f md_aux, f annot) +and map_mapdef_annot_aux f = function + | MD_mapping (id, tannot_opt, mapcls) -> MD_mapping (id, tannot_opt, List.map (map_mapcl_annot f) mapcls) + +and map_valspec_annot f = function + | VS_aux (vs_aux, annot) -> VS_aux (vs_aux, f annot) + +and map_scattered_annot f = function + | SD_aux (sd_aux, annot) -> SD_aux (map_scattered_annot_aux f sd_aux, f annot) +and map_scattered_annot_aux f = function + | SD_function (rec_opt, tannot_opt, eff_opt, name) -> SD_function (map_recopt_annot f rec_opt, tannot_opt, eff_opt, name) + | SD_funcl fcl -> SD_funcl (map_funcl_annot f fcl) + | SD_variant (id, typq) -> SD_variant (id, typq) + | SD_unioncl (id, tu) -> SD_unioncl (id, tu) + | SD_mapping (id, tannot_opt) -> SD_mapping (id, tannot_opt) + | SD_mapcl (id, mcl) -> SD_mapcl (id, map_mapcl_annot f mcl) + | SD_end id -> SD_end id + +and map_decspec_annot f = function + | DEC_aux (dec_aux, annot) -> DEC_aux (map_decspec_annot_aux f dec_aux, f annot) +and map_decspec_annot_aux f = function + | DEC_reg (eff1, eff2, typ, id) -> DEC_reg (eff1, eff2, typ, id) + | DEC_config (id, typ, exp) -> DEC_config (id, typ, map_exp_annot f exp) + | DEC_alias (id, als) -> DEC_alias (id, map_aliasspec_annot f als) + | DEC_typ_alias (typ, id, als) -> DEC_typ_alias (typ, id, map_aliasspec_annot f als) +and map_aliasspec_annot f = function + | AL_aux (al_aux, annot) -> AL_aux (map_aliasspec_annot_aux f al_aux, f annot) +and map_aliasspec_annot_aux f = function + | AL_subreg (reg_id, id) -> AL_subreg (map_regid_annot f reg_id, id) + | AL_bit (reg_id, exp) -> AL_bit (map_regid_annot f reg_id, map_exp_annot f exp) + | AL_slice (reg_id, exp1, exp2) -> AL_slice (map_regid_annot f reg_id, map_exp_annot f exp1, map_exp_annot f exp2) + | AL_concat (reg_id1, reg_id2) -> AL_concat (map_regid_annot f reg_id1, map_regid_annot f reg_id2) +and map_regid_annot f = function + | RI_aux (ri_aux, annot) -> RI_aux (map_regid_annot_aux f ri_aux, f annot) +and map_regid_annot_aux f = function + | RI_id id -> RI_id id + +and map_def_annot f = function + | DEF_type td -> DEF_type (map_typedef_annot f td) + | DEF_fundef fd -> DEF_fundef (map_fundef_annot f fd) + | DEF_mapdef md -> DEF_mapdef (map_mapdef_annot f md) + | DEF_val lb -> DEF_val (map_letbind_annot f lb) + | DEF_spec vs -> DEF_spec (map_valspec_annot f vs) + | DEF_fixity (prec, n, id) -> DEF_fixity (prec, n, id) + | DEF_overload (name, overloads) -> DEF_overload (name, overloads) + | DEF_default ds -> DEF_default ds + | DEF_scattered sd -> DEF_scattered (map_scattered_annot f sd) + | DEF_measure (id, pat, exp) -> DEF_measure (id, map_pat_annot f pat, map_exp_annot f exp) + | DEF_reg_dec ds -> DEF_reg_dec (map_decspec_annot f ds) + | DEF_internal_mutrec fds -> DEF_internal_mutrec (List.map (map_fundef_annot f) fds) + | DEF_pragma (name, arg, l) -> DEF_pragma (name, arg, l) +and map_defs_annot f = function + | Defs defs -> Defs (List.map (map_def_annot f) defs) + let id_loc = function | Id_aux (_, l) -> l diff --git a/src/ast_util.mli b/src/ast_util.mli index bef4a238..6cc4e8a5 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -205,6 +205,16 @@ val map_mfpat_annot : ('a annot -> 'b annot) -> 'a mfpat -> 'b mfpat val map_mpexp_annot : ('a annot -> 'b annot) -> 'a mpexp -> 'b mpexp val map_mapcl_annot : ('a annot -> 'b annot) -> 'a mapcl -> 'b mapcl +val map_typedef_annot : ('a annot -> 'b annot) -> 'a type_def -> 'b type_def +val map_fundef_annot : ('a annot -> 'b annot) -> 'a fundef -> 'b fundef +val map_funcl_annot : ('a annot -> 'b annot) -> 'a funcl -> 'b funcl +val map_mapdef_annot : ('a annot -> 'b annot) -> 'a mapdef -> 'b mapdef +val map_valspec_annot : ('a annot -> 'b annot) -> 'a val_spec -> 'b val_spec +val map_scattered_annot : ('a annot -> 'b annot) -> 'a scattered_def -> 'b scattered_def + +val map_def_annot : ('a annot -> 'b annot) -> 'a def -> 'b def +val map_defs_annot : ('a annot -> 'b annot) -> 'a defs -> 'b defs + (* Extract locations from identifiers *) val id_loc : id -> Parse_ast.l val kid_loc : kid -> Parse_ast.l diff --git a/src/sail.ml b/src/sail.ml index 9cd4d352..82f8b8f2 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -140,7 +140,7 @@ let options = Arg.align ([ Arg.Clear Latex.opt_simple_val, " print full valspecs in LaTeX output"); ( "-marshal", - Arg.Set opt_marshal_defs, + Arg.Tuple [Arg.Set opt_marshal_defs; Arg.Set Initial_check.opt_undefined_gen], " OCaml-marshal out the rewritten AST to a file"); ( "-c", Arg.Tuple [Arg.Set opt_print_c; Arg.Set Initial_check.opt_undefined_gen], @@ -490,7 +490,13 @@ let main() = let ast_marshal = rewrite_ast_interpreter type_envs ast in let out_filename = match !opt_file_out with None -> "out" | Some s -> s in let f = open_out_bin (out_filename ^ ".defs") in - Marshal.to_string (ast_marshal, Type_check.Env.set_prover None type_envs) [Marshal.No_sharing; Marshal.Compat_32] + let remove_prover (l, tannot) = + if Type_check.is_empty_tannot tannot then + (l, Type_check.empty_tannot) + else + (l, Type_check.replace_env (Type_check.Env.set_prover None (Type_check.env_of_tannot tannot)) tannot) + in + Marshal.to_string (Ast_util.map_defs_annot remove_prover ast_marshal, Type_check.Env.set_prover None type_envs) [Marshal.Compat_32] |> B64.encode |> output_string f; close_out f -- cgit v1.2.3 From 949964e09c0f53fdbf82f39f79e9c3cda2f92a6f Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 13 Mar 2019 16:53:27 +0000 Subject: Finish toFromInterp backend, adding Lem mode --- src/toFromInterp_backend.ml | 139 +++++++++++++++++++++++++++----------------- src/toFromInterp_lib.ml | 25 ++++++++ 2 files changed, 112 insertions(+), 52 deletions(-) (limited to 'src') diff --git a/src/toFromInterp_backend.ml b/src/toFromInterp_backend.ml index 5a03ca83..e35af091 100644 --- a/src/toFromInterp_backend.ml +++ b/src/toFromInterp_backend.ml @@ -58,12 +58,12 @@ open Ocaml_backend let lem_mode = ref false -let maybe_zencode s = if !lem_mode then s else zencode_string s +let maybe_zencode s = if !lem_mode then String.uncapitalize_ascii s else zencode_string s let maybe_zencode_upper s = if !lem_mode then String.capitalize_ascii s else zencode_upper_string s let frominterp_typedef (TD_aux (td_aux, (l, _))) = let fromValueArgs (Typ_aux (typ_aux, _)) = match typ_aux with - | Typ_tup typs -> brackets (separate (semi ^^ space) (List.mapi (fun i _ -> string ("v" ^ (string_of_int i))) typs)) + | Typ_tup typs -> brackets (separate space [string "V_tuple"; brackets (separate (semi ^^ space) (List.mapi (fun i _ -> string ("v" ^ (string_of_int i))) typs))]) | _ -> brackets (string "v0") in let fromValueKid (Kid_aux ((Var name), _)) = @@ -81,6 +81,11 @@ let frominterp_typedef (TD_aux (td_aux, (l, _))) = | _ -> string "TYP_ARG" and fromValueTyp ((Typ_aux (typ_aux, l)) as typ) arg_name = match typ_aux with | Typ_id id -> parens (concat [string (maybe_zencode (string_of_id id)); string ("FromInterpValue"); space; string arg_name]) + (* special case bit vectors for lem *) + | Typ_app (Id_aux (Id "vector", _), [A_aux (A_nexp len_nexp, _); + A_aux (A_order (Ord_aux (Ord_dec, _)), _); + A_aux (A_typ (Typ_aux (Typ_id (Id_aux (Id "bit", _)), _)), _)]) when !lem_mode -> + parens (separate space ([string (maybe_zencode "bitsFromInterpValue"); fromValueNexp len_nexp; string arg_name])) | Typ_app (typ_id, typ_args) -> assert (typ_args <> []); parens (separate space ([string (maybe_zencode (string_of_id typ_id) ^ "FromInterpValue")] @ List.map fromValueTypArg typ_args @ [string arg_name])) @@ -108,37 +113,48 @@ let frominterp_typedef (TD_aux (td_aux, (l, _))) = | Id_aux ((Id "barrier_kind"),_) -> empty | Id_aux ((Id "trans_kind"),_) -> empty | Id_aux ((Id "instruction_kind"),_) -> empty - (* | Id_aux ((Id "regfp"),_) -> empty - | Id_aux ((Id "niafp"),_) -> empty - | Id_aux ((Id "diafp"),_) -> empty *) + | Id_aux ((Id "regfp"),_) -> empty + | Id_aux ((Id "regfps"),_) -> empty + | Id_aux ((Id "niafp"),_) -> empty + | Id_aux ((Id "niafps"),_) -> empty + | Id_aux ((Id "diafp"),_) -> empty + | Id_aux ((Id "diafps"),_) -> empty (* | Id_aux ((Id "option"),_) -> empty *) - | _ -> - let fromInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "FromInterpValue"] in - let fromFallback = separate space [pipe; underscore; arrow; string "failwith"; - dquotes (string ("invalid interpreter value for " ^ (string_of_id id)))] in - let fromInterpValue = - prefix 2 1 - (separate space [string "let"; fromInterpValueName; separate space (fromValueTypqs typq @ [string "v"]); equals; string "match v with"]) - ((separate_map hardline - (fun (Tu_aux (Tu_ty_id (typ, ctor_id), _)) -> - separate space - [pipe; string "V_ctor"; parens (concat [dquotes (string (string_of_id ctor_id)); comma_sp; - fromValueArgs typ - ]); - arrow; string (maybe_zencode_upper (string_of_id ctor_id)); fromValueVals typ - ] - ) - arms) - ^^ hardline ^^ fromFallback) - in - fromInterpValue ^^ (twice hardline) + | Id_aux ((Id id_string), _) + | Id_aux ((DeIid id_string), _) -> + if !lem_mode && id_string = "option" then empty else + let fromInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "FromInterpValue"] in + let fromFallback = separate space [pipe; underscore; arrow; string "failwith"; + dquotes (string ("invalid interpreter value for " ^ (string_of_id id)))] in + let fromInterpValue = + prefix 2 1 + (separate space [string "let"; fromInterpValueName; separate space (fromValueTypqs typq @ [string "v"]); equals; string "match v with"]) + ((separate_map hardline + (fun (Tu_aux (Tu_ty_id (typ, ctor_id), _)) -> + separate space + [pipe; string "V_ctor"; parens (concat [dquotes (string (string_of_id ctor_id)); comma_sp; + fromValueArgs typ + ]); + arrow; string (maybe_zencode_upper (string_of_id ctor_id)); fromValueVals typ + ] + ) + arms) + ^^ hardline ^^ fromFallback) + in + fromInterpValue ^^ (twice hardline) end + | TD_abbrev (Id_aux (Id "regfps", _), _, _) -> empty + | TD_abbrev (Id_aux (Id "niafps", _), _, _) -> empty | TD_abbrev (id, typq, typ_arg) -> let fromInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "FromInterpValue"] in let fromInterpValue = (separate space [string "let"; fromInterpValueName; separate space (fromValueTypqs typq); equals; fromValueTypArg typ_arg]) in fromInterpValue ^^ (twice hardline) + | TD_enum (Id_aux (Id "read_kind", _), _, _) -> empty + | TD_enum (Id_aux (Id "write_kind", _), _, _) -> empty + | TD_enum (Id_aux (Id "barrier_kind", _), _, _) -> empty + | TD_enum (Id_aux (Id "trans_kind", _), _, _) -> empty | TD_enum (id, ids, _) -> let fromInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "FromInterpValue"] in let fromFallback = separate space [pipe; underscore; arrow; string "failwith"; @@ -156,13 +172,13 @@ let frominterp_typedef (TD_aux (td_aux, (l, _))) = ^^ hardline ^^ fromFallback) in fromInterpValue ^^ (twice hardline) - | TD_record (id, typq, fields, _) -> + | TD_record (record_id, typq, fields, _) -> let fromInterpField (typ, id) = - separate space [string (maybe_zencode (string_of_id id)); equals; fromValueTyp typ ("(StringMap.find \"" ^ (string_of_id id) ^ "\" fs)")] + separate space [string (maybe_zencode ((if !lem_mode then string_of_id record_id ^ "_" else "") ^ string_of_id id)); equals; fromValueTyp typ ("(StringMap.find \"" ^ (string_of_id id) ^ "\" fs)")] in - let fromInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "FromInterpValue"] in + let fromInterpValueName = concat [string (maybe_zencode (string_of_id record_id)); string "FromInterpValue"] in let fromFallback = separate space [pipe; underscore; arrow; string "failwith"; - dquotes (string ("invalid interpreter value for " ^ (string_of_id id)))] in + dquotes (string ("invalid interpreter value for " ^ (string_of_id record_id)))] in let fromInterpValue = prefix 2 1 (separate space [string "let"; fromInterpValueName; separate space (fromValueTypqs typq @ [string "v"]); equals; string "match v with"]) @@ -192,6 +208,11 @@ let tointerp_typedef (TD_aux (td_aux, (l, _))) = | _ -> string "TYP_ARG" and toValueTyp ((Typ_aux (typ_aux, l)) as typ) arg_name = match typ_aux with | Typ_id id -> parens (concat [string (maybe_zencode (string_of_id id)); string "ToInterpValue"; space; string arg_name]) + (* special case bit vectors for lem *) + | Typ_app (Id_aux (Id "vector", _), [A_aux (A_nexp len_nexp, _); + A_aux (A_order (Ord_aux (Ord_dec, _)), _); + A_aux (A_typ (Typ_aux (Typ_id (Id_aux (Id "bit", _)), _)), _)]) when !lem_mode -> + parens (separate space ([string (maybe_zencode "bitsToInterpValue"); toValueNexp len_nexp; string arg_name])) | Typ_app (typ_id, typ_args) -> assert (typ_args <> []); parens (separate space ([string ((maybe_zencode (string_of_id typ_id)) ^ "ToInterpValue")] @ List.map toValueTypArg typ_args @ [string arg_name])) @@ -199,7 +220,7 @@ let tointerp_typedef (TD_aux (td_aux, (l, _))) = | _ -> parens (string "failwith \"toValueTyp: type arm unimplemented\"") in let toValueVals ((Typ_aux (typ_aux, _)) as typ) = match typ_aux with - | Typ_tup typs -> brackets (separate (semi ^^ space) (List.mapi (fun i typ -> toValueTyp typ ("v" ^ (string_of_int i))) typs)) + | Typ_tup typs -> brackets (separate space [string "V_tuple"; brackets (separate (semi ^^ space) (List.mapi (fun i typ -> toValueTyp typ ("v" ^ (string_of_int i))) typs))]) | _ -> brackets (toValueTyp typ "v0") in let toValueTypq (QI_aux (qi_aux, _)) = match qi_aux with @@ -218,32 +239,43 @@ let tointerp_typedef (TD_aux (td_aux, (l, _))) = | Id_aux ((Id "barrier_kind"),_) -> empty | Id_aux ((Id "trans_kind"),_) -> empty | Id_aux ((Id "instruction_kind"),_) -> empty - (* | Id_aux ((Id "regfp"),_) -> empty - | Id_aux ((Id "niafp"),_) -> empty - | Id_aux ((Id "diafp"),_) -> empty *) + | Id_aux ((Id "regfp"),_) -> empty + | Id_aux ((Id "regfps"),_) -> empty + | Id_aux ((Id "niafp"),_) -> empty + | Id_aux ((Id "niafps"),_) -> empty + | Id_aux ((Id "diafp"),_) -> empty + | Id_aux ((Id "diafps"),_) -> empty (* | Id_aux ((Id "option"),_) -> empty *) - | _ -> - let toInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "ToInterpValue"] in - let toInterpValue = - prefix 2 1 - (separate space [string "let"; toInterpValueName; separate space (toValueTypqs typq @ [string "v"]); equals; string "match v with"]) - ((separate_map hardline - (fun (Tu_aux (Tu_ty_id (typ, ctor_id), _)) -> - separate space - [pipe; string (maybe_zencode_upper (string_of_id ctor_id)); toValueArgs typ; - arrow; string "V_ctor"; parens (concat [dquotes (string (string_of_id ctor_id)); comma_sp; toValueVals typ]) - ] - ) - arms)) - in - toInterpValue ^^ (twice hardline) + | Id_aux ((Id id_string), _) + | Id_aux ((DeIid id_string), _) -> + if !lem_mode && id_string = "option" then empty else + let toInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "ToInterpValue"] in + let toInterpValue = + prefix 2 1 + (separate space [string "let"; toInterpValueName; separate space (toValueTypqs typq @ [string "v"]); equals; string "match v with"]) + ((separate_map hardline + (fun (Tu_aux (Tu_ty_id (typ, ctor_id), _)) -> + separate space + [pipe; string (maybe_zencode_upper (string_of_id ctor_id)); toValueArgs typ; + arrow; string "V_ctor"; parens (concat [dquotes (string (string_of_id ctor_id)); comma_sp; toValueVals typ]) + ] + ) + arms)) + in + toInterpValue ^^ (twice hardline) end + | TD_abbrev (Id_aux (Id "regfps", _), _, _) -> empty + | TD_abbrev (Id_aux (Id "niafps", _), _, _) -> empty | TD_abbrev (id, typq, typ_arg) -> let toInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "ToInterpValue"] in let toInterpValue = (separate space [string "let"; toInterpValueName; separate space (toValueTypqs typq); equals; toValueTypArg typ_arg]) in toInterpValue ^^ (twice hardline) + | TD_enum (Id_aux (Id "read_kind", _), _, _) -> empty + | TD_enum (Id_aux (Id "write_kind", _), _, _) -> empty + | TD_enum (Id_aux (Id "barrier_kind", _), _, _) -> empty + | TD_enum (Id_aux (Id "trans_kind", _), _, _) -> empty | TD_enum (id, ids, _) -> let toInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "ToInterpValue"] in let toInterpValue = @@ -258,11 +290,11 @@ let tointerp_typedef (TD_aux (td_aux, (l, _))) = ids)) in toInterpValue ^^ (twice hardline) - | TD_record (id, typq, fields, _) -> + | TD_record (record_id, typq, fields, _) -> let toInterpField (typ, id) = - parens (separate comma_sp [dquotes (string (string_of_id id)); toValueTyp typ ("r." ^ (maybe_zencode (string_of_id id)))]) + parens (separate comma_sp [dquotes (string (string_of_id id)); toValueTyp typ ("r." ^ (maybe_zencode ((if !lem_mode then string_of_id record_id ^ "_" else "") ^ string_of_id id)))]) in - let toInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "ToInterpValue"] in + let toInterpValueName = concat [string (maybe_zencode (string_of_id record_id)); string "ToInterpValue"] in let toInterpValue = prefix 2 1 (separate space [string "let"; toInterpValueName; separate space (toValueTypqs typq @ [string "r"]); equals]) @@ -280,7 +312,10 @@ let tofrominterp_defs name (Defs defs) = (string "open Sail_lib;;" ^^ hardline) ^^ (string "open Value;;" ^^ hardline) ^^ (string "open ToFromInterp_lib;;" ^^ hardline) + ^^ (if !lem_mode then (string "open Sail2_instr_kinds;;" ^^ hardline) else empty) ^^ (string ("open " ^ String.capitalize_ascii name ^ ";;") ^^ hardline) + ^^ (if !lem_mode then (string ("open " ^ String.capitalize_ascii name ^ "_types;;") ^^ hardline) else empty) + ^^ (if !lem_mode then (string ("open " ^ String.capitalize_ascii name ^ "_extras;;") ^^ hardline) else empty) ^^ (string "module Big_int = Nat_big_num" ^^ ocaml_def_end) ^^ concat (List.map tofrominterp_def defs) @@ -289,6 +324,6 @@ let tofrominterp_pp_defs name f defs = let tofrominterp_output maybe_dir name defs = let dir = match maybe_dir with Some dir -> dir | None -> "." in - let out_chan = open_out (Filename.concat dir (name ^ "_toFromInterp.ml")) in + let out_chan = open_out (Filename.concat dir (name ^ "_toFromInterp2.ml")) in tofrominterp_pp_defs name out_chan defs; close_out out_chan diff --git a/src/toFromInterp_lib.ml b/src/toFromInterp_lib.ml index 5e776853..c29fcd84 100644 --- a/src/toFromInterp_lib.ml +++ b/src/toFromInterp_lib.ml @@ -9,6 +9,8 @@ type vector_order = | Order_inc | Order_dec +(* zencoded variants are for the OCaml backend, non-zencoded are for the Lem backend compiled to OCaml. + Sometimes they're just aliased. *) let zunitFromInterpValue v = match v with | V_unit -> () @@ -99,3 +101,26 @@ let zbitToInterpValue v = V_bit v let bitFromInterpValue = zbitFromInterpValue let bitToInterpValue = zbitToInterpValue + +let optionFromInterpValue typq_'a v = match v with + | V_ctor ("None", [v0]) -> None + | V_ctor ("Some", [v0]) -> Some (typq_'a v0) + | _ -> failwith "invalid interpreter value for option" + +let optionToInterpValue typq_'a v = match v with + | None -> V_ctor ("None", [(unitToInterpValue ())]) + | Some (v0) -> V_ctor ("Some", [(typq_'a v0)]) + + +let bitsFromInterpValue typq_'n v = match v with + | V_vector vs -> + assert (Big_int.of_int (List.length vs) = typq_'n); + Lem.wordFromBitlist (List.map (fun b -> bitFromInterpValue b |> Sail_lib.bool_of_bit) vs) + | _ -> failwith "invalid interpreter value for bits" + +let bitsToInterpValue typq_'n v = + let bs = Lem.bitlistFromWord v in + assert (Big_int.of_int (List.length bs) = typq_'n); + V_vector (List.map (fun b -> Sail_lib.bit_of_bool b |> bitToInterpValue) bs) + + -- cgit v1.2.3 From 81261ce7a4f91d3d55351f54d979fa5e4b4661ee Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 13 Mar 2019 16:54:03 +0000 Subject: Debugging: string_of_value internal values in string_of_exp --- src/ast_util.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index 526d3845..afd00d3d 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -927,7 +927,7 @@ let rec string_of_exp (E_aux (exp, _)) = | E_internal_return exp -> "internal_return (" ^ string_of_exp exp ^ ")" | E_internal_plet (pat, exp, body) -> "internal_plet " ^ string_of_pat pat ^ " = " ^ string_of_exp exp ^ " in " ^ string_of_exp body | E_nondet _ -> "NONDET" - | E_internal_value _ -> "INTERNAL VALUE" + | E_internal_value v -> "INTERNAL_VALUE(" ^ Value.string_of_value v ^ ")" and string_of_fexp (FE_aux (FE_Fexp (field, exp), _)) = string_of_id field ^ " = " ^ string_of_exp exp -- cgit v1.2.3 From 985a9582a0e780d1ffbe4722653927a3bb860403 Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 13 Mar 2019 17:04:47 +0000 Subject: fix is_true/is_false use of == for web-interface new-interpreter --- src/interpreter.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/interpreter.ml b/src/interpreter.ml index b9cc9191..cad9cc00 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -103,11 +103,11 @@ let is_value = function | _ -> false let is_true = function - | (E_aux (E_internal_value (V_bool b), _)) -> b == true + | (E_aux (E_internal_value (V_bool b), annot)) -> b | _ -> false let is_false = function - | (E_aux (E_internal_value (V_bool b), _)) -> b == false + | (E_aux (E_internal_value (V_bool b), _)) -> not b | _ -> false let exp_of_value v = (E_aux (E_internal_value v, (Parse_ast.Unknown, Type_check.empty_tannot))) -- cgit v1.2.3 From 5151a1e4f0c85da075012be116461cbf7b463c1d Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 13 Mar 2019 17:08:24 +0000 Subject: Refactor interpreter monad to include pp in effect requests/failures --- src/constant_fold.ml | 5 ++++- src/interpreter.ml | 51 +++++++++++++++++++++++++++------------------------ src/isail.ml | 19 +++++++++++++++---- 3 files changed, 46 insertions(+), 29 deletions(-) (limited to 'src') diff --git a/src/constant_fold.ml b/src/constant_fold.ml index 2c46f38b..15772168 100644 --- a/src/constant_fold.ml +++ b/src/constant_fold.ml @@ -123,11 +123,14 @@ and is_constant_fexp (FE_aux (FE_Fexp (_, exp), _)) = is_constant exp let rec run frame = match frame with | Interpreter.Done (state, v) -> v + | Interpreter.Fail _ -> + (* something went wrong, raise exception to abort constant folding *) + assert false | Interpreter.Step (lazy_str, _, _, _) -> run (Interpreter.eval_frame frame) | Interpreter.Break frame -> run (Interpreter.eval_frame frame) - | Interpreter.Effect_request (st, Interpreter.Read_reg (reg, cont)) -> + | Interpreter.Effect_request (out, st, stack, Interpreter.Read_reg (reg, cont)) -> (* return a dummy value to read_reg requests which we handle above if an expression finally evals to it, but the interpreter will fail if it tries to actually use. See value.ml *) diff --git a/src/interpreter.ml b/src/interpreter.ml index cad9cc00..33370816 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -142,7 +142,7 @@ type 'a response = | Read_mem of (* read_kind : *) value * (* address : *) value * (* length : *) value * (value -> 'a) | Write_ea of (* write_kind : *) value * (* address : *) value * (* length : *) value * (unit -> 'a) | Excl_res of (bool -> 'a) - | Write_memv of value * (bool -> 'a) + | Write_mem of (* write_kind : *) value * (* address : *) value * (* length : *) value * (* value : *) value * (bool -> 'a) | Barrier of (* barrier_kind : *) value * (unit -> 'a) | Read_reg of string * (value -> 'a) | Write_reg of string * value * (unit -> 'a) @@ -164,7 +164,7 @@ let map_response f = function | Read_mem (rk, addr, len, cont) -> Read_mem (rk, addr, len, fun v -> f (cont v)) | Write_ea (wk, addr, len, cont) -> Write_ea (wk, addr, len, fun () -> f (cont ())) | Excl_res cont -> Excl_res (fun b -> f (cont b)) - | Write_memv (v, cont) -> Write_memv (v, fun b -> f (cont b)) + | Write_mem (wk, addr, len, v, cont) -> Write_mem (wk, addr, len, v, fun b -> f (cont b)) | Barrier (bk, cont) -> Barrier (bk, fun () -> f (cont ())) | Read_reg (name, cont) -> Read_reg (name, fun v -> f (cont v)) | Write_reg (name, v, cont) -> Write_reg (name, v, fun () -> f (cont ())) @@ -215,8 +215,8 @@ let write_ea wk addr len : unit monad = let excl_res () : bool monad = Yield (Excl_res (fun b -> Pure b)) -let write_memv v : bool monad = - Yield (Write_memv (v, fun b -> Pure b)) +let write_mem wk addr len v : bool monad = + Yield (Write_mem (wk, addr, len, v, fun b -> Pure b)) let barrier bk : unit monad = Yield (Barrier (bk, fun () -> Pure ())) @@ -393,7 +393,7 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = | _ -> fail "Wrong number of parameters to read_mem intrinsic" end - | "write_ea" -> + | "write_mem_ea" -> begin match evaluated with | [wk; addr; len] -> write_ea (value_of_exp wk) (value_of_exp addr) (value_of_exp len) >> wrap unit_exp @@ -407,10 +407,10 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = | _ -> fail "Wrong number of parameters to excl_res intrinsic" end - | "write_memv" -> + | "write_mem" -> begin match evaluated with - | [v] -> - write_memv (value_of_exp v) >>= fun b -> return (exp_of_value (V_bool b)) + | [wk; addr; len; v] -> + write_mem (value_of_exp wk) (value_of_exp v) (value_of_exp len) (value_of_exp v) >>= fun b -> return (exp_of_value (V_bool b)) | _ -> fail "Wrong number of parameters to write_memv intrinsic" end @@ -751,22 +751,24 @@ type frame = | Done of state * value | Step of string Lazy.t * state * (Type_check.tannot exp) monad * (string Lazy.t * lstate * (return_value -> (Type_check.tannot exp) monad)) list | Break of frame - | Effect_request of state * effect_request + | Effect_request of string Lazy.t * state * (string Lazy.t * lstate * (return_value -> (Type_check.tannot exp) monad)) list * effect_request + | Fail of string Lazy.t * state * (Type_check.tannot exp) monad * (string Lazy.t * lstate * (return_value -> (Type_check.tannot exp) monad)) list * string (* when changing effect_request remember to also update response type above *) and effect_request = | Read_mem of (* read_kind : *) value * (* address : *) value * (* length : *) value * (value -> state -> frame) | Write_ea of (* write_kind : *) value * (* address : *) value * (* length : *) value * (unit -> state -> frame) | Excl_res of (bool -> state -> frame) - | Write_memv of value * (bool -> state -> frame) + | Write_mem of (* write_kind : *) value * (* address : *) value * (* length : *) value * (* value : *) value * (bool -> state -> frame) | Barrier of (* barrier_kind : *) value * (unit -> state -> frame) | Read_reg of string * (value -> state -> frame) | Write_reg of string * value * (unit -> state -> frame) let rec eval_frame' = function | Done (state, v) -> Done (state, v) + | Fail (out, state, m, stack, msg) -> Fail (out, state, m, stack, msg) | Break frame -> Break frame - | Effect_request (state, eff) -> Effect_request (state, eff) + | Effect_request (out, state, stack, eff) -> Effect_request (out, state, stack, eff) | Step (out, state, m, stack) -> let lstate, gstate = state in match (m, stack) with @@ -796,9 +798,9 @@ let rec eval_frame' = function end | Yield (Read_reg (name, cont)), _ -> - Effect_request (state, Read_reg (name, fun v state' -> eval_frame' (Step (out, state', cont v, stack)))) + Effect_request (out, state, stack, Read_reg (name, fun v state' -> eval_frame' (Step (out, state', cont v, stack)))) | Yield (Write_reg (name, v, cont)), _ -> - Effect_request (state, Write_reg (name, v, fun () state' -> eval_frame' (Step (out, state', cont (), stack)))) + Effect_request (out, state, stack, Write_reg (name, v, fun () state' -> eval_frame' (Step (out, state', cont (), stack)))) | Yield (Get_primop (name, cont)), _ -> begin try @@ -820,22 +822,22 @@ let rec eval_frame' = function | Yield (Get_global_letbinds cont), _ -> eval_frame' (Step (out, state, cont gstate.letbinds, stack)) | Yield (Read_mem (rk, addr, len, cont)), _ -> - Effect_request (state, Read_mem (rk, addr, len, fun result state' -> eval_frame' (Step (out, state', cont result, stack)))) + Effect_request (out, state, stack, Read_mem (rk, addr, len, fun result state' -> eval_frame' (Step (out, state', cont result, stack)))) | Yield (Write_ea (wk, addr, len, cont)), _ -> - Effect_request (state, Write_ea (wk, addr, len, fun () state' -> eval_frame' (Step (out, state', cont (), stack)))) + Effect_request (out, state, stack, Write_ea (wk, addr, len, fun () state' -> eval_frame' (Step (out, state', cont (), stack)))) | Yield (Excl_res cont), _ -> - Effect_request (state, Excl_res (fun b state' -> eval_frame' (Step (out, state', cont b, stack)))) - | Yield (Write_memv (v, cont)), _ -> - Effect_request (state, Write_memv (v, fun b state' -> eval_frame' (Step (out, state', cont b, stack)))) + Effect_request (out, state, stack, Excl_res (fun b state' -> eval_frame' (Step (out, state', cont b, stack)))) + | Yield (Write_mem (wk, addr, len, v, cont)), _ -> + Effect_request (out, state, stack, Write_mem (wk, addr, len, v, fun b state' -> eval_frame' (Step (out, state', cont b, stack)))) | Yield (Barrier (bk, cont)), _ -> - Effect_request (state, Barrier (bk, fun () state' -> eval_frame' (Step (out, state', cont (), stack)))) + Effect_request (out, state, stack, Barrier (bk, fun () state' -> eval_frame' (Step (out, state', cont (), stack)))) | Yield (Early_return v), [] -> Done (state, v) | Yield (Early_return v), (head :: stack') -> Step (stack_string head, (stack_state head, gstate), stack_cont head (Return_ok v), stack') | Yield (Assertion_failed msg), _ | Yield (Fail msg), _ -> - failwith msg + Fail (out, state, m, stack, msg) | Yield (Exception v), [] -> - failwith ("Uncaught Exception" |> Util.cyan |> Util.clear) + Fail (out, state, m, stack, "Uncaught exception: " ^ string_of_value v) | Yield (Exception v), (head :: stack') -> Step (stack_string head, (stack_state head, gstate), stack_cont head (Return_exception v), stack') @@ -860,10 +862,10 @@ let default_effect_interp state eff = | Excl_res cont -> (* always succeeds in single-threaded interpreter *) cont true state - | Write_memv (v, cont) -> + | Write_mem (wk, addr, len, v, cont) -> begin match gstate.last_write_ea with - | Some (wk, addr, len) -> + | Some (wk', addr', len') -> let state' = (lstate, { gstate with last_write_ea = None }) in (* all write-kinds treated the same in single-threaded interpreter *) let addr' = coerce_bv addr in @@ -909,11 +911,12 @@ let default_effect_interp state eff = let rec run_frame frame = match frame with | Done (state, v) -> v + | Fail (_, _, _, _, msg) -> failwith ("run_frame got Fail: " ^ msg) | Step (lazy_str, _, _, _) -> run_frame (eval_frame frame) | Break frame -> run_frame (eval_frame frame) - | Effect_request (state, eff) -> + | Effect_request (out, state, stack, eff) -> run_frame (default_effect_interp state eff) let eval_exp state exp = diff --git a/src/isail.ml b/src/isail.ml index 30e02b36..7a33c7d1 100644 --- a/src/isail.ml +++ b/src/isail.ml @@ -120,7 +120,9 @@ let sep = "-----------------------------------------------------" |> Util.blue | let print_program () = match !current_mode with | Normal | Emacs -> () - | Evaluation (Step (out, _, _, stack)) -> + | Evaluation (Step (out, _, _, stack)) + | Evaluation (Effect_request(out, _, stack, _)) + | Evaluation (Fail (out, _, _, stack, _)) -> List.map stack_string stack |> List.rev |> List.iter (fun code -> print_endline (Lazy.force code); print_endline sep); print_endline (Lazy.force out) | Evaluation (Done (_, v)) -> @@ -153,6 +155,9 @@ let rec run () = interactive_state := state; print_endline ("Result = " ^ Value.string_of_value v); current_mode := Normal + | Fail (_, _, _, _, msg) -> + print_endline ("Error: " ^ msg); + current_mode := Normal | Step (out, state, _, stack) -> begin try @@ -164,7 +169,7 @@ let rec run () = | Break frame -> print_endline "Breakpoint"; current_mode := Evaluation frame - | Effect_request (state, eff) -> + | Effect_request (out, state, stack, eff) -> begin try current_mode := Evaluation (Interpreter.default_effect_interp state eff) @@ -187,6 +192,9 @@ let rec run_steps n = interactive_state := state; print_endline ("Result = " ^ Value.string_of_value v); current_mode := Normal + | Fail (_, _, _, _, msg) -> + print_endline ("Error: " ^ msg); + current_mode := Normal | Step (out, state, _, stack) -> begin try @@ -198,7 +206,7 @@ let rec run_steps n = | Break frame -> print_endline "Breakpoint"; current_mode := Evaluation frame - | Effect_request (state, eff) -> + | Effect_request (out, state, stack, eff) -> begin try current_mode := Evaluation (Interpreter.default_effect_interp state eff) @@ -552,6 +560,9 @@ let handle_input' input = interactive_state := state; print_endline ("Result = " ^ Value.string_of_value v); current_mode := Normal + | Fail (_, _, _, _, msg) -> + print_endline ("Error: " ^ msg); + current_mode := Normal | Step (out, state, _, stack) -> begin try @@ -564,7 +575,7 @@ let handle_input' input = | Break frame -> print_endline "Breakpoint"; current_mode := Evaluation frame - | Effect_request (state, eff) -> + | Effect_request (out, state, stack, eff) -> begin try interactive_state := state; -- cgit v1.2.3 From fd13ec718014c58fbb3fede23f6e6369d9e15c55 Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 13 Mar 2019 17:09:50 +0000 Subject: Interpreter: error handling when calling primops --- src/interpreter.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/interpreter.ml b/src/interpreter.ml index 33370816..34dcf590 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -422,7 +422,11 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = fail "Wrong number of parameters to barrier intrinsic" end | _ -> - get_primop extern >>= fun op -> return (exp_of_value (op (List.map value_of_exp evaluated))) + prerr_endline ("calling get_primop for '" ^ extern ^ "' with args (" ^ String.concat ", " (List.map string_of_exp evaluated) ^ ")"); + get_primop extern >>= + fun op -> try + return (exp_of_value (op (List.map value_of_exp evaluated))) + with _ as exc -> fail ("Exception calling primop '" ^ extern ^ "': " ^ Printexc.to_string exc) end | [] -> call id (List.map value_of_exp evaluated) >>= -- cgit v1.2.3 From a3bc3d7221758850093827da1db030014c6d529f Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 13 Mar 2019 17:10:10 +0000 Subject: Interpreter: handling for E_cons --- src/interpreter.ml | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/interpreter.ml b/src/interpreter.ml index 34dcf590..577e1234 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -643,7 +643,16 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = | None -> fail "Sizeof unevaluable nexp" end - | _ -> fail ("Unimplemented " ^ string_of_exp orig_exp) + | E_cons (hd, tl) when is_value hd && is_value tl -> + let hd = value_of_exp hd in + let tl = coerce_listlike (value_of_exp tl) in + return (exp_of_value (V_list (hd :: tl))) + | E_cons (hd, tl) when is_value hd -> + step tl >>= fun tl' -> wrap (E_cons (hd, tl')) + | E_cons (hd, tl) -> + step hd >>= fun hd' -> wrap (E_cons (hd', tl)) + + | _ -> raise (Invalid_argument ("Unimplemented " ^ string_of_exp orig_exp)) and combine _ v1 v2 = match (v1, v2) with -- cgit v1.2.3 From 31acee54267e21465ba6e65dd338d61d30012aa9 Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 13 Mar 2019 17:10:33 +0000 Subject: Interpreter: return frame rather than eval-looping analyse_instruction This is in order to allow register reads etc to be handled by RMEM --- src/interpreter.ml | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) (limited to 'src') diff --git a/src/interpreter.ml b/src/interpreter.ml index 577e1234..24af75e2 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -992,17 +992,13 @@ let annot_exp e_aux l env typ = annot_exp_effect e_aux l env typ no_effect let id_typ id = mk_typ (Typ_id (mk_id id)) let analyse_instruction state ast = - try - let env = (snd state).typecheck_env in - let unk = Parse_ast.Unknown in - let typed = annot_exp - (E_app (mk_id "initial_analysis", [annot_exp (E_internal_value ast) unk env (id_typ "ast")])) unk env - (tuple_typ [id_typ "regfps"; id_typ "regfps"; id_typ "regfps"; id_typ "niafps"; id_typ "diafp"; id_typ "instruction_kind"]) - in - let evaled = eval_exp state typed in - Value_success evaled - with _ as exn -> - Value_error exn + let env = (snd state).typecheck_env in + let unk = Parse_ast.Unknown in + let typed = annot_exp + (E_app (mk_id "initial_analysis", [annot_exp (E_internal_value ast) unk env (id_typ "ast")])) unk env + (tuple_typ [id_typ "regfps"; id_typ "regfps"; id_typ "regfps"; id_typ "niafps"; id_typ "diafp"; id_typ "instruction_kind"]) + in + Step (lazy (Pretty_print_sail.to_string (Pretty_print_sail.doc_exp typed)), state, return typed, []) let execute_instruction state ast = let env = (snd state).typecheck_env in -- cgit v1.2.3 From 4f14ccb421443dbc10b88e190526dda754f324aa Mon Sep 17 00:00:00 2001 From: Jon French Date: Wed, 13 Mar 2019 17:11:39 +0000 Subject: Pretty_print_sail: don't use colour to highlight E_internal_value --- src/pretty_print_sail.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index 56026c81..9712b62c 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -470,7 +470,7 @@ 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 -> string (Value.string_of_value v (* |> Util.green |> Util.clear *)) | _ -> parens (doc_exp exp) and doc_fexps fexps = separate_map (comma ^^ space) doc_fexp fexps -- cgit v1.2.3 From 1ffd3e2bfb5cbf32c3340af38ff39207a55a9b52 Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 14 Mar 2019 14:46:42 +0000 Subject: fix typo in interpreter excl_res intrinsic --- src/interpreter.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/interpreter.ml b/src/interpreter.ml index 24af75e2..bf60cc60 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -402,7 +402,7 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = end | "excl_res" -> begin match evaluated with - | [] -> + | [_] -> excl_res () >>= fun b -> return (exp_of_value (V_bool b)) | _ -> fail "Wrong number of parameters to excl_res intrinsic" -- cgit v1.2.3 From 791b75f7ba5207ed6660a1b910d28dd941515366 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Tue, 9 Apr 2019 17:56:26 +0100 Subject: Coq: tweak measure rewrites slightly Allows a quick hack where you can give a termination limit rather than a proper measure for functions with awkward termination properties. --- src/rewrites.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index f27e2946..e148cee4 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -4568,15 +4568,16 @@ let rewrite_explicit_measure env (Defs defs) = | _, P_aux (P_tup ps,_) -> ps | _, _ -> [measure_pat] in - let mk_wrap i (P_aux (p,(l,_))) = + let mk_wrap i (P_aux (p,(l,_)) as p_full) = let id = match p with | P_id id | P_typ (_,(P_aux (P_id id,_))) -> id + | P_lit _ | P_wild | P_typ (_,(P_aux (P_wild,_))) -> mk_id ("_arg" ^ string_of_int i) - | _ -> raise (Reporting.err_todo l "Measure patterns can only be identifiers or wildcards") + | _ -> raise (Reporting.err_todo l ("Measure patterns can only be identifiers or wildcards, not " ^ string_of_pat p_full)) in P_aux (P_id id,(loc,empty_tannot)), E_aux (E_id id,(loc,empty_tannot)) -- cgit v1.2.3 From 4d3e9db83ec604eb7379f51ebd6e9423271f3c1e Mon Sep 17 00:00:00 2001 From: Jon French Date: Fri, 12 Apr 2019 14:33:40 +0100 Subject: update libsail.mllib with more jib modules --- src/libsail.mllib | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'src') diff --git a/src/libsail.mllib b/src/libsail.mllib index d4125d68..734a1381 100644 --- a/src/libsail.mllib +++ b/src/libsail.mllib @@ -15,6 +15,10 @@ Interactive Interpreter Isail Jib +Jib_compile +Jib_optimize +Jib_ssa +Jib_util Latex Lexer Manifest -- cgit v1.2.3 From f2cdaab5fd7f648c1037c504e289e881ce8bbf47 Mon Sep 17 00:00:00 2001 From: Jon French Date: Fri, 12 Apr 2019 14:43:17 +0100 Subject: Interpreter: remove debug printing (oops) --- src/interpreter.ml | 1 - 1 file changed, 1 deletion(-) (limited to 'src') diff --git a/src/interpreter.ml b/src/interpreter.ml index bf60cc60..1ebfdeff 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -422,7 +422,6 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = fail "Wrong number of parameters to barrier intrinsic" end | _ -> - prerr_endline ("calling get_primop for '" ^ extern ^ "' with args (" ^ String.concat ", " (List.map string_of_exp evaluated) ^ ")"); get_primop extern >>= fun op -> try return (exp_of_value (op (List.map value_of_exp evaluated))) -- cgit v1.2.3 From f254b36fe1157df8ff620536f13eb289d781e28f Mon Sep 17 00:00:00 2001 From: Jon French Date: Fri, 12 Apr 2019 14:45:04 +0100 Subject: ToFromInterp_backend: better handling of nexps --- src/toFromInterp_backend.ml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/toFromInterp_backend.ml b/src/toFromInterp_backend.ml index e35af091..43166f77 100644 --- a/src/toFromInterp_backend.ml +++ b/src/toFromInterp_backend.ml @@ -69,10 +69,11 @@ let frominterp_typedef (TD_aux (td_aux, (l, _))) = let fromValueKid (Kid_aux ((Var name), _)) = string ("typq_" ^ name) in - let fromValueNexp (Nexp_aux (nexp_aux, _)) = match nexp_aux with + let fromValueNexp ((Nexp_aux (nexp_aux, annot)) as nexp) = match nexp_aux with | Nexp_constant num -> parens (separate space [string "Big_int.of_string"; dquotes (string (Nat_big_num.to_string num))]) | Nexp_var var -> fromValueKid var - | _ -> string "NEXP" + | Nexp_id id -> string (string_of_id id ^ "FromInterpValue") + | _ -> string ("NEXP(" ^ string_of_nexp nexp ^ ")") in let rec fromValueTypArg (A_aux (a_aux, _)) = match a_aux with | A_typ typ -> fromValueTyp typ "" @@ -196,10 +197,11 @@ let tointerp_typedef (TD_aux (td_aux, (l, _))) = let toValueKid (Kid_aux ((Var name), _)) = string ("typq_" ^ name) in - let toValueNexp (Nexp_aux (nexp_aux, _)) = match nexp_aux with + let toValueNexp ((Nexp_aux (nexp_aux, _)) as nexp) = match nexp_aux with | Nexp_constant num -> parens (separate space [string "Big_int.of_string"; dquotes (string (Nat_big_num.to_string num))]) | Nexp_var var -> toValueKid var - | _ -> string "NEXP" + | Nexp_id id -> string (string_of_id id ^ "ToInterpValue") + | _ -> string ("NEXP(" ^ string_of_nexp nexp ^ ")") in let rec toValueTypArg (A_aux (a_aux, _)) = match a_aux with | A_typ typ -> toValueTyp typ "" -- cgit v1.2.3 From 63694e62ed04288f34204e6db139acd219bcfc96 Mon Sep 17 00:00:00 2001 From: Jon French Date: Fri, 12 Apr 2019 14:45:50 +0100 Subject: ToFromInterp_backend: don't generate converters for cache_op_kind --- src/toFromInterp_backend.ml | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'src') diff --git a/src/toFromInterp_backend.ml b/src/toFromInterp_backend.ml index 43166f77..5a6dae23 100644 --- a/src/toFromInterp_backend.ml +++ b/src/toFromInterp_backend.ml @@ -114,6 +114,7 @@ let frominterp_typedef (TD_aux (td_aux, (l, _))) = | Id_aux ((Id "barrier_kind"),_) -> empty | Id_aux ((Id "trans_kind"),_) -> empty | Id_aux ((Id "instruction_kind"),_) -> empty + | Id_aux ((Id "cache_op_kind"),_) -> empty | Id_aux ((Id "regfp"),_) -> empty | Id_aux ((Id "regfps"),_) -> empty | Id_aux ((Id "niafp"),_) -> empty @@ -156,6 +157,7 @@ let frominterp_typedef (TD_aux (td_aux, (l, _))) = | TD_enum (Id_aux (Id "write_kind", _), _, _) -> empty | TD_enum (Id_aux (Id "barrier_kind", _), _, _) -> empty | TD_enum (Id_aux (Id "trans_kind", _), _, _) -> empty + | TD_enum (Id_aux (Id "cache_op_kind", _), _, _) -> empty | TD_enum (id, ids, _) -> let fromInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "FromInterpValue"] in let fromFallback = separate space [pipe; underscore; arrow; string "failwith"; @@ -241,6 +243,7 @@ let tointerp_typedef (TD_aux (td_aux, (l, _))) = | Id_aux ((Id "barrier_kind"),_) -> empty | Id_aux ((Id "trans_kind"),_) -> empty | Id_aux ((Id "instruction_kind"),_) -> empty + | Id_aux ((Id "cache_op_kind"),_) -> empty | Id_aux ((Id "regfp"),_) -> empty | Id_aux ((Id "regfps"),_) -> empty | Id_aux ((Id "niafp"),_) -> empty @@ -278,6 +281,7 @@ let tointerp_typedef (TD_aux (td_aux, (l, _))) = | TD_enum (Id_aux (Id "write_kind", _), _, _) -> empty | TD_enum (Id_aux (Id "barrier_kind", _), _, _) -> empty | TD_enum (Id_aux (Id "trans_kind", _), _, _) -> empty + | TD_enum (Id_aux (Id "cache_op_kind", _), _, _) -> empty | TD_enum (id, ids, _) -> let toInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "ToInterpValue"] in let toInterpValue = -- cgit v1.2.3 From 0f6fd188ca232cb539592801fcbb873d59611d81 Mon Sep 17 00:00:00 2001 From: Jon French Date: Fri, 12 Apr 2019 14:47:04 +0100 Subject: ToFromInterp_backend: print type annotations for abbrevs of unquantified types, to help out ocaml (hack) --- src/toFromInterp_backend.ml | 46 +++++++++++++++++++++++++++++++++++---------- 1 file changed, 36 insertions(+), 10 deletions(-) (limited to 'src') diff --git a/src/toFromInterp_backend.ml b/src/toFromInterp_backend.ml index 5a6dae23..b253791d 100644 --- a/src/toFromInterp_backend.ml +++ b/src/toFromInterp_backend.ml @@ -148,11 +148,24 @@ let frominterp_typedef (TD_aux (td_aux, (l, _))) = | TD_abbrev (Id_aux (Id "regfps", _), _, _) -> empty | TD_abbrev (Id_aux (Id "niafps", _), _, _) -> empty | TD_abbrev (id, typq, typ_arg) -> - let fromInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "FromInterpValue"] in - let fromInterpValue = - (separate space [string "let"; fromInterpValueName; separate space (fromValueTypqs typq); equals; fromValueTypArg typ_arg]) - in - fromInterpValue ^^ (twice hardline) + begin + let fromInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "FromInterpValue"] in + (* HACK: print a type annotation for abbrevs of unquantified types, to help cases ocaml can't type-infer on its own *) + let fromInterpValspec = + (* HACK because of lem renaming *) + if string_of_id id = "opcode" then empty else + match typ_arg with + | A_aux (A_typ _, _) -> begin match typq with + | TypQ_aux (TypQ_no_forall, _) -> separate space [colon; string "value"; arrow; string (maybe_zencode (string_of_id id))] + | _ -> empty + end + | _ -> empty + in + let fromInterpValue = + (separate space [string "let"; fromInterpValueName; separate space (fromValueTypqs typq); fromInterpValspec; equals; fromValueTypArg typ_arg]) + in + fromInterpValue ^^ (twice hardline) + end | TD_enum (Id_aux (Id "read_kind", _), _, _) -> empty | TD_enum (Id_aux (Id "write_kind", _), _, _) -> empty | TD_enum (Id_aux (Id "barrier_kind", _), _, _) -> empty @@ -272,11 +285,24 @@ let tointerp_typedef (TD_aux (td_aux, (l, _))) = | TD_abbrev (Id_aux (Id "regfps", _), _, _) -> empty | TD_abbrev (Id_aux (Id "niafps", _), _, _) -> empty | TD_abbrev (id, typq, typ_arg) -> - let toInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "ToInterpValue"] in - let toInterpValue = - (separate space [string "let"; toInterpValueName; separate space (toValueTypqs typq); equals; toValueTypArg typ_arg]) - in - toInterpValue ^^ (twice hardline) + begin + let toInterpValueName = concat [string (maybe_zencode (string_of_id id)); string "ToInterpValue"] in + (* HACK: print a type annotation for abbrevs of unquantified types, to help cases ocaml can't type-infer on its own *) + let toInterpValspec = + (* HACK because of lem renaming *) + if string_of_id id = "opcode" then empty else + match typ_arg with + | A_aux (A_typ _, _) -> begin match typq with + | TypQ_aux (TypQ_no_forall, _) -> separate space [colon; string (maybe_zencode (string_of_id id)); arrow; string "value"] + | _ -> empty + end + | _ -> empty + in + let toInterpValue = + (separate space [string "let"; toInterpValueName; separate space (toValueTypqs typq); toInterpValspec; equals; toValueTypArg typ_arg]) + in + toInterpValue ^^ (twice hardline) + end | TD_enum (Id_aux (Id "read_kind", _), _, _) -> empty | TD_enum (Id_aux (Id "write_kind", _), _, _) -> empty | TD_enum (Id_aux (Id "barrier_kind", _), _, _) -> empty -- cgit v1.2.3 From 1f421b865a87a161a82550443a0cf39aa2642d9c Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Mon, 15 Apr 2019 12:08:28 +0100 Subject: Basic loop termination measures for Coq Currently only supports pure termination measures for loops with effects. The user syntax uses separate termination measure declarations, as in the previous recursive termination measures, which are rewritten into the loop AST nodes before type checking (because it would be rather difficult to calculate the correct environment to type check the separate declaration in). --- src/ast_util.ml | 33 +++++-- src/constant_propagation.ml | 10 +- src/initial_check.ml | 20 +++- src/interpreter.ml | 4 +- src/jib/anf.ml | 2 +- src/jib/jib_compile.ml | 1 + src/monomorphise.ml | 10 +- src/ocaml_backend.ml | 4 +- src/parse_ast.ml | 16 ++- src/parser.mly | 29 +++++- src/pretty_print_coq.ml | 95 +++++++++++------- src/pretty_print_lem.ml | 8 +- src/pretty_print_sail.ml | 21 +++- src/rewriter.ml | 235 +++++++++++++++++++++++++++++++++++++++++--- src/rewriter.mli | 6 +- src/rewrites.ml | 82 ++++++++++++++-- src/rewrites.mli | 3 + src/sail.ml | 3 + src/spec_analysis.ml | 14 ++- src/type_check.ml | 24 ++++- 20 files changed, 525 insertions(+), 95 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index d0efc0de..254afccf 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -519,7 +519,7 @@ and map_exp_annot_aux f = function | E_tuple xs -> E_tuple (List.map (map_exp_annot f) xs) | E_if (cond, t, e) -> E_if (map_exp_annot f cond, map_exp_annot f t, map_exp_annot f e) | E_for (v, e1, e2, e3, o, e4) -> E_for (v, map_exp_annot f e1, map_exp_annot f e2, map_exp_annot f e3, o, map_exp_annot f e4) - | E_loop (loop_type, e1, e2) -> E_loop (loop_type, map_exp_annot f e1, map_exp_annot f e2) + | E_loop (loop_type, measure, e1, e2) -> E_loop (loop_type, map_measure_annot f measure, map_exp_annot f e1, map_exp_annot f e2) | E_vector exps -> E_vector (List.map (map_exp_annot f) exps) | E_vector_access (exp1, exp2) -> E_vector_access (map_exp_annot f exp1, map_exp_annot f exp2) | E_vector_subrange (exp1, exp2, exp3) -> E_vector_subrange (map_exp_annot f exp1, map_exp_annot f exp2, map_exp_annot f exp3) @@ -546,6 +546,10 @@ and map_exp_annot_aux f = function | E_var (lexp, exp1, exp2) -> E_var (map_lexp_annot f lexp, map_exp_annot f exp1, map_exp_annot f exp2) | E_internal_plet (pat, exp1, exp2) -> E_internal_plet (map_pat_annot f pat, map_exp_annot f exp1, map_exp_annot f exp2) | E_internal_return exp -> E_internal_return (map_exp_annot f exp) +and map_measure_annot f (Measure_aux (m, l)) = Measure_aux (map_measure_annot_aux f m, l) +and map_measure_annot_aux f = function + | Measure_none -> Measure_none + | Measure_some exp -> Measure_some (map_exp_annot f exp) and map_opt_default_annot f (Def_val_aux (df, annot)) = Def_val_aux (map_opt_default_annot_aux f df, f annot) and map_opt_default_annot_aux f = function | Def_val_empty -> Def_val_empty @@ -648,6 +652,7 @@ let def_loc = function | DEF_internal_mutrec _ -> Parse_ast.Unknown | DEF_pragma (_, _, l) -> l | DEF_measure (id, _, _) -> id_loc id + | DEF_loop_measures (id, _) -> id_loc id let string_of_id = function | Id_aux (Id v, _) -> v @@ -838,8 +843,8 @@ let rec string_of_exp (E_aux (exp, _)) = ^ " by " ^ string_of_exp u ^ " order " ^ string_of_order ord ^ ") { " ^ string_of_exp body - | E_loop (While, cond, body) -> "while " ^ string_of_exp cond ^ " do " ^ string_of_exp body - | E_loop (Until, cond, body) -> "repeat " ^ string_of_exp body ^ " until " ^ string_of_exp cond + | E_loop (While, measure, cond, body) -> "while " ^ string_of_measure measure ^ string_of_exp cond ^ " do " ^ string_of_exp body + | E_loop (Until, measure, cond, body) -> "repeat " ^ string_of_measure measure ^ string_of_exp body ^ " until " ^ string_of_exp cond | E_assert (test, msg) -> "assert(" ^ string_of_exp test ^ ", " ^ string_of_exp msg ^ ")" | E_exit exp -> "exit " ^ string_of_exp exp | E_throw exp -> "throw " ^ string_of_exp exp @@ -855,6 +860,11 @@ let rec string_of_exp (E_aux (exp, _)) = | E_nondet _ -> "NONDET" | E_internal_value _ -> "INTERNAL VALUE" +and string_of_measure (Measure_aux (m,_)) = + match m with + | Measure_none -> "" + | Measure_some exp -> "termination_measure { " ^ string_of_exp exp ^ "}" + and string_of_fexp (FE_aux (FE_Fexp (field, exp), _)) = string_of_id field ^ " = " ^ string_of_exp exp and string_of_pexp (Pat_aux (pexp, _)) = @@ -1448,8 +1458,8 @@ let rec subst id value (E_aux (e_aux, annot) as exp) = | E_if (cond, then_exp, else_exp) -> E_if (subst id value cond, subst id value then_exp, subst id value else_exp) - | E_loop (loop, cond, body) -> - E_loop (loop, subst id value cond, subst id value body) + | E_loop (loop, measure, cond, body) -> + E_loop (loop, subst_measure id value measure, subst id value cond, subst id value body) | E_for (id', exp1, exp2, exp3, order, body) when Id.compare id id' = 0 -> E_for (id', exp1, exp2, exp3, order, body) | E_for (id', exp1, exp2, exp3, order, body) -> @@ -1503,6 +1513,11 @@ let rec subst id value (E_aux (e_aux, annot) as exp) = in wrap e_aux +and subst_measure id value (Measure_aux (m_aux, l)) = + match m_aux with + | Measure_none -> Measure_aux (Measure_none, l) + | Measure_some exp -> Measure_aux (Measure_some (subst id value exp), l) + and subst_pexp id value (Pat_aux (pexp_aux, annot)) = let pexp_aux = match pexp_aux with | Pat_exp (pat, exp) when IdSet.mem id (pat_ids pat) -> Pat_exp (pat, exp) @@ -1660,7 +1675,7 @@ let rec locate : 'a. (l -> l) -> 'a exp -> 'a exp = fun f (E_aux (e_aux, (l, ann | E_app_infix (exp1, op, exp2) -> E_app_infix (locate f exp1, locate_id f op, locate f exp2) | E_tuple exps -> E_tuple (List.map (locate f) exps) | E_if (cond_exp, then_exp, else_exp) -> E_if (locate f cond_exp, locate f then_exp, locate f else_exp) - | E_loop (loop, cond, body) -> E_loop (loop, locate f cond, locate f body) + | E_loop (loop, measure, cond, body) -> E_loop (loop, locate_measure f measure, locate f cond, locate f body) | E_for (id, exp1, exp2, exp3, ord, exp4) -> E_for (locate_id f id, locate f exp1, locate f exp2, locate f exp3, ord, locate f exp4) | E_vector exps -> E_vector (List.map (locate f) exps) @@ -1694,6 +1709,12 @@ let rec locate : 'a. (l -> l) -> 'a exp -> 'a exp = fun f (E_aux (e_aux, (l, ann in E_aux (e_aux, (f l, annot)) +and locate_measure : 'a. (l -> l) -> 'a internal_loop_measure -> 'a internal_loop_measure = fun f (Measure_aux (m, l)) -> + let m = match m with + | Measure_none -> Measure_none + | Measure_some exp -> Measure_some (locate f exp) + in Measure_aux (m, f l) + and locate_letbind : 'a. (l -> l) -> 'a letbind -> 'a letbind = fun f (LB_aux (LB_val (pat, exp), (l, annot))) -> LB_aux (LB_val (locate_pat f pat, locate f exp), (f l, annot)) diff --git a/src/constant_propagation.ml b/src/constant_propagation.ml index 5c99a534..ee5678a8 100644 --- a/src/constant_propagation.ml +++ b/src/constant_propagation.ml @@ -440,11 +440,17 @@ let const_props defs ref_vars = let assigns = isubst_minus_set assigns (assigned_vars e4) in let e4',_ = const_prop_exp (Bindings.remove id (fst substs),snd substs) assigns e4 in re (E_for (id,e1',e2',e3',ord,e4')) assigns - | E_loop (loop,e1,e2) -> + | E_loop (loop,m,e1,e2) -> let assigns = isubst_minus_set assigns (IdSet.union (assigned_vars e1) (assigned_vars e2)) in + let m' = match m with + | Measure_aux (Measure_none,_) -> m + | Measure_aux (Measure_some exp,l) -> + let exp',_ = const_prop_exp substs assigns exp in + Measure_aux (Measure_some exp',l) + in let e1',_ = const_prop_exp substs assigns e1 in let e2',_ = const_prop_exp substs assigns e2 in - re (E_loop (loop,e1',e2')) assigns + re (E_loop (loop,m',e1',e2')) assigns | E_vector es -> let es',assigns = non_det_exp_list es in begin diff --git a/src/initial_check.ml b/src/initial_check.ml index df9af97f..8129fd89 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -367,8 +367,8 @@ and to_ast_exp ctx (P.E_aux(exp,l) : P.exp) = | P.E_for(id,e1,e2,e3,atyp,e4) -> E_for(to_ast_id id,to_ast_exp ctx e1, to_ast_exp ctx e2, to_ast_exp ctx e3,to_ast_order ctx atyp, to_ast_exp ctx e4) - | P.E_loop (P.While, e1, e2) -> E_loop (While, to_ast_exp ctx e1, to_ast_exp ctx e2) - | P.E_loop (P.Until, e1, e2) -> E_loop (Until, to_ast_exp ctx e1, to_ast_exp ctx e2) + | P.E_loop (P.While, m, e1, e2) -> E_loop (While, to_ast_measure ctx m, to_ast_exp ctx e1, to_ast_exp ctx e2) + | P.E_loop (P.Until, m, e1, e2) -> E_loop (Until, to_ast_measure ctx m, to_ast_exp ctx e1, to_ast_exp ctx e2) | P.E_vector(exps) -> E_vector(List.map (to_ast_exp ctx) exps) | P.E_vector_access(vexp,exp) -> E_vector_access(to_ast_exp ctx vexp, to_ast_exp ctx exp) | P.E_vector_subrange(vex,exp1,exp2) -> @@ -414,6 +414,16 @@ and to_ast_exp ctx (P.E_aux(exp,l) : P.exp) = | _ -> raise (Reporting.err_unreachable l __POS__ "Unparsable construct in to_ast_exp") ), (l,())) +and to_ast_measure ctx (P.Measure_aux(m,l)) : unit internal_loop_measure = + let m = match m with + | P.Measure_none -> Measure_none + | P.Measure_some exp -> + if !opt_magic_hash then + Measure_some (to_ast_exp ctx exp) + else + raise (Reporting.err_general l "Internal loop termination measure found without -dmagic_hash") + in Measure_aux (m,l) + and to_ast_lexp ctx (P.E_aux(exp,l) : P.exp) : unit lexp = let lexp = match exp with | P.E_id id -> LEXP_id (to_ast_id id) @@ -762,6 +772,10 @@ let to_ast_prec = function | P.InfixL -> InfixL | P.InfixR -> InfixR +let to_ast_loop_measure ctx = function + | P.Loop (P.While, exp) -> Loop (While, to_ast_exp ctx exp) + | P.Loop (P.Until, exp) -> Loop (Until, to_ast_exp ctx exp) + let to_ast_def ctx def : unit def list ctx_out = match def with | P.DEF_overload (id, ids) -> @@ -800,6 +814,8 @@ let to_ast_def ctx def : unit def list ctx_out = [DEF_scattered sdef], ctx | P.DEF_measure (id, pat, exp) -> [DEF_measure (to_ast_id id, to_ast_pat ctx pat, to_ast_exp ctx exp)], ctx + | P.DEF_loop_measures (id, measures) -> + [DEF_loop_measures (to_ast_id id, List.map (to_ast_loop_measure ctx) measures)], ctx let rec remove_mutrec = function | [] -> [] diff --git a/src/interpreter.ml b/src/interpreter.ml index f01a3846..b198c59b 100644 --- a/src/interpreter.ml +++ b/src/interpreter.ml @@ -243,8 +243,8 @@ let rec step (E_aux (e_aux, annot) as orig_exp) = | E_if (exp, then_exp, else_exp) -> step exp >>= fun exp' -> wrap (E_if (exp', then_exp, else_exp)) - | E_loop (While, exp, body) -> wrap (E_if (exp, E_aux (E_block [body; orig_exp], annot), exp_of_value V_unit)) - | E_loop (Until, exp, body) -> wrap (E_block [body; E_aux (E_if (exp, exp_of_value V_unit, orig_exp), annot)]) + | E_loop (While, _, exp, body) -> wrap (E_if (exp, E_aux (E_block [body; orig_exp], annot), exp_of_value V_unit)) + | E_loop (Until, _, exp, body) -> wrap (E_block [body; E_aux (E_if (exp, exp_of_value V_unit, orig_exp), annot)]) | E_assert (exp, msg) when is_true exp -> wrap unit_exp | E_assert (exp, msg) when is_false exp && is_value msg -> diff --git a/src/jib/anf.ml b/src/jib/anf.ml index 0a410249..c7f86cd4 100644 --- a/src/jib/anf.ml +++ b/src/jib/anf.ml @@ -518,7 +518,7 @@ let rec anf (E_aux (e_aux, ((l, _) as exp_annot)) as exp) = raise (Reporting.err_unreachable l __POS__ ("Encountered complex l-expression " ^ string_of_lexp lexp ^ " when converting to ANF")) - | E_loop (loop_typ, cond, exp) -> + | E_loop (loop_typ, _, cond, exp) -> let acond = anf cond in let aexp = anf exp in mk_aexp (AE_loop (loop_typ, acond, aexp)) diff --git a/src/jib/jib_compile.ml b/src/jib/jib_compile.ml index 4a72ffff..f977193a 100644 --- a/src/jib/jib_compile.ml +++ b/src/jib/jib_compile.ml @@ -1264,6 +1264,7 @@ and compile_def' n total ctx = function (* Termination measures only needed for Coq, and other theorem prover output *) | DEF_measure _ -> [], ctx + | DEF_loop_measures _ -> [], ctx | DEF_internal_mutrec fundefs -> let defs = List.map (fun fdef -> DEF_fundef fdef) fundefs in diff --git a/src/monomorphise.ml b/src/monomorphise.ml index 4d7119d7..92c58e5d 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -980,7 +980,7 @@ let split_defs all_errors splits defs = | E_tuple es -> re (E_tuple (List.map map_exp es)) | E_if (e1,e2,e3) -> re (E_if (map_exp e1, map_exp e2, map_exp e3)) | E_for (id,e1,e2,e3,ord,e4) -> re (E_for (id,map_exp e1,map_exp e2,map_exp e3,ord,map_exp e4)) - | E_loop (loop,e1,e2) -> re (E_loop (loop,map_exp e1,map_exp e2)) + | E_loop (loop,m,e1,e2) -> re (E_loop (loop,m,map_exp e1,map_exp e2)) | E_vector es -> re (E_vector (List.map map_exp es)) | E_vector_access (e1,e2) -> re (E_vector_access (map_exp e1,map_exp e2)) | E_vector_subrange (e1,e2,e3) -> re (E_vector_subrange (map_exp e1,map_exp e2,map_exp e3)) @@ -1115,10 +1115,14 @@ let split_defs all_errors splits defs = | DEF_internal_mutrec _ -> [d] | DEF_fundef fd -> [DEF_fundef (map_fundef fd)] - | DEF_mapdef (MD_aux (_, (l, _))) -> Reporting.unreachable l __POS__ "mappings should be gone by now" + | DEF_mapdef (MD_aux (_, (l, _))) -> + Reporting.unreachable l __POS__ "mappings should be gone by now" | DEF_val lb -> [DEF_val (map_letbind lb)] | DEF_scattered sd -> List.map (fun x -> DEF_scattered x) (map_scattered_def sd) | DEF_measure (id,pat,exp) -> [DEF_measure (id,pat,map_exp exp)] + | DEF_loop_measures (id,_) -> + Reporting.unreachable (id_loc id) __POS__ + "Loop termination measures should have been rewritten before now" in Defs (List.concat (List.map map_def defs)) in @@ -2065,7 +2069,7 @@ let rec analyse_exp fn_id env assigns (E_aux (e,(l,annot)) as exp) = let d3,a3,r3 = analyse_exp fn_id env assigns e3 in let assigns = add_dep_to_assigned d1 (dep_bindings_merge a2 a3) [e2;e3] in (dmerge d1 (dmerge d2 d3), assigns, merge r1 (merge r2 r3)) - | E_loop (_,e1,e2) -> + | E_loop (_,_,e1,e2) -> (* We remove all of the variables assigned in the loop, so we don't need to add control dependencies *) let assigns = remove_assigns [e1;e2] " assigned in a loop" in diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index c68a258d..8361d5f5 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -256,7 +256,7 @@ let rec ocaml_exp ctx (E_aux (exp_aux, _) as exp) = separate space [string "let"; ocaml_atomic_lexp ctx lexp; equals; string "ref"; parens (ocaml_atomic_exp ctx exp1 ^^ space ^^ colon ^^ space ^^ ocaml_typ ctx (Rewrites.simple_typ (typ_of exp1))); string "in"] ^/^ ocaml_exp ctx exp2 - | E_loop (Until, cond, body) -> + | E_loop (Until, _, cond, body) -> let loop_body = (ocaml_atomic_exp ctx body ^^ semi) ^/^ @@ -267,7 +267,7 @@ let rec ocaml_exp ctx (E_aux (exp_aux, _) as exp) = (string "let rec loop () =" ^//^ loop_body) ^/^ string "in" ^/^ string "loop ()" - | E_loop (While, cond, body) -> + | E_loop (While, _, cond, body) -> let loop_body = separate space [string "if"; ocaml_atomic_exp ctx cond; string "then"; parens (ocaml_atomic_exp ctx body ^^ semi ^^ space ^^ string "loop ()"); diff --git a/src/parse_ast.ml b/src/parse_ast.ml index 818c9340..896a860d 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -238,7 +238,14 @@ and fpat = type loop = While | Until -type +type measure_aux = (* optional termination measure for a loop *) + | Measure_none + | Measure_some of exp + +and measure = + | Measure_aux of measure_aux * l + +and exp_aux = (* Expression *) E_block of (exp) list (* block (parsing conflict with structs?) *) | E_nondet of (exp) list (* block that can evaluate the contained expressions in any ordering *) @@ -251,7 +258,7 @@ exp_aux = (* Expression *) | E_app_infix of exp * id * exp (* infix function application *) | E_tuple of (exp) list (* tuple *) | E_if of exp * exp * exp (* conditional *) - | E_loop of loop * exp * exp + | E_loop of loop * measure * exp * exp | E_for of id * exp * exp * exp * atyp * exp (* loop *) | E_vector of (exp) list (* vector (indexed from 0) *) | E_vector_access of exp * exp (* vector access *) @@ -489,6 +496,10 @@ dec_spec = DEC_aux of dec_spec_aux * l +type loop_measure = + | Loop of loop * exp + + type scattered_def = SD_aux of scattered_def_aux * l @@ -509,6 +520,7 @@ def = (* Top-level definition *) | DEF_default of default_typing_spec (* default kind and type assumptions *) | DEF_scattered of scattered_def (* scattered definition *) | DEF_measure of id * pat * exp (* separate termination measure declaration *) + | DEF_loop_measures of id * loop_measure list (* separate termination measure declaration *) | DEF_reg_dec of dec_spec (* register declaration *) | DEF_pragma of string * string * l | DEF_internal_mutrec of fundef list diff --git a/src/parser.mly b/src/parser.mly index 39ca75ff..5e448a05 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -92,6 +92,7 @@ let mk_typ t n m = ATyp_aux (t, loc n m) let mk_pat p n m = P_aux (p, loc n m) let mk_pexp p n m = Pat_aux (p, loc n m) let mk_exp e n m = E_aux (e, loc n m) +let mk_measure meas n m = Measure_aux (meas, loc n m) let mk_lit l n m = L_aux (l, loc n m) let mk_lit_exp l n m = mk_exp (E_lit (mk_lit l n m)) n m let mk_typschm tq t n m = TypSchm_aux (TypSchm_ts (tq, t), loc n m) @@ -748,6 +749,13 @@ exp_eof: | exp Eof { $1 } +/* Internal syntax for loop measures, rejected in normal code by initial_check */ +internal_loop_measure: + | + { mk_measure Measure_none $startpos $endpos } + | TerminationMeasure Lcurly exp Rcurly + { mk_measure (Measure_some $3) $startpos $endpos } + exp: | exp0 { $1 } @@ -802,10 +810,10 @@ exp: else ATyp_aux(ATyp_dec,loc $startpos($6) $endpos($6)) in mk_exp (E_for ($3, $5, $7, step, ord, $9)) $startpos $endpos } - | Repeat exp Until exp - { mk_exp (E_loop (Until, $4, $2)) $startpos $endpos } - | While exp Do exp - { mk_exp (E_loop (While, $2, $4)) $startpos $endpos } + | Repeat internal_loop_measure exp Until exp + { mk_exp (E_loop (Until, $2, $5, $3)) $startpos $endpos } + | While internal_loop_measure exp Do exp + { mk_exp (E_loop (While, $2, $3, $5)) $startpos $endpos } /* Debugging only, will be rejected in initial_check if debugging isn't on */ | InternalPLet pat Eq exp In exp @@ -1401,6 +1409,17 @@ scattered_clause: | Function_ Clause funcl { mk_sd (SD_funcl $3) $startpos $endpos } +loop_measure: + | Until exp + { Loop (Until, $2) } + | While exp + { Loop (While, $2) } + +loop_measures: + | loop_measure + { [$1] } + | loop_measure Comma loop_measures + { $1::$3 } def: | fun_def @@ -1439,6 +1458,8 @@ def: { DEF_pragma (fst $1, snd $1, loc $startpos $endpos) } | TerminationMeasure id pat Eq exp { DEF_measure ($2, $3, $5) } + | TerminationMeasure id loop_measures + { DEF_loop_measures ($2,$3) } defs_list: | def diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index b4f32dce..dabb7b56 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -1504,43 +1504,58 @@ let doc_exp, doc_let = | _ -> raise (Reporting.err_unreachable l __POS__ "Unexpected number of arguments for loop combinator") end - | Id_aux (Id (("while#" | "until#") as combinator), _) -> - let combinator = String.sub combinator 0 (String.length combinator - 1) in + | Id_aux (Id (("while#" | "until#" | "while#t" | "until#t") as combinator), _) -> + let combinator = String.sub combinator 0 (String.index combinator '#') in begin - match args with - | [cond; varstuple; body] -> - let return (E_aux (e, a)) = E_aux (E_internal_return (E_aux (e, a)), a) in - let csuffix, cond, body = - match effectful (effect_of cond), effectful (effect_of body) with - | false, false -> "", cond, body - | false, true -> "M", return cond, body - | true, false -> "M", cond, return body - | true, true -> "M", cond, body - in - let used_vars_body = find_e_ids body in - let lambda = - (* Work around indentation issues in Lem when translating - tuple or literal unit patterns to Isabelle *) - match fst (uncast_exp varstuple) with - | E_aux (E_tuple _, _) - when not (IdSet.mem (mk_id "varstup") used_vars_body)-> - separate space [string "fun varstup"; bigarrow] ^^ break 1 ^^ - separate space [string "let"; squote ^^ expY varstuple; string ":= varstup in"] - | E_aux (E_lit (L_aux (L_unit, _)), _) - when not (IdSet.mem (mk_id "unit_var") used_vars_body) -> - separate space [string "fun unit_var"; bigarrow] - | _ -> - separate space [string "fun"; expY varstuple; bigarrow] - in - parens ( - (prefix 2 1) - ((separate space) [string (combinator ^ csuffix); expY varstuple]) - ((prefix 0 1) - (parens (prefix 2 1 (group lambda) (expN cond))) - (parens (prefix 2 1 (group lambda) (expN body)))) - ) - | _ -> raise (Reporting.err_unreachable l __POS__ - "Unexpected number of arguments for loop combinator") + let cond, varstuple, body, measure = + match args with + | [cond; varstuple; body] -> cond, varstuple, body, None + | [cond; varstuple; body; measure] -> cond, varstuple, body, Some measure + | _ -> raise (Reporting.err_unreachable l __POS__ + "Unexpected number of arguments for loop combinator") + in + let return (E_aux (e, (l,a))) = + let a' = mk_tannot (env_of_annot (l,a)) bool_typ no_effect in + E_aux (E_internal_return (E_aux (e, (l,a))), (l,a')) + in + let simple_bool (E_aux (_, (l,a)) as exp) = + let a' = mk_tannot (env_of_annot (l,a)) bool_typ no_effect in + E_aux (E_cast (bool_typ, exp), (l,a')) + in + let csuffix, cond, body = + match effectful (effect_of cond), effectful (effect_of body) with + | false, false -> "", cond, body + | false, true -> "M", return cond, body + | true, false -> "M", simple_bool cond, return body + | true, true -> "M", simple_bool cond, body + in + let msuffix, measure_pp = + match measure with + | None -> "", [] + | Some exp -> "T", [expY exp] + in + let used_vars_body = find_e_ids body in + let lambda = + (* Work around indentation issues in Lem when translating + tuple or literal unit patterns to Isabelle *) + match fst (uncast_exp varstuple) with + | E_aux (E_tuple _, _) + when not (IdSet.mem (mk_id "varstup") used_vars_body)-> + separate space [string "fun varstup"; bigarrow] ^^ break 1 ^^ + separate space [string "let"; squote ^^ expY varstuple; string ":= varstup in"] + | E_aux (E_lit (L_aux (L_unit, _)), _) + when not (IdSet.mem (mk_id "unit_var") used_vars_body) -> + separate space [string "fun unit_var"; bigarrow] + | _ -> + separate space [string "fun"; expY varstuple; bigarrow] + in + parens ( + (prefix 2 1) + ((separate space) (string (combinator ^ csuffix ^ msuffix)::measure_pp@[expY varstuple])) + ((prefix 0 1) + (parens (prefix 2 1 (group lambda) (expN cond))) + (parens (prefix 2 1 (group lambda) (expN body)))) + ) end | Id_aux (Id "early_return", _) -> begin @@ -2191,7 +2206,9 @@ let types_used_with_generic_eq defs = | DEF_mapdef (MD_aux (_,(l,_))) | DEF_scattered (SD_aux (_,(l,_))) | DEF_measure (Id_aux (_,l),_,_) - -> unreachable l __POS__ "Internal definition found in the Coq back-end" + | DEF_loop_measures (Id_aux (_,l),_) + -> unreachable l __POS__ + "Definition found in the Coq back-end that should have been rewritten away" | DEF_internal_mutrec fds -> List.fold_left IdSet.union IdSet.empty (List.map typs_req_fundef fds) | DEF_val lb -> @@ -2925,6 +2942,10 @@ let rec doc_def unimplemented generic_eq_types def = | DEF_measure (id,_,_) -> unreachable (id_loc id) __POS__ ("Termination measure for " ^ string_of_id id ^ " should have been rewritten before backend") + | DEF_loop_measures (id,_) -> + unreachable (id_loc id) __POS__ + ("Loop termination measures for " ^ string_of_id id ^ + " should have been rewritten before backend") let find_exc_typ defs = let is_exc_typ_def = function diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index 6479a028..2daee940 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -715,11 +715,12 @@ let doc_exp_lem, doc_let_lem = | _ -> raise (Reporting.err_unreachable l __POS__ "Unexpected number of arguments for loop combinator") end - | Id_aux (Id (("while#" | "until#") as combinator), _) -> - let combinator = String.sub combinator 0 (String.length combinator - 1) in + | Id_aux (Id (("while#" | "until#" | "while#t" | "until#t") as combinator), _) -> + let combinator = String.sub combinator 0 (String.index combinator '#') in begin match args with - | [cond; varstuple; body] -> + | [cond; varstuple; body] + | [cond; varstuple; body; _] -> (* Ignore termination measures - not used in Lem *) let return (E_aux (e, a)) = E_aux (E_internal_return (E_aux (e, a)), a) in let csuffix, cond, body = match effectful (effect_of cond), effectful (effect_of body) with @@ -1485,6 +1486,7 @@ let rec doc_def_lem type_env def = | DEF_mapdef (MD_aux (_, (l, _))) -> unreachable l __POS__ "Lem doesn't support mappings" | DEF_pragma _ -> empty | DEF_measure _ -> empty (* we might use these in future *) + | DEF_loop_measures _ -> empty let find_exc_typ defs = let is_exc_typ_def = function diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index 7f3a2b63..e46f784e 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -387,10 +387,10 @@ let rec doc_exp (E_aux (e_aux, _) as exp) = | E_list exps -> string "[|" ^^ separate_map (comma ^^ space) doc_exp exps ^^ string "|]" | E_cons (exp1, exp2) -> doc_atomic_exp exp1 ^^ space ^^ string "::" ^^ space ^^ doc_exp exp2 | E_record fexps -> separate space [string "struct"; string "{"; doc_fexps fexps; string "}"] - | E_loop (While, cond, exp) -> - separate space [string "while"; doc_exp cond; string "do"; doc_exp exp] - | E_loop (Until, cond, exp) -> - separate space [string "repeat"; doc_exp exp; string "until"; doc_exp cond] + | E_loop (While, measure, cond, exp) -> + separate space ([string "while"] @ doc_measure measure @ [doc_exp cond; string "do"; doc_exp exp]) + | E_loop (Until, measure, cond, exp) -> + separate space ([string "repeat"] @ doc_measure measure @ [doc_exp exp; string "until"; doc_exp cond]) | E_record_update (exp, fexps) -> separate space [string "{"; doc_exp exp; string "with"; doc_fexps fexps; string "}"] | E_vector_append (exp1, exp2) -> separate space [doc_atomic_exp exp1; string "@"; doc_atomic_exp exp2] @@ -429,6 +429,10 @@ let rec doc_exp (E_aux (e_aux, _) as exp) = | E_app (id, [exp]) when Id.compare (mk_id "pow2") id == 0 -> separate space [string "2"; string "^"; doc_atomic_exp exp] | _ -> doc_atomic_exp exp +and doc_measure (Measure_aux (m_aux, _)) = + match m_aux with + | Measure_none -> [] + | Measure_some exp -> [string "termination_measure"; braces (doc_exp exp)] and doc_infix n (E_aux (e_aux, _) as exp) = match e_aux with | E_app_infix (l, op, r) when n < 10 -> @@ -643,6 +647,13 @@ let doc_prec = function | InfixL -> string "infixl" | InfixR -> string "infixr" +let doc_loop_measures l = + separate_map (comma ^^ break 1) + (function (Loop (l,e)) -> + string (match l with While -> "while" | Until -> "until") ^^ + space ^^ doc_exp e) + l + let rec doc_scattered (SD_aux (sd_aux, _)) = match sd_aux with | SD_function (_, _, _, id) -> @@ -679,6 +690,8 @@ let rec doc_def def = group (match def with | DEF_measure (id,pat,exp) -> string "termination_measure" ^^ space ^^ doc_id id ^/^ doc_pat pat ^^ space ^^ equals ^/^ doc_exp exp + | DEF_loop_measures (id,measures) -> + string "termination_measure" ^^ space ^^ doc_id id ^/^ doc_loop_measures measures | DEF_pragma (pragma, arg, l) -> string ("$" ^ pragma ^ " " ^ arg) | DEF_fixity (prec, n, id) -> diff --git a/src/rewriter.ml b/src/rewriter.ml index edf0d4a5..2573a135 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -151,7 +151,7 @@ let fix_eff_exp (E_aux (e,((l,_) as annot))) = match destruct_tannot (snd annot) union_effects (fun_app_effects f env) (union_eff_exps [e1;e2]) | E_if (e1,e2,e3) -> union_eff_exps [e1;e2;e3] | E_for (_,e1,e2,e3,_,e4) -> union_eff_exps [e1;e2;e3;e4] - | E_loop (_,e1,e2) -> union_eff_exps [e1;e2] + | E_loop (_,_,e1,e2) -> union_eff_exps [e1;e2] | E_vector es -> union_eff_exps es | E_vector_access (e1,e2) -> union_eff_exps [e1;e2] | E_vector_subrange (e1,e2,e3) -> union_eff_exps [e1;e2;e3] @@ -280,8 +280,12 @@ let rewrite_exp rewriters (E_aux (exp,(l,annot)) as orig_exp) = | E_if (c,t,e) -> rewrap (E_if (rewrite c,rewrite t, rewrite e)) | E_for (id, e1, e2, e3, o, body) -> rewrap (E_for (id, rewrite e1, rewrite e2, rewrite e3, o, rewrite body)) - | E_loop (loop, e1, e2) -> - rewrap (E_loop (loop, rewrite e1, rewrite e2)) + | E_loop (loop, m, e1, e2) -> + let m = match m with + | Measure_aux (Measure_none,_) -> m + | Measure_aux (Measure_some exp,l) -> Measure_aux (Measure_some (rewrite exp),l) + in + rewrap (E_loop (loop, m, rewrite e1, rewrite e2)) | E_vector exps -> rewrap (E_vector (List.map rewrite exps)) | E_vector_access (vec,index) -> rewrap (E_vector_access (rewrite vec,rewrite index)) | E_vector_subrange (vec,i1,i2) -> @@ -362,8 +366,9 @@ let rewrite_def rewriters d = match d with | DEF_internal_mutrec fdefs -> DEF_internal_mutrec (List.map (rewriters.rewrite_fun rewriters) fdefs) | DEF_val letbind -> DEF_val (rewriters.rewrite_let rewriters letbind) | DEF_pragma (pragma, arg, l) -> DEF_pragma (pragma, arg, l) - | DEF_scattered _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "DEF_scattered survived to rewritter") + | DEF_scattered _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "DEF_scattered survived to rewriter") | DEF_measure (id,pat,exp) -> DEF_measure (id,rewriters.rewrite_pat rewriters pat, rewriters.rewrite_exp rewriters exp) + | DEF_loop_measures (id,_) -> raise (Reporting.err_unreachable (id_loc id) __POS__ "DEF_loop_measures survived to rewriter") let rewrite_defs_base rewriters (Defs defs) = let rec rewrite ds = match ds with @@ -539,7 +544,7 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux, ; e_tuple : 'exp list -> 'exp_aux ; e_if : 'exp * 'exp * 'exp -> 'exp_aux ; e_for : id * 'exp * 'exp * 'exp * Ast.order * 'exp -> 'exp_aux - ; e_loop : loop * 'exp * 'exp -> 'exp_aux + ; e_loop : loop * ('exp option * Parse_ast.l) * 'exp * 'exp -> 'exp_aux ; e_vector : 'exp list -> 'exp_aux ; e_vector_access : 'exp * 'exp -> 'exp_aux ; e_vector_subrange : 'exp * 'exp * 'exp -> 'exp_aux @@ -602,8 +607,12 @@ let rec fold_exp_aux alg = function | E_if (e1,e2,e3) -> alg.e_if (fold_exp alg e1, fold_exp alg e2, fold_exp alg e3) | E_for (id,e1,e2,e3,order,e4) -> alg.e_for (id,fold_exp alg e1, fold_exp alg e2, fold_exp alg e3, order, fold_exp alg e4) - | E_loop (loop_type, e1, e2) -> - alg.e_loop (loop_type, fold_exp alg e1, fold_exp alg e2) + | E_loop (loop_type, m, e1, e2) -> + let m = match m with + | Measure_aux (Measure_none,l) -> None,l + | Measure_aux (Measure_some exp,l) -> Some (fold_exp alg exp),l + in + alg.e_loop (loop_type, m, fold_exp alg e1, fold_exp alg e2) | E_vector es -> alg.e_vector (List.map (fold_exp alg) es) | E_vector_access (e1,e2) -> alg.e_vector_access (fold_exp alg e1, fold_exp alg e2) | E_vector_subrange (e1,e2,e3) -> @@ -681,7 +690,9 @@ let id_exp_alg = ; e_tuple = (fun es -> E_tuple es) ; e_if = (fun (e1,e2,e3) -> E_if (e1,e2,e3)) ; e_for = (fun (id,e1,e2,e3,order,e4) -> E_for (id,e1,e2,e3,order,e4)) - ; e_loop = (fun (lt, e1, e2) -> E_loop (lt, e1, e2)) + ; e_loop = (fun (lt, (m,l), e1, e2) -> + let m = match m with None -> Measure_none | Some e -> Measure_some e in + E_loop (lt, Measure_aux (m,l), e1, e2)) ; e_vector = (fun es -> E_vector es) ; e_vector_access = (fun (e1,e2) -> E_vector_access (e1,e2)) ; e_vector_subrange = (fun (e1,e2,e3) -> E_vector_subrange (e1,e2,e3)) @@ -776,8 +787,12 @@ let compute_exp_alg bot join = ; e_if = (fun ((v1,e1),(v2,e2),(v3,e3)) -> (join_list [v1;v2;v3], E_if (e1,e2,e3))) ; e_for = (fun (id,(v1,e1),(v2,e2),(v3,e3),order,(v4,e4)) -> (join_list [v1;v2;v3;v4], E_for (id,e1,e2,e3,order,e4))) - ; e_loop = (fun (lt, (v1, e1), (v2, e2)) -> - (join_list [v1;v2], E_loop (lt, e1, e2))) + ; e_loop = (fun (lt, (m,l), (v1, e1), (v2, e2)) -> + let vs,m = match m with + | None -> [], Measure_none + | Some (v,e) -> [v], Measure_some e + in + (join_list (vs@[v1;v2]), E_loop (lt, Measure_aux (m,l), e1, e2))) ; e_vector = split_join (fun es -> E_vector es) ; e_vector_access = (fun ((v1,e1),(v2,e2)) -> (join v1 v2, E_vector_access (e1,e2))) ; e_vector_subrange = (fun ((v1,e1),(v2,e2),(v3,e3)) -> (join_list [v1;v2;v3], E_vector_subrange (e1,e2,e3))) @@ -878,7 +893,8 @@ let pure_exp_alg bot join = ; e_tuple = join_list ; e_if = (fun (v1,v2,v3) -> join_list [v1;v2;v3]) ; e_for = (fun (id,v1,v2,v3,order,v4) -> join_list [v1;v2;v3;v4]) - ; e_loop = (fun (lt, v1, v2) -> join v1 v2) + ; e_loop = (fun (lt, (m,_), v1, v2) -> + let v = join v1 v2 in match m with None -> v | Some v' -> join v v') ; e_vector = join_list ; e_vector_access = (fun (v1,v2) -> join v1 v2) ; e_vector_subrange = (fun (v1,v2,v3) -> join_list [v1;v2;v3]) @@ -927,3 +943,200 @@ let pure_exp_alg bot join = ; lB_aux = (fun (vl,annot) -> vl) ; pat_alg = pure_pat_alg bot join } + +let default_fold_fexp f x (FE_aux (FE_Fexp (id,e),annot)) = + let x,e = f x e in + x, FE_aux (FE_Fexp (id,e),annot) + +let default_fold_pexp f x (Pat_aux (pe,ann)) = + let x,pe = match pe with + | Pat_exp (p,e) -> + let x,e = f x e in + x,Pat_exp (p,e) + | Pat_when (p,e1,e2) -> + let x,e1 = f x e1 in + let x,e2 = f x e2 in + x,Pat_when (p,e1,e2) + in x, Pat_aux (pe,ann) + +let default_fold_letbind f x (LB_aux (LB_val (p,e),ann)) = + let x,e = f x e in + x, LB_aux (LB_val (p,e),ann) + +let rec default_fold_lexp f x (LEXP_aux (le,ann) as lexp) = + let re le = LEXP_aux (le,ann) in + match le with + | LEXP_id _ + | LEXP_cast _ + -> x, lexp + | LEXP_deref e -> + let x, e = f x e in + x, re (LEXP_deref e) + | LEXP_memory (id,es) -> + let x,es = List.fold_left (fun (x,es) e -> + let x,e' = f x e in x,e'::es) (x,[]) es in + x, re (LEXP_memory (id, List.rev es)) + | LEXP_tup les -> + let x,les = List.fold_left (fun (x,les) le -> + let x,le' = default_fold_lexp f x le in x,le'::les) (x,[]) les in + x, re (LEXP_tup (List.rev les)) + | LEXP_vector_concat les -> + let x,les = List.fold_left (fun (x,les) le -> + let x,le' = default_fold_lexp f x le in x,le'::les) (x,[]) les in + x, re (LEXP_vector_concat (List.rev les)) + | LEXP_vector (le,e) -> + let x, le = default_fold_lexp f x le in + let x, e = f x e in + x, re (LEXP_vector (le,e)) + | LEXP_vector_range (le,e1,e2) -> + let x, le = default_fold_lexp f x le in + let x, e1 = f x e1 in + let x, e2 = f x e2 in + x, re (LEXP_vector_range (le,e1,e2)) + | LEXP_field (le,id) -> + let x, le = default_fold_lexp f x le in + x, re (LEXP_field (le,id)) + +let default_fold_exp f x (E_aux (e,ann) as exp) = + let re e = E_aux (e,ann) in + match e with + | E_block es -> + let x,es = List.fold_left (fun (x,es) e -> + let x,e' = f x e in x,e'::es) (x,[]) es in + x, re (E_block (List.rev es)) + | E_nondet es -> + let x,es = List.fold_left (fun (x,es) e -> + let x,e' = f x e in x,e'::es) (x,[]) es in + x, re (E_nondet (List.rev es)) + | E_id _ + | E_ref _ + | E_lit _ -> x, exp + | E_cast (typ,e) -> + let x,e = f x e in + x, re (E_cast (typ,e)) + | E_app (id,es) -> + let x,es = List.fold_left (fun (x,es) e -> + let x,e' = f x e in x,e'::es) (x,[]) es in + x, re (E_app (id, List.rev es)) + | E_app_infix (e1,id,e2) -> + let x,e1 = f x e1 in + let x,e2 = f x e2 in + x, re (E_app_infix (e1,id,e2)) + | E_tuple es -> + let x,es = List.fold_left (fun (x,es) e -> + let x,e' = f x e in x,e'::es) (x,[]) es in + x, re (E_tuple (List.rev es)) + | E_if (e1,e2,e3) -> + let x,e1 = f x e1 in + let x,e2 = f x e2 in + let x,e3 = f x e3 in + x, re (E_if (e1,e2,e3)) + | E_for (id,e1,e2,e3,order,e4) -> + let x,e1 = f x e1 in + let x,e2 = f x e2 in + let x,e3 = f x e3 in + let x,e4 = f x e4 in + x, re (E_for (id,e1,e2,e3,order,e4)) + | E_loop (loop_type, m, e1, e2) -> + let x,m = match m with + | Measure_aux (Measure_none,_) -> x,m + | Measure_aux (Measure_some exp,l) -> + let x, exp = f x exp in + x, Measure_aux (Measure_some exp,l) + in + let x,e1 = f x e1 in + let x,e2 = f x e2 in + x, re (E_loop (loop_type, m, e1, e2)) + | E_vector es -> + let x,es = List.fold_left (fun (x,es) e -> + let x,e' = f x e in x,e'::es) (x,[]) es in + x, re (E_vector (List.rev es)) + | E_vector_access (e1,e2) -> + let x,e1 = f x e1 in + let x,e2 = f x e2 in + x, re (E_vector_access (e1,e2)) + | E_vector_subrange (e1,e2,e3) -> + let x,e1 = f x e1 in + let x,e2 = f x e2 in + let x,e3 = f x e3 in + x, re (E_vector_subrange (e1,e2,e3)) + | E_vector_update (e1,e2,e3) -> + let x,e1 = f x e1 in + let x,e2 = f x e2 in + let x,e3 = f x e3 in + x, re (E_vector_update (e1,e2,e3)) + | E_vector_update_subrange (e1,e2,e3,e4) -> + let x,e1 = f x e1 in + let x,e2 = f x e2 in + let x,e3 = f x e3 in + let x,e4 = f x e4 in + x, re (E_vector_update_subrange (e1,e2,e3,e4)) + | E_vector_append (e1,e2) -> + let x,e1 = f x e1 in + let x,e2 = f x e2 in + x, re (E_vector_append (e1,e2)) + | E_list es -> + let x,es = List.fold_left (fun (x,es) e -> + let x,e' = f x e in x,e'::es) (x,[]) es in + x, re (E_list (List.rev es)) + | E_cons (e1,e2) -> + let x,e1 = f x e1 in + let x,e2 = f x e2 in + x, re (E_cons (e1,e2)) + | E_record fexps -> + let x,fexps = List.fold_left (fun (x,fes) fe -> + let x,fe' = default_fold_fexp f x fe in x,fe'::fes) (x,[]) fexps in + x, re (E_record (List.rev fexps)) + | E_record_update (e,fexps) -> + let x,e = f x e in + let x,fexps = List.fold_left (fun (x,fes) fe -> + let x,fe' = default_fold_fexp f x fe in x,fe'::fes) (x,[]) fexps in + x, re (E_record_update (e, List.rev fexps)) + | E_field (e,id) -> + let x,e = f x e in x, re (E_field (e,id)) + | E_case (e,pexps) -> + let x,e = f x e in + let x,pexps = List.fold_left (fun (x,pes) pe -> + let x,pe' = default_fold_pexp f x pe in x,pe'::pes) (x,[]) pexps in + x, re (E_case (e, List.rev pexps)) + | E_try (e,pexps) -> + let x,e = f x e in + let x,pexps = List.fold_left (fun (x,pes) pe -> + let x,pe' = default_fold_pexp f x pe in x,pe'::pes) (x,[]) pexps in + x, re (E_try (e, List.rev pexps)) + | E_let (letbind,e) -> + let x,letbind = default_fold_letbind f x letbind in + let x,e = f x e in + x, re (E_let (letbind,e)) + | E_assign (lexp,e) -> + let x,lexp = default_fold_lexp f x lexp in + let x,e = f x e in + x, re (E_assign (lexp,e)) + | E_sizeof _ + | E_constraint _ + -> x,exp + | E_exit e -> + let x,e = f x e in x, re (E_exit e) + | E_throw e -> + let x,e = f x e in x, re (E_throw e) + | E_return e -> + let x,e = f x e in x, re (E_return e) + | E_assert(e1,e2) -> + let x,e1 = f x e1 in + let x,e2 = f x e2 in + x, re (E_assert (e1,e2)) + | E_var (lexp,e1,e2) -> + let x,lexp = default_fold_lexp f x lexp in + let x,e1 = f x e1 in + let x,e2 = f x e2 in + x, re (E_var (lexp,e1,e2)) + | E_internal_plet (pat,e1,e2) -> + let x,e1 = f x e1 in + let x,e2 = f x e2 in + x, re (E_internal_plet (pat,e1,e2)) + | E_internal_return e -> + let x,e = f x e in x, re (E_internal_return e) + | E_internal_value _ -> x,exp + +let rec foldin_exp f x e = f (default_fold_exp (foldin_exp f)) x e +let rec foldin_pexp f x e = default_fold_pexp (foldin_exp f) x e diff --git a/src/rewriter.mli b/src/rewriter.mli index ab29d1d9..878e0d15 100644 --- a/src/rewriter.mli +++ b/src/rewriter.mli @@ -128,7 +128,7 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux, ; e_tuple : 'exp list -> 'exp_aux ; e_if : 'exp * 'exp * 'exp -> 'exp_aux ; e_for : id * 'exp * 'exp * 'exp * Ast.order * 'exp -> 'exp_aux - ; e_loop : loop * 'exp * 'exp -> 'exp_aux + ; e_loop : loop * ('exp option * Parse_ast.l) * 'exp * 'exp -> 'exp_aux ; e_vector : 'exp list -> 'exp_aux ; e_vector_access : 'exp * 'exp -> 'exp_aux ; e_vector_subrange : 'exp * 'exp * 'exp -> 'exp_aux @@ -254,3 +254,7 @@ val fix_eff_pexp : tannot pexp -> tannot pexp val fix_eff_fexp : tannot fexp -> tannot fexp val fix_eff_opt_default : tannot opt_default -> tannot opt_default + +(* In-order fold over expressions *) +val foldin_exp : (('a -> 'b exp -> 'a * 'b exp) -> 'a -> 'b exp -> 'a * 'b exp) -> 'a -> 'b exp -> 'a * 'b exp +val foldin_pexp : (('a -> 'b exp -> 'a * 'b exp) -> 'a -> 'b exp -> 'a * 'b exp) -> 'a -> 'b pexp -> 'a * 'b pexp diff --git a/src/rewrites.ml b/src/rewrites.ml index e148cee4..39920e33 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2369,10 +2369,15 @@ let rewrite_defs_letbind_effects env = n_exp_name by (fun by -> let body = n_exp_term (effectful body) body in k (rewrap (E_for (id,start,stop,by,dir,body)))))) - | E_loop (loop, cond, body) -> + | E_loop (loop, measure, cond, body) -> + let measure = match measure with + | Measure_aux (Measure_none,_) -> measure + | Measure_aux (Measure_some exp,l) -> + Measure_aux (Measure_some (n_exp_term false exp),l) + in let cond = n_exp_term (effectful cond) cond in let body = n_exp_term (effectful body) body in - k (rewrap (E_loop (loop,cond,body))) + k (rewrap (E_loop (loop,measure,cond,body))) | E_vector exps -> n_exp_nameL exps (fun exps -> k (rewrap (E_vector exps))) @@ -3448,7 +3453,7 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = el env (typ_of exp4)))) el env (typ_of exp4)) in Added_vars (v, tuple_pat (if overwrite then varpats else pat :: varpats)) - | E_loop(loop,cond,body) -> + | E_loop(loop,Measure_aux (measure,_),cond,body) -> (* Find variables that might be updated in the loop body and are used either after or within the loop. *) let vars, varpats = @@ -3458,11 +3463,14 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = in let body = rewrite_var_updates (add_vars overwrite body vars) in let (E_aux (_,(_,bannot))) = body in - let fname = match loop with - | While -> "while#" - | Until -> "until#" in + let fname, measure = match loop, measure with + | While, Measure_none -> "while#", [] + | Until, Measure_none -> "until#", [] + | While, Measure_some exp -> "while#t", [exp] + | Until, Measure_some exp -> "until#t", [exp] + in let funcl = Id_aux (Id fname,gen_loc el) in - let v = E_aux (E_app (funcl,[cond;tuple_exp vars;body]), (gen_loc el, bannot)) in + let v = E_aux (E_app (funcl,[cond;tuple_exp vars;body]@measure), (gen_loc el, bannot)) in Added_vars (v, tuple_pat (if overwrite then varpats else pat :: varpats)) | E_if (c,e1,e2) -> let vars, varpats = @@ -3763,8 +3771,10 @@ let rewrite_defs_remove_e_assign env (Defs defs) = let (Defs loop_specs) = fst (Type_error.check Env.empty (Defs (List.map gen_vs [("foreach#", "forall ('vars : Type). (int, int, int, bool, 'vars, 'vars) -> 'vars"); ("while#", "forall ('vars : Type). (bool, 'vars, 'vars) -> 'vars"); - ("until#", "forall ('vars : Type). (bool, 'vars, 'vars) -> 'vars")]))) in - let rewrite_exp _ e = + ("until#", "forall ('vars : Type). (bool, 'vars, 'vars) -> 'vars"); + ("while#t", "forall ('vars : Type). (bool, 'vars, 'vars, int) -> 'vars"); + ("until#t", "forall ('vars : Type). (bool, 'vars, 'vars, int) -> 'vars")]))) in + let rewrite_exp _ e = replace_memwrite_e_assign (remove_reference_types (rewrite_var_updates e)) in rewrite_defs_base { rewrite_exp = rewrite_exp @@ -4438,6 +4448,7 @@ let minimise_recursive_functions env (Defs defs) = | d -> d in Defs (List.map rewrite_def defs) +(* Move recursive function termination measures into the function definitions. *) let move_termination_measures env (Defs defs) = let scan_for id defs = let rec aux = function @@ -4632,6 +4643,59 @@ let remove_mapping_valspecs env (Defs defs) = Defs (List.filter allowed_def defs) +(* Move loop termination measures into loop AST nodes. This is used before + type checking so that we avoid the complexity of type checking separate + measures. *) +let rec move_loop_measures (Defs defs) = + let loop_measures = + List.fold_left + (fun m d -> + match d with + | DEF_loop_measures (id, measures) -> + (* Allow multiple measure definitions, concatenating them *) + Bindings.add id + (match Bindings.find_opt id m with + | None -> measures + | Some m -> m @ measures) + m + | _ -> m) Bindings.empty defs + in + let do_exp exp_rec measures (E_aux (e,ann) as exp) = + match e, measures with + | E_loop (loop, _, e1, e2), (Loop (loop',exp))::t when loop = loop' -> + let t,e1 = exp_rec t e1 in + let t,e2 = exp_rec t e2 in + t,E_aux (E_loop (loop, Measure_aux (Measure_some exp, exp_loc exp), e1, e2),ann) + | _ -> exp_rec measures exp + in + let do_funcl (m,acc) (FCL_aux (FCL_Funcl (id, pexp),ann) as fcl) = + match Bindings.find_opt id m with + | Some measures -> + let measures,pexp = foldin_pexp do_exp measures pexp in + Bindings.add id measures m, (FCL_aux (FCL_Funcl (id, pexp),ann))::acc + | None -> m, fcl::acc + in + let unused,rev_defs = + List.fold_left + (fun (m,acc) d -> + match d with + | DEF_loop_measures _ -> m, acc + | DEF_fundef (FD_aux (FD_function (r,t,e,fcls),ann)) -> + let m,rfcls = List.fold_left do_funcl (m,[]) fcls in + m, (DEF_fundef (FD_aux (FD_function (r,t,e,List.rev rfcls),ann)))::acc + | _ -> m, d::acc) + (loop_measures,[]) defs + in let () = Bindings.iter + (fun id -> function + | [] -> () + | _::_ -> + Reporting.print_err (id_loc id) "Warning" + ("unused loop measure for function " ^ string_of_id id)) + unused + in Defs (List.rev rev_defs) + + + let opt_mono_rewrites = ref false let opt_mono_complex_nexps = ref true diff --git a/src/rewrites.mli b/src/rewrites.mli index 330f10b4..e30a4206 100644 --- a/src/rewrites.mli +++ b/src/rewrites.mli @@ -63,6 +63,9 @@ val opt_dmono_continue : bool ref (* Generate a fresh id with the given prefix *) val fresh_id : string -> l -> id +(* Move loop termination measures into loop AST nodes *) +val move_loop_measures : 'a defs -> 'a defs + (* Re-write undefined to functions created by -undefined_gen flag *) val rewrite_undefined : bool -> Env.t -> tannot defs -> tannot defs diff --git a/src/sail.ml b/src/sail.ml index 9c3a3d5c..b8be79f6 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -333,6 +333,9 @@ let load_files ?check:(check=false) type_envs files = -> 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 diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index 80bff0dd..8afc985d 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -205,7 +205,9 @@ let rec fv_of_exp consider_var bound used set (E_aux (e,(_,tannot))) : (Nameset. | E_for(id,from,to_,by,_,body) -> let _,used,set = list_fv bound used set [from;to_;by] in fv_of_exp consider_var (Nameset.add (string_of_id id) bound) used set body - | E_loop(_, cond, body) -> list_fv bound used set [cond; body] + | E_loop(_, measure, cond, body) -> + let m = match measure with Measure_aux (Measure_some exp,_) -> [exp] | _ -> [] in + list_fv bound used set (m @ [cond; body]) | E_vector_access(v,i) -> list_fv bound used set [v;i] | E_vector_subrange(v,i1,i2) -> list_fv bound used set [v;i1;i2] | E_vector_update(v,i,e) -> list_fv bound used set [v;i;e] @@ -509,6 +511,8 @@ let fv_of_def consider_var consider_scatter_as_one all_defs = function ((fun (_,u,_) -> Nameset.singleton ("measure:"^i),u) (fv_of_pes consider_var mt used mt [Pat_aux(Pat_exp (pat,exp),(Unknown,Type_check.empty_tannot))])) + | DEF_loop_measures(id,_) -> + Reporting.unreachable (id_loc id) __POS__ "Loop termination measures should be rewritten before now" let group_defs consider_scatter_as_one (Ast.Defs defs) = @@ -823,7 +827,7 @@ let nexp_subst_fns substs = | E_tuple es -> re (E_tuple (List.map s_exp es)) | E_if (e1,e2,e3) -> re (E_if (s_exp e1, s_exp e2, s_exp e3)) | E_for (id,e1,e2,e3,ord,e4) -> re (E_for (id,s_exp e1,s_exp e2,s_exp e3,ord,s_exp e4)) - | E_loop (loop,e1,e2) -> re (E_loop (loop,s_exp e1,s_exp e2)) + | E_loop (loop,m,e1,e2) -> re (E_loop (loop,s_measure m,s_exp e1,s_exp e2)) | E_vector es -> re (E_vector (List.map s_exp es)) | E_vector_access (e1,e2) -> re (E_vector_access (s_exp e1,s_exp e2)) | E_vector_subrange (e1,e2,e3) -> re (E_vector_subrange (s_exp e1,s_exp e2,s_exp e3)) @@ -846,6 +850,12 @@ let nexp_subst_fns substs = | E_internal_return e -> re (E_internal_return (s_exp e)) | E_throw e -> re (E_throw (s_exp e)) | E_try (e,cases) -> re (E_try (s_exp e, List.map s_pexp cases)) + and s_measure (Measure_aux (m,l)) = + let m = match m with + | Measure_none -> m + | Measure_some exp -> Measure_some (s_exp exp) + in + Measure_aux (m,l) and s_fexp (FE_aux (FE_Fexp (id,e), (l,annot))) = FE_aux (FE_Fexp (id,s_exp e),(l,s_tannot annot)) and s_pexp = function diff --git a/src/type_check.ml b/src/type_check.ml index d5d42316..53bf02fa 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -3696,10 +3696,15 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = in try_overload ([], Env.get_overloads f env) | E_app (f, xs) -> infer_funapp l env f xs None - | E_loop (loop_type, cond, body) -> + | E_loop (loop_type, measure, cond, body) -> let checked_cond = crule check_exp env cond bool_typ in + let checked_measure = match measure with + | Measure_aux (Measure_none,l) -> Measure_aux (Measure_none,l) + | Measure_aux (Measure_some exp,l) -> + Measure_aux (Measure_some (crule check_exp env exp int_typ),l) + in let checked_body = crule check_exp (add_opt_constraint (assert_constraint env true checked_cond) env) body unit_typ in - annot_exp (E_loop (loop_type, checked_cond, checked_body)) unit_typ + annot_exp (E_loop (loop_type, checked_measure, checked_cond, checked_body)) unit_typ | E_for (v, f, t, step, ord, body) -> begin let f, t, is_dec = match ord with @@ -4372,10 +4377,18 @@ and propagate_exp_effect_aux = function let p_body = propagate_exp_effect body in E_for (v, p_f, p_t, p_step, ord, p_body), collect_effects [p_f; p_t; p_step; p_body] - | E_loop (loop_type, cond, body) -> + | E_loop (loop_type, measure, cond, body) -> let p_cond = propagate_exp_effect cond in + let () = match measure with + | Measure_aux (Measure_some exp,l) -> + let eff = effect_of (propagate_exp_effect exp) in + if (BESet.is_empty (effect_set eff) || !opt_no_effects) + then () + else typ_error (env_of exp) l ("Loop termination measure with effects " ^ string_of_effect eff) + | _ -> () + in let p_body = propagate_exp_effect body in - E_loop (loop_type, p_cond, p_body), + E_loop (loop_type, measure, p_cond, p_body), union_effects (effect_of p_cond) (effect_of p_body) | E_let (letbind, exp) -> let p_lb, eff = propagate_letbind_effect letbind in @@ -5016,6 +5029,9 @@ and check_def : 'a. Env.t -> 'a def -> (tannot def) list * Env.t = | DEF_reg_dec (DEC_aux (DEC_typ_alias (typ, id, aspec), (l, tannot))) -> cd_err () | DEF_scattered sdef -> check_scattered env sdef | DEF_measure (id, pat, exp) -> [check_termination_measure_decl env (id, pat, exp)], env + | DEF_loop_measures (id, _) -> + Reporting.unreachable (id_loc id) __POS__ + "Loop termination measures should have been rewritten before type checking" and check_defs : 'a. int -> int -> Env.t -> 'a def list -> tannot defs * Env.t = fun n total env defs -> -- cgit v1.2.3 From 4529e0acc377bed4d1bab4230f4023e4bee3ae85 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 15 Apr 2019 14:35:02 +0100 Subject: Fix: Allow zero-length vector literals --- src/jib/jib_compile.ml | 37 +++++++++++++++++++++++-------------- src/parser.mly | 2 ++ 2 files changed, 25 insertions(+), 14 deletions(-) (limited to 'src') diff --git a/src/jib/jib_compile.ml b/src/jib/jib_compile.ml index f977193a..a59f6c80 100644 --- a/src/jib/jib_compile.ml +++ b/src/jib/jib_compile.ml @@ -254,23 +254,32 @@ let rec compile_aval l ctx = function (F_id gs, ctyp), [iclear ctyp gs] - | AV_vector ([], _) -> - raise (Reporting.err_general l "Encountered empty vector literal") + | AV_vector ([], typ) -> + let vector_ctyp = ctyp_of_typ ctx typ in + begin match ctyp_of_typ ctx typ with + | CT_fbits (0, _) -> + [], (F_lit (V_bits []), vector_ctyp), [] + | _ -> + let gs = ngensym () in + [idecl vector_ctyp gs; + iextern (CL_id (gs, vector_ctyp)) (mk_id "internal_vector_init") [(F_lit (V_int Big_int.zero), CT_fint 64)]], + (F_id gs, vector_ctyp), + [iclear vector_ctyp gs] + end (* Convert a small bitvector to a uint64_t literal. *) | AV_vector (avals, typ) when is_bitvector avals && List.length avals <= 64 -> - begin - let bitstring = F_lit (V_bits (List.map value_of_aval_bit avals)) in - let len = List.length avals in - match destruct_vector ctx.tc_env typ with - | Some (_, Ord_aux (Ord_inc, _), _) -> - [], (bitstring, CT_fbits (len, false)), [] - | Some (_, Ord_aux (Ord_dec, _), _) -> - [], (bitstring, CT_fbits (len, true)), [] - | Some _ -> - raise (Reporting.err_general l "Encountered order polymorphic bitvector literal") - | None -> - raise (Reporting.err_general l "Encountered vector literal without vector type") + let bitstring = F_lit (V_bits (List.map value_of_aval_bit avals)) in + let len = List.length avals in + begin match destruct_vector ctx.tc_env typ with + | Some (_, Ord_aux (Ord_inc, _), _) -> + [], (bitstring, CT_fbits (len, false)), [] + | Some (_, Ord_aux (Ord_dec, _), _) -> + [], (bitstring, CT_fbits (len, true)), [] + | Some _ -> + raise (Reporting.err_general l "Encountered order polymorphic bitvector literal") + | None -> + raise (Reporting.err_general l "Encountered vector literal without vector type") end (* Convert a bitvector literal that is larger than 64-bits to a diff --git a/src/parser.mly b/src/parser.mly index 5e448a05..8c4475c4 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -1064,6 +1064,8 @@ atomic_exp: { mk_exp (E_record $3) $startpos $endpos } | Lcurly exp With fexp_exp_list Rcurly { mk_exp (E_record_update ($2, $4)) $startpos $endpos } + | Lsquare Rsquare + { mk_exp (E_vector []) $startpos $endpos } | Lsquare exp_list Rsquare { mk_exp (E_vector $2) $startpos $endpos } | Lsquare exp With atomic_exp Eq exp Rsquare -- cgit v1.2.3 From 23f39ad36659e7d46a3c1799e217bab22eca7869 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Tue, 16 Apr 2019 14:33:26 +0100 Subject: Also allow "repeat" in loop termination measure syntax --- src/parser.mly | 2 ++ 1 file changed, 2 insertions(+) (limited to 'src') diff --git a/src/parser.mly b/src/parser.mly index a1e93388..f764995a 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -1414,6 +1414,8 @@ scattered_clause: loop_measure: | Until exp { Loop (Until, $2) } + | Repeat exp + { Loop (Until, $2) } | While exp { Loop (While, $2) } -- cgit v1.2.3 From 70c1ab20b8b5539f4efedff84bea68f7683d1aec Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Tue, 16 Apr 2019 14:38:35 +0100 Subject: Coq: don't record assertions in the context if Sail doesn't This can massively reduce Coq's typechecking time on assertion heavy code, such as the builtins tests. --- src/pretty_print_coq.ml | 11 ++++++++--- src/type_check.mli | 2 ++ 2 files changed, 10 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index ae0e1561..07f70c42 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -1994,9 +1994,14 @@ let doc_exp, doc_let = match pat, e1, e2 with | (P_aux (P_wild,_) | P_aux (P_typ (_, P_aux (P_wild, _)), _)), (E_aux (E_assert (assert_e1,assert_e2),_)), _ -> - let epp = liftR (separate space [string "assert_exp'"; expY assert_e1; expY assert_e2]) in - let epp = infix 0 1 (string ">>= fun _ =>") epp (top_exp new_ctxt false e2) in - if aexp_needed then parens (align epp) else align epp + let assert_fn, mid = + match assert_constraint outer_env true assert_e1 with + | Some _ -> "assert_exp'", ">>= fun _ =>" + | None -> "assert_exp", ">>" + in + let epp = liftR (separate space [string assert_fn; expY assert_e1; expY assert_e2]) in + let epp = infix 0 1 (string mid) epp (top_exp new_ctxt false e2) in + if aexp_needed then parens (align epp) else align epp | _ -> let epp = let middle = diff --git a/src/type_check.mli b/src/type_check.mli index 2a413238..dcedcc90 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -319,6 +319,8 @@ val check_fundef : Env.t -> 'a fundef -> tannot def list * Env.t val check_val_spec : Env.t -> 'a val_spec -> tannot def list * Env.t +val assert_constraint : Env.t -> bool -> tannot exp -> n_constraint option + (** Attempt to prove a constraint using z3. Returns true if z3 can prove that the constraint is true, returns false if z3 cannot prove the constraint true. Note that this does not guarantee that the -- cgit v1.2.3 From 3918354ab84347efaacd14954f0d04e0b7c7ee75 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 15 Apr 2019 14:41:51 +0100 Subject: Fix: Don't repeat ctyp_of_typ call --- src/jib/jib_compile.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/jib/jib_compile.ml b/src/jib/jib_compile.ml index a59f6c80..f901d948 100644 --- a/src/jib/jib_compile.ml +++ b/src/jib/jib_compile.ml @@ -256,7 +256,7 @@ let rec compile_aval l ctx = function | AV_vector ([], typ) -> let vector_ctyp = ctyp_of_typ ctx typ in - begin match ctyp_of_typ ctx typ with + begin match vector_ctyp with | CT_fbits (0, _) -> [], (F_lit (V_bits []), vector_ctyp), [] | _ -> @@ -277,12 +277,12 @@ let rec compile_aval l ctx = function | Some (_, Ord_aux (Ord_dec, _), _) -> [], (bitstring, CT_fbits (len, true)), [] | Some _ -> - raise (Reporting.err_general l "Encountered order polymorphic bitvector literal") + raise (Reporting.err_general l "Encountered order polymorphic bitvector literal") | None -> raise (Reporting.err_general l "Encountered vector literal without vector type") end - (* Convert a bitvector literal that is larger than 64-bits to a + (* Convert a bitvector literal that is larger than 64-bits to a variable size bitvector, converting it in 64-bit chunks. *) | AV_vector (avals, typ) when is_bitvector avals -> let len = List.length avals in -- cgit v1.2.3 From a6b9e85997879845d1317270696ceffff1c00127 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Tue, 16 Apr 2019 19:38:44 +0100 Subject: Temporarily remove Makefile part that is making Jenkins fail Comment out some interpreter tests that go into infinite loops because those will cause issues for Jenkins. --- src/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/Makefile b/src/Makefile index a002d4f3..5ff56330 100644 --- a/src/Makefile +++ b/src/Makefile @@ -103,7 +103,7 @@ sail: ast.ml jib.ml manifest.ml ocamlbuild -use-ocamlfind sail.native sail_lib.cma sail_lib.cmxa isail: ast.ml jib.ml manifest.ml - ocamlbuild -use-ocamlfind isail.native sail_lib.cma sail_lib.cmxa libsail.cma libsail.cmxa + ocamlbuild -use-ocamlfind isail.native sail_lib.cma sail_lib.cmxa coverage: ast.ml jib.ml manifest.ml -- cgit v1.2.3 From f091479ccfbe7861cd0620cef414887ccfe65090 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Wed, 17 Apr 2019 14:25:16 +0100 Subject: Build libsail again (removed Bytcode and Share_directory) --- src/Makefile | 2 +- src/libsail.mllib | 2 -- 2 files changed, 1 insertion(+), 3 deletions(-) (limited to 'src') diff --git a/src/Makefile b/src/Makefile index 5ff56330..a002d4f3 100644 --- a/src/Makefile +++ b/src/Makefile @@ -103,7 +103,7 @@ sail: ast.ml jib.ml manifest.ml ocamlbuild -use-ocamlfind sail.native sail_lib.cma sail_lib.cmxa isail: ast.ml jib.ml manifest.ml - ocamlbuild -use-ocamlfind isail.native sail_lib.cma sail_lib.cmxa + ocamlbuild -use-ocamlfind isail.native sail_lib.cma sail_lib.cmxa libsail.cma libsail.cmxa coverage: ast.ml jib.ml manifest.ml diff --git a/src/libsail.mllib b/src/libsail.mllib index 734a1381..1a992391 100644 --- a/src/libsail.mllib +++ b/src/libsail.mllib @@ -2,7 +2,6 @@ Anf Ast Ast_util Bitfield -Bytecode C_backend Cgen_backend Constant_fold @@ -48,7 +47,6 @@ Sail Sail2_values Sail_lib Scattered -Share_directory Spec_analysis Specialize State -- cgit v1.2.3 From 9e0f58f27966bf606bdc3ec06972bc294fbd362b Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Wed, 17 Apr 2019 18:30:40 +0100 Subject: Coq: support pure loops with termination measures --- src/pretty_print_coq.ml | 12 ++++++++++++ src/rewrites.ml | 25 +++++++++++++++++++++++++ 2 files changed, 37 insertions(+) (limited to 'src') diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 07f70c42..fb250245 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -1529,6 +1529,18 @@ let doc_exp, doc_let = | true, false -> "M", simple_bool cond, return body | true, true -> "M", simple_bool cond, body in + (* If rewrite_loops_with_escape_effect added a dummy assertion to + ensure that the loop can escape when it reaches the limit, omit + the dummy assert here. *) + let body = match body with + | E_aux (E_internal_plet + (P_aux ((P_wild | P_typ (_,P_aux (P_wild, _))),_), + E_aux (E_assert + (E_aux (E_lit (L_aux (L_true,_)),_), + E_aux (E_lit (L_aux (L_string "loop dummy assert",_)),_)) + ,_),body'),_) -> body' + | _ -> body + in let msuffix, measure_pp = match measure with | None -> "", [] diff --git a/src/rewrites.ml b/src/rewrites.ml index b56d097f..34d45618 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -4626,6 +4626,29 @@ let rewrite_explicit_measure env (Defs defs) = in Defs (List.flatten (List.map rewrite_def defs)) +(* Add a dummy assert to loops for backends that require loops to be able to + fail. Note that the Coq backend will spot the assert and omit it. *) +let rewrite_loops_with_escape_effect env defs = + let dummy_ann = Parse_ast.Unknown,empty_tannot in + let assert_exp = + E_aux (E_assert (E_aux (E_lit (L_aux (L_true,Unknown)),dummy_ann), + E_aux (E_lit (L_aux (L_string "loop dummy assert",Unknown)),dummy_ann)), + dummy_ann) + in + let rewrite_exp rws exp = + let (E_aux (e,ann) as exp) = Rewriter.rewrite_exp rws exp in + match e with + | E_loop (l,(Measure_aux (Measure_some _,_) as m),guard,body) -> + if has_effect (effect_of exp) BE_escape then exp else + let body = match body with + | E_aux (E_block es,ann) -> + E_aux (E_block (assert_exp::es),ann) + | _ -> E_aux (E_block [assert_exp;body],dummy_ann) + in E_aux (E_loop (l,m,guard,body),ann) + | _ -> exp + in + rewrite_defs_base { rewriters_base with rewrite_exp } defs + let recheck_defs env defs = fst (Type_error.check initial_env defs) let recheck_defs_without_effects env defs = let old = !opt_no_effects in @@ -4815,6 +4838,7 @@ let all_rewrites = [ ("minimise_recursive_functions", Basic_rewriter minimise_recursive_functions); ("move_termination_measures", Basic_rewriter move_termination_measures); ("rewrite_explicit_measure", Basic_rewriter rewrite_explicit_measure); + ("rewrite_loops_with_escape_effect", Basic_rewriter rewrite_loops_with_escape_effect); ("simple_types", Basic_rewriter rewrite_simple_types); ("overload_cast", Basic_rewriter rewrite_overload_cast); ("top_sort_defs", Basic_rewriter (fun _ -> top_sort_defs)); @@ -4908,6 +4932,7 @@ let rewrites_coq = [ ("recheck_defs_without_effects", []); ("make_cases_exhaustive", []); ("rewrite_explicit_measure", []); + ("rewrite_loops_with_escape_effect", []); ("recheck_defs_without_effects", []); ("fix_val_specs", []); ("remove_blocks", []); -- cgit v1.2.3 From d2b4e990d915a121c59cf58f2ea7a89348c0d55c Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Fri, 19 Apr 2019 14:44:48 +0100 Subject: Coq: when replacing n_constraints in types allow for some rearrangement (in particular, to cope with Type_check.simp_typ) --- src/pretty_print_coq.ml | 56 ++++++++++++++++++++++++++++++++++--------------- 1 file changed, 39 insertions(+), 17 deletions(-) (limited to 'src') diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index fb250245..f26c74d7 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -58,6 +58,15 @@ open Pretty_print_common module StringSet = Set.Make(String) +let rec list_contains cmp l1 = function + | [] -> Some l1 + | h::t -> + let rec remove = function + | [] -> None + | h'::t' -> if cmp h h' = 0 then Some t' + else Util.option_map (List.cons h') (remove t') + in Util.option_bind (fun l1' -> list_contains cmp l1' t) (remove l1) + let opt_undef_axioms = ref false let opt_debug_on : string list ref = ref [] @@ -549,6 +558,11 @@ let classify_ex_type ctxt env ?binding ?(rawbools=false) (Typ_aux (t,l) as t0) = | Typ_exist (kopts,_,t1) -> ExGeneral,kopts,t1 | _ -> ExNone,[],t0 +let rec flatten_nc (NC_aux (nc,l) as nc_full) = + match nc with + | NC_and (nc1,nc2) -> flatten_nc nc1 @ flatten_nc nc2 + | _ -> [nc_full] + (* When making changes here, check whether they affect coq_nvars_of_typ *) let rec doc_typ_fns ctx env = (* following the structure of parser for precedence *) @@ -729,15 +743,19 @@ and doc_nc_prop ?(top = true) ctx env nc = (fun m (v,(_,Typ_aux (typ,_))) -> match typ with | Typ_app (id, [A_aux (A_bool nc,_)]) when string_of_id id = "atom_bool" -> - NCMap.add nc v m - | _ -> m) NCMap.empty locals + (flatten_nc nc, v)::m + | _ -> m) [] locals in - let newnc f nc = - match NCMap.find_opt nc nc_id_map with - | Some id -> parens (doc_op equals (doc_id id) (string "true")) - | None -> f nc - in - let rec l85 (NC_aux (nc,_) as nc_full) = + 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_op equals (doc_id id) (string "true")) + | ((h::t),id)::_ -> parens (doc_op (string "/\\") (doc_op equals (doc_id id) (string "true")) (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 @@ -779,21 +797,25 @@ and doc_nc_prop ?(top = true) ctx env nc = (* Follows Coq precedence levels *) let rec 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 = 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" -> - NCMap.add nc v m - | _ -> m) NCMap.empty locals - in - let newnc f nc = - match NCMap.find_opt nc nc_id_map with - | Some id -> doc_id id - | None -> f nc + (flatten_nc nc, v)::m + | _ -> m) [] locals in - let nc = Env.expand_constraint_synonyms env nc in - let rec l70 (NC_aux (nc,_) as nc_full) = + 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)::_ -> doc_id id + | ((h::t),id)::_ -> parens (doc_op (string "&&") (doc_id id) (l10 (List.fold_left nc_and h t))) + | [] -> f nc + and l70 (NC_aux (nc,_) as nc_full) = match nc with | NC_equal (ne1, ne2) -> doc_op (string "=?") (doc_nexp ctx ne1) (doc_nexp ctx ne2) | NC_bounded_ge (ne1, ne2) -> doc_op (string ">=?") (doc_nexp ctx ne1) (doc_nexp ctx ne2) -- cgit v1.2.3 From e3aa6935bfe7bb1e92a5c70f3df4bd380149d03c Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Sat, 20 Apr 2019 11:58:53 +0100 Subject: Fix: Reduce constant-fold time for ARM from 20min+ to 10s With the new interpreter changes computing the initial state for the interpreter does some significant work. The existing code was re-computing the initial state for every subexpression in the specification (not even just the ones due to be constant-folded away). Now we just compute the initial state once and use it for all constant folds. Also reduce the time taken for the simple_assignments rewrite from 20s to under 1s for ARMv8.5, by skipping l-expressions that are already in the simplest form. --- src/constant_fold.ml | 3 ++- src/rewrites.ml | 4 ++++ 2 files changed, 6 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/constant_fold.ml b/src/constant_fold.ml index 14d6550c..f2e0add5 100644 --- a/src/constant_fold.ml +++ b/src/constant_fold.ml @@ -251,10 +251,11 @@ let rec rewrite_constant_function_calls' ast = let rewrite_count = ref 0 in let ok () = incr rewrite_count in let not_ok () = decr rewrite_count in + let istate = initial_state ast Type_check.initial_env in let rw_defs = { rewriters_base with - rewrite_exp = (fun _ -> rw_exp ok not_ok (initial_state ast Type_check.initial_env)) + rewrite_exp = (fun _ -> rw_exp 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 *) diff --git a/src/rewrites.ml b/src/rewrites.ml index 34d45618..a37449a4 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2153,6 +2153,10 @@ let rewrite_simple_assignments env defs = let assign_e_aux e_aux annot = let env = env_of_annot annot in match e_aux with + | E_assign (LEXP_aux (LEXP_id _, _), _) -> + E_aux (e_aux, annot) + | E_assign (LEXP_aux (LEXP_cast (_, _), _), _) -> + E_aux (e_aux, annot) | E_assign (lexp, exp) -> let (lexp, rhs) = rewrite_lexp_to_rhs lexp in let assign = mk_exp (E_assign (strip_lexp lexp, strip_exp (rhs exp))) in -- cgit v1.2.3 From 73b5f711029ea8dd7463f79277f7c01527c5e3bf Mon Sep 17 00:00:00 2001 From: Jon French Date: Thu, 25 Apr 2019 11:56:58 +0100 Subject: lem gen_lib: update read/write functions to take (dummy) addrsize argument as in other places --- src/gen_lib/sail2_prompt_monad.lem | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) (limited to 'src') diff --git a/src/gen_lib/sail2_prompt_monad.lem b/src/gen_lib/sail2_prompt_monad.lem index e0ac09f6..28c0a27e 100644 --- a/src/gen_lib/sail2_prompt_monad.lem +++ b/src/gen_lib/sail2_prompt_monad.lem @@ -170,8 +170,8 @@ let read_mem_bytes rk addr sz = (maybe_fail "nat_of_bv" (nat_of_bv addr)) (fun addr -> Read_mem rk addr (nat_of_int sz) return) -val read_mem : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv 'b 'e -let read_mem rk addr sz = +val read_mem : forall 'rv 'a 'b 'e 'addrsize. Bitvector 'a, Bitvector 'b => read_kind -> 'addrsize -> 'a -> integer -> monad 'rv 'b 'e +let read_mem rk addr_sz addr sz = bind (read_mem_bytes rk addr sz) (fun bytes -> @@ -185,15 +185,15 @@ let excl_result () = let k successful = (return successful) in Excl_res k -val write_mem_ea : forall 'rv 'a 'e. Bitvector 'a => write_kind -> 'a -> integer -> monad 'rv unit 'e -let write_mem_ea wk addr sz = +val write_mem_ea : forall 'rv 'a 'e 'addrsize. Bitvector 'a => write_kind -> 'addrsize -> 'a -> integer -> monad 'rv unit 'e +let write_mem_ea wk addr_size addr sz = bind (maybe_fail "nat_of_bv" (nat_of_bv addr)) (fun addr -> Write_ea wk addr (nat_of_int sz) (Done ())) -val write_mem : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => - write_kind -> 'a -> integer -> 'b -> monad 'rv bool 'e -let write_mem wk addr sz v = +val write_mem : forall 'rv 'a 'b 'e 'addrsize. Bitvector 'a, Bitvector 'b => + write_kind -> 'addrsize -> 'a -> integer -> 'b -> monad 'rv bool 'e +let write_mem wk addr_size addr sz v = match (mem_bytes_of_bits v, nat_of_bv addr) with | (Just v, Just addr) -> Write_mem wk addr (nat_of_int sz) v return -- cgit v1.2.3 From c5c2f3a9dc9c18463719647eb48ccccd84fbdc89 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Wed, 24 Apr 2019 11:44:01 +0100 Subject: Don't try to insert monomorphisation casts when the types are the same --- src/monomorphise.ml | 1 + 1 file changed, 1 insertion(+) (limited to 'src') diff --git a/src/monomorphise.ml b/src/monomorphise.ml index 9f273cb1..3f8a40e6 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -3182,6 +3182,7 @@ let make_bitvector_env_casts env quant_kids (kid,i) exp = if mut = Immutable then mk_cast var typ exp else exp) locals exp let make_bitvector_cast_exp cast_name cast_env quant_kids typ target_typ exp = + if alpha_equivalent cast_env typ target_typ then exp else let infer_arg_typ env f l typ = let (typq, ctor_typ) = Env.get_union_id f env in let quants = quant_items typq in -- cgit v1.2.3 From f2e6e822b69681f20d17344141efabca0131dddf Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Wed, 24 Apr 2019 11:44:24 +0100 Subject: Make constructor splitting in monomorphisation obey -dall_split_errors --- src/monomorphise.ml | 37 ++++++++++++++++++++++++------------- 1 file changed, 24 insertions(+), 13 deletions(-) (limited to 'src') diff --git a/src/monomorphise.ml b/src/monomorphise.ml index 3f8a40e6..a37ff69a 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -249,7 +249,18 @@ let rec size_nvars_nexp (Nexp_aux (ne,_)) = (* Given a type for a constructor, work out which refinements we ought to produce *) (* TODO collision avoidance *) -let split_src_type id ty (TypQ_aux (q,ql)) = +let split_src_type all_errors 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) + | Some flag -> begin + flag := false; + print_error error; + default + end + in let i = string_of_id id in (* This was originally written for the general case, but I cut it down to the more manageable prenex-form below *) @@ -259,9 +270,9 @@ let split_src_type id ty (TypQ_aux (q,ql)) = | Typ_var _ -> (KidSet.empty,[[],typ]) | Typ_fn _ -> - raise (Reporting.err_general l ("Function type in constructor " ^ i)) + cannot l ("Function type in constructor " ^ i) (KidSet.empty,[[],typ]) | Typ_bidir _ -> - raise (Reporting.err_general l ("Mapping type in constructor " ^ i)) + cannot l ("Mapping type in constructor " ^ i) (KidSet.empty,[[],typ]) | Typ_tup ts -> let (vars,tys) = List.split (List.map size_nvars_ty ts) in let insttys = List.map (fun x -> let (insts,tys) = List.split x in @@ -318,11 +329,10 @@ let split_src_type id ty (TypQ_aux (q,ql)) = | Typ_aux (Typ_tup _,_) -> Typ_aux (Typ_tup [ty],Unknown) | _ -> ty) tys in if contains_exist t then - raise (Reporting.err_general l - "Only prenex types in unions are supported by monomorphisation") + cannot l "Only prenex types in unions are supported by monomorphisation" [] else if List.length kids > 1 then - raise (Reporting.err_general l - "Only single-variable existential types in unions are currently supported by monomorphisation") + cannot l + "Only single-variable existential types in unions are currently supported by monomorphisation" [] else tys end | _ -> [] @@ -332,11 +342,11 @@ let split_src_type id ty (TypQ_aux (q,ql)) = match variants with | [] -> None | sample::__ -> - let () = if List.length variants > size_set_limit then - raise (Reporting.err_general ql - (string_of_int (List.length variants) ^ "variants for constructor " ^ i ^ - "bigger than limit " ^ string_of_int size_set_limit)) else () - in + if List.length variants > size_set_limit then + cannot ql + (string_of_int (List.length variants) ^ "variants for constructor " ^ i ^ + "bigger than limit " ^ string_of_int size_set_limit) None + else let wrap = match id with | Id_aux (Id i,l) -> (fun f -> Id_aux (Id (f i),Generated l)) | Id_aux (Operator i,l) -> (fun f -> Id_aux (Operator (f i),l)) @@ -616,9 +626,10 @@ let apply_pat_choices choices = let split_defs all_errors splits defs = let no_errors_happened = ref true in + let error_opt = if all_errors then Some no_errors_happened else None in let split_constructors (Defs defs) = let sc_type_union q (Tu_aux (Tu_ty_id (ty, id), l)) = - match split_src_type id ty q with + match split_src_type error_opt id ty q with | None -> ([],[Tu_aux (Tu_ty_id (ty,id),l)]) | Some variants -> ([(id,variants)], -- cgit v1.2.3 From d750f3e9256bba43d2eca33f0a4e9ad52e33e72e Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Thu, 25 Apr 2019 17:12:37 +0100 Subject: Get basic constructor monomorphisation working again - updates for type checking changes - handle a little more pattern matching in constant propagation - fix bug where false positive warnings were produced - ensure bitvectors in tuples are always monomorphised (to catch the case where the bitvectors only appear alone with a constant size) --- src/constant_propagation.ml | 183 ++++++++++++++++++++++---------------------- src/monomorphise.ml | 134 ++++++++++++++++---------------- 2 files changed, 160 insertions(+), 157 deletions(-) (limited to 'src') diff --git a/src/constant_propagation.ml b/src/constant_propagation.ml index 78f15d7d..51d079e9 100644 --- a/src/constant_propagation.ml +++ b/src/constant_propagation.ml @@ -655,12 +655,97 @@ let const_props defs ref_vars = | _ -> exp and can_match_with_env env (E_aux (e,(l,annot)) as exp0) cases (substs,ksubsts) assigns = - let rec findpat_generic check_pat description assigns = function + let rec check_exp_pat (E_aux (e,(l,annot))) (P_aux (p,(l',_))) = + match e with + | E_id id -> + (match Env.lookup_id id env with + | Enum _ -> begin + match p with + | P_id id' + | P_app (id',[]) -> + if Id.compare id id' = 0 then DoesMatch ([],[]) else DoesNotMatch + | _ -> + (Reporting.print_err l' "Monomorphisation" + "Unexpected kind of pattern for enumeration"; GiveUp) + end + | _ -> GiveUp) + | E_lit (L_aux (lit_e, lit_l)) -> begin + match p with + | P_lit (L_aux (lit_p, _)) -> + if lit_match (lit_e,lit_p) then DoesMatch ([],[]) else DoesNotMatch + | P_var (P_aux (P_id id,p_id_annot), TP_aux (TP_var kid, _)) -> + begin + match lit_e with + | L_num i -> + DoesMatch ([id, E_aux (e,(l,annot))], + [kid,Nexp_aux (Nexp_constant i,Unknown)]) + (* For undefined we fix the type-level size (because there's no good + way to construct an undefined size), but leave the term as undefined + to make the meaning clear. *) + | L_undef -> + let nexp = fabricate_nexp l annot in + let typ = subst_kids_typ (KBindings.singleton kid nexp) (typ_of_annot p_id_annot) in + DoesMatch ([id, E_aux (E_cast (typ,E_aux (e,(l,empty_tannot))),(l,empty_tannot))], + [kid,nexp]) + | _ -> + (Reporting.print_err lit_l "Monomorphisation" + "Unexpected kind of literal for var match"; GiveUp) + end + | _ -> + (Reporting.print_err l' "Monomorphisation" + "Unexpected kind of pattern for literal"; GiveUp) + end + | E_vector es when List.for_all (function (E_aux (E_lit _,_)) -> true | _ -> false) es -> begin + match p with + | P_vector ps -> + let matches = List.map2 (fun e p -> + match e, p with + | E_aux (E_lit (L_aux (lit,_)),_), P_aux (P_lit (L_aux (lit',_)),_) -> + if lit_match (lit,lit') then DoesMatch ([],[]) else DoesNotMatch + | E_aux (E_lit l,_), P_aux (P_id var,_) when pat_id_is_variable env var -> + DoesMatch ([var, e],[]) + | _ -> GiveUp) es ps in + let final = List.fold_left (fun acc m -> match acc, m with + | _, GiveUp -> GiveUp + | GiveUp, _ -> GiveUp + | DoesMatch (sub,ksub), DoesMatch(sub',ksub') -> DoesMatch(sub@sub',ksub@ksub') + | _ -> DoesNotMatch) (DoesMatch ([],[])) matches in + (match final with + | GiveUp -> + (Reporting.print_err l "Monomorphisation" + "Unexpected kind of pattern for vector literal"; GiveUp) + | _ -> final) + | _ -> + (Reporting.print_err l "Monomorphisation" + "Unexpected kind of pattern for vector literal"; GiveUp) + end + | E_cast (undef_typ, (E_aux (E_lit (L_aux (L_undef, lit_l)),_) as e_undef)) -> begin + match p with + | P_lit (L_aux (lit_p, _)) -> DoesNotMatch + | P_var (P_aux (P_id id,p_id_annot), TP_aux (TP_var kid, _)) -> + (* For undefined we fix the type-level size (because there's no good + way to construct an undefined size), but leave the term as undefined + to make the meaning clear. *) + let nexp = fabricate_nexp l annot in + let kids = equal_kids (env_of_annot p_id_annot) kid in + let ksubst = KidSet.fold (fun k b -> KBindings.add k nexp b) kids KBindings.empty in + let typ = subst_kids_typ ksubst (typ_of_annot p_id_annot) in + DoesMatch ([id, E_aux (E_cast (typ,e_undef),(l,empty_tannot))], + KBindings.bindings ksubst) + | _ -> + (Reporting.print_err l' "Monomorphisation" + "Unexpected kind of pattern for literal"; GiveUp) + end + | E_record _ | E_cast (_, E_aux (E_record _, _)) -> DoesNotMatch + | _ -> GiveUp + in + let check_pat = check_exp_pat exp0 in + let rec findpat_generic description assigns = function | [] -> (Reporting.print_err l "Monomorphisation" ("Failed to find a case for " ^ description); None) | [Pat_aux (Pat_exp (P_aux (P_wild,_),exp),_)] -> Some (exp,[],[]) | (Pat_aux (Pat_exp (P_aux (P_typ (_,p),_),exp),ann))::tl -> - findpat_generic check_pat description assigns ((Pat_aux (Pat_exp (p,exp),ann))::tl) + findpat_generic description assigns ((Pat_aux (Pat_exp (p,exp),ann))::tl) | (Pat_aux (Pat_exp (P_aux (P_id id',_),exp),_))::tlx when pat_id_is_variable env id' -> Some (exp, [(id', exp0)], []) @@ -670,12 +755,12 @@ let const_props defs ref_vars = let (E_aux (guard,_)),assigns = const_prop_exp substs assigns guard in match guard with | E_lit (L_aux (L_true,_)) -> Some (exp,[(id',exp0)],[]) - | E_lit (L_aux (L_false,_)) -> findpat_generic check_pat description assigns tl + | E_lit (L_aux (L_false,_)) -> findpat_generic description assigns tl | _ -> None end | (Pat_aux (Pat_when (p,guard,exp),_))::tl -> begin match check_pat p with - | DoesNotMatch -> findpat_generic check_pat description assigns tl + | DoesNotMatch -> findpat_generic description assigns tl | DoesMatch (vsubst,ksubst) -> begin let guard = nexp_subst_exp (kbindings_from_list ksubst) guard in let substs = bindings_union substs (bindings_from_list vsubst), @@ -683,101 +768,17 @@ let const_props defs ref_vars = let (E_aux (guard,_)),assigns = const_prop_exp substs assigns guard in match guard with | E_lit (L_aux (L_true,_)) -> Some (exp,vsubst,ksubst) - | E_lit (L_aux (L_false,_)) -> findpat_generic check_pat description assigns tl + | E_lit (L_aux (L_false,_)) -> findpat_generic description assigns tl | _ -> None end | GiveUp -> None end | (Pat_aux (Pat_exp (p,exp),_))::tl -> match check_pat p with - | DoesNotMatch -> findpat_generic check_pat description assigns tl + | DoesNotMatch -> findpat_generic description assigns tl | DoesMatch (subst,ksubst) -> Some (exp,subst,ksubst) | GiveUp -> None - in - match e with - | E_id id -> - (match Env.lookup_id id env with - | Enum _ -> - let checkpat = function - | P_aux (P_id id',_) - | P_aux (P_app (id',[]),_) -> - if Id.compare id id' = 0 then DoesMatch ([],[]) else DoesNotMatch - | P_aux (_,(l',_)) -> - (Reporting.print_err l' "Monomorphisation" - "Unexpected kind of pattern for enumeration"; GiveUp) - in findpat_generic checkpat (string_of_id id) assigns cases - | _ -> None) - | E_lit (L_aux (lit_e, lit_l)) -> - let checkpat = function - | P_aux (P_lit (L_aux (lit_p, _)),_) -> - if lit_match (lit_e,lit_p) then DoesMatch ([],[]) else DoesNotMatch - | P_aux (P_var (P_aux (P_id id,p_id_annot), TP_aux (TP_var kid, _)),_) -> - begin - match lit_e with - | L_num i -> - DoesMatch ([id, E_aux (e,(l,annot))], - [kid,Nexp_aux (Nexp_constant i,Unknown)]) - (* For undefined we fix the type-level size (because there's no good - way to construct an undefined size), but leave the term as undefined - to make the meaning clear. *) - | L_undef -> - let nexp = fabricate_nexp l annot in - let typ = subst_kids_typ (KBindings.singleton kid nexp) (typ_of_annot p_id_annot) in - DoesMatch ([id, E_aux (E_cast (typ,E_aux (e,(l,empty_tannot))),(l,empty_tannot))], - [kid,nexp]) - | _ -> - (Reporting.print_err lit_l "Monomorphisation" - "Unexpected kind of literal for var match"; GiveUp) - end - | P_aux (_,(l',_)) -> - (Reporting.print_err l' "Monomorphisation" - "Unexpected kind of pattern for literal"; GiveUp) - in findpat_generic checkpat "literal" assigns cases - | E_vector es when List.for_all (function (E_aux (E_lit _,_)) -> true | _ -> false) es -> - let checkpat = function - | P_aux (P_vector ps,_) -> - let matches = List.map2 (fun e p -> - match e, p with - | E_aux (E_lit (L_aux (lit,_)),_), P_aux (P_lit (L_aux (lit',_)),_) -> - if lit_match (lit,lit') then DoesMatch ([],[]) else DoesNotMatch - | E_aux (E_lit l,_), P_aux (P_id var,_) when pat_id_is_variable env var -> - DoesMatch ([var, e],[]) - | _ -> GiveUp) es ps in - let final = List.fold_left (fun acc m -> match acc, m with - | _, GiveUp -> GiveUp - | GiveUp, _ -> GiveUp - | DoesMatch (sub,ksub), DoesMatch(sub',ksub') -> DoesMatch(sub@sub',ksub@ksub') - | _ -> DoesNotMatch) (DoesMatch ([],[])) matches in - (match final with - | GiveUp -> - (Reporting.print_err l "Monomorphisation" - "Unexpected kind of pattern for vector literal"; GiveUp) - | _ -> final) - | _ -> - (Reporting.print_err l "Monomorphisation" - "Unexpected kind of pattern for vector literal"; GiveUp) - in findpat_generic checkpat "vector literal" assigns cases - - | E_cast (undef_typ, (E_aux (E_lit (L_aux (L_undef, lit_l)),_) as e_undef)) -> - let checkpat = function - | P_aux (P_lit (L_aux (lit_p, _)),_) -> DoesNotMatch - | P_aux (P_var (P_aux (P_id id,p_id_annot), TP_aux (TP_var kid, _)),_) -> - (* For undefined we fix the type-level size (because there's no good - way to construct an undefined size), but leave the term as undefined - to make the meaning clear. *) - let nexp = fabricate_nexp l annot in - let kids = equal_kids (env_of_annot p_id_annot) kid in - let ksubst = KidSet.fold (fun k b -> KBindings.add k nexp b) kids KBindings.empty in - let typ = subst_kids_typ ksubst (typ_of_annot p_id_annot) in - DoesMatch ([id, E_aux (E_cast (typ,e_undef),(l,empty_tannot))], - KBindings.bindings ksubst) - | P_aux (_,(l',_)) -> - (Reporting.print_err l' "Monomorphisation" - "Unexpected kind of pattern for literal"; GiveUp) - in findpat_generic checkpat "literal" assigns cases - | E_record _ | E_cast (_, E_aux (E_record _, _)) -> - findpat_generic (fun _ -> DoesNotMatch) "record" assigns cases - | _ -> None + in findpat_generic (string_of_exp exp0) assigns cases and can_match exp = let env = Type_check.env_of exp in diff --git a/src/monomorphise.ml b/src/monomorphise.ml index a37ff69a..03527ef3 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -167,7 +167,9 @@ let rec split_insts = function let apply_kid_insts kid_insts t = let kid_insts, kids' = split_insts kid_insts in - let kid_insts = List.map (fun (v,i) -> (v,Nexp_aux (Nexp_constant i,Generated Unknown))) kid_insts in + let kid_insts = List.map + (fun (v,i) -> (kopt_kid v,Nexp_aux (Nexp_constant i,Generated Unknown))) + kid_insts in let subst = kbindings_from_list kid_insts in kids', subst_kids_typ subst t @@ -193,14 +195,12 @@ let rec inst_src_type insts (Typ_aux (ty,l) as typ) = args (insts,[]) in insts, Typ_aux (Typ_app (id,ts),l) | Typ_exist (kopts, nc, t) -> begin - (* TODO handle non-integer existentials *) - let kids = List.map kopt_kid kopts in - let kid_insts, insts' = peel (kids,insts) in - let kids', t' = apply_kid_insts kid_insts t in + let kid_insts, insts' = peel (kopts,insts) in + let kopts', t' = apply_kid_insts kid_insts t in (* TODO: subst in nc *) - match kids' with + match kopts' with | [] -> insts', t' - | _ -> insts', Typ_aux (Typ_exist (List.map (mk_kopt K_int) kids', nc, t'), l) + | _ -> insts', Typ_aux (Typ_exist (kopts', nc, t'), l) end | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" and inst_src_typ_arg insts (A_aux (ta,l) as tyarg) = @@ -249,7 +249,7 @@ let rec size_nvars_nexp (Nexp_aux (ne,_)) = (* Given a type for a constructor, work out which refinements we ought to produce *) (* TODO collision avoidance *) -let split_src_type all_errors id ty (TypQ_aux (q,ql)) = +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 @@ -264,7 +264,8 @@ let split_src_type all_errors id ty (TypQ_aux (q,ql)) = let i = string_of_id id in (* This was originally written for the general case, but I cut it down to the more manageable prenex-form below *) - let rec size_nvars_ty (Typ_aux (ty,l) as typ) = + let rec size_nvars_ty typ = + let Typ_aux (ty,l) = Env.expand_synonyms env typ in match ty with | Typ_id _ | Typ_var _ @@ -286,30 +287,28 @@ let split_src_type all_errors id ty (TypQ_aux (q,ql)) = (KidSet.empty,[[],typ]) (* We only support sizes for bitvectors mentioned explicitly, not any buried inside another type *) | Typ_exist (kopts, nc, t) -> - (* TODO handle non integer existentials *) - let kids = List.map kopt_kid kopts in let (vars,tys) = size_nvars_ty t in let find_insts k (insts,nc) = let inst,nc' = - if KidSet.mem k vars then - let is,nc' = extract_set_nc l k nc in + if KidSet.mem (kopt_kid k) vars then + let is,nc' = extract_set_nc l (kopt_kid k) nc in Some is,nc' else None,nc in (k,inst)::insts,nc' in - let (insts,nc') = List.fold_right find_insts kids ([],nc) in + let (insts,nc') = List.fold_right find_insts kopts ([],nc) in let insts = cross'' insts in let ty_and_inst (inst0,ty) inst = - let kids, ty = apply_kid_insts inst ty in + let kopts, ty = apply_kid_insts inst ty in let ty = (* Typ_exist is not allowed an empty list of kids *) - match kids with + match kopts with | [] -> ty - | _ -> Typ_aux (Typ_exist (List.map (mk_kopt K_int) kids, nc', ty),l) + | _ -> Typ_aux (Typ_exist (kopts, nc', ty),l) in inst@inst0, ty in let tys = List.concat (List.map (fun instty -> List.map (ty_and_inst instty) insts) tys) in - let free = List.fold_left (fun vars k -> KidSet.remove k vars) vars kids in + let free = List.fold_left (fun vars k -> KidSet.remove (kopt_kid k) vars) vars kopts in (free,tys) | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" in @@ -320,14 +319,8 @@ let split_src_type all_errors id ty (TypQ_aux (q,ql)) = begin match snd (size_nvars_ty typ) with | [] -> [] + | [[],_] -> [] | tys -> - (* One level of tuple type is stripped off by the type checker, so - add another here *) - let tys = - List.map (fun (x,ty) -> - x, match ty with - | Typ_aux (Typ_tup _,_) -> Typ_aux (Typ_tup [ty],Unknown) - | _ -> ty) tys in if contains_exist t then cannot l "Only prenex types in unions are supported by monomorphisation" [] else if List.length kids > 1 then @@ -341,7 +334,7 @@ let split_src_type all_errors id ty (TypQ_aux (q,ql)) = let variants = size_nvars_ty ty in match variants with | [] -> None - | sample::__ -> + | sample::_ -> if List.length variants > size_set_limit then cannot ql (string_of_int (List.length variants) ^ "variants for constructor " ^ i ^ @@ -353,7 +346,7 @@ let split_src_type all_errors id ty (TypQ_aux (q,ql)) = in let name_seg = function | (_,None) -> "" - | (k,Some i) -> string_of_kid k ^ Big_int.to_string i + | (k,Some i) -> string_of_kid (kopt_kid k) ^ Big_int.to_string i in let name l i = String.concat "_" (i::(List.map name_seg l)) in Some (List.map (fun (l,ty) -> (l, wrap (name l),ty)) variants) @@ -395,7 +388,7 @@ let typ_of_args args = let refine_constructor refinements l env id args = match List.find (fun (id',_) -> Id.compare id id' = 0) refinements with | (_,irefinements) -> begin - let (_,constr_ty) = Env.get_val_spec id env in + let (_,constr_ty) = Env.get_union_id id env in match constr_ty with (* A constructor should always have a single argument. *) | Typ_aux (Typ_fn ([constr_ty],_,_),_) -> begin @@ -403,11 +396,9 @@ let refine_constructor refinements l env id args = match Type_check.destruct_exist (Type_check.Env.expand_synonyms env constr_ty) with | None -> None | Some (kopts,nc,constr_ty) -> - (* TODO: Handle non-integer existentials *) - let kids = List.map kopt_kid kopts in let bindings = Type_check.unify l env (tyvars_of_typ constr_ty) constr_ty arg_ty in - let find_kid kid = try Some (KBindings.find kid bindings) with Not_found -> None in - let bindings = List.map find_kid kids in + let find_kopt kopt = try Some (KBindings.find (kopt_kid kopt) bindings) with Not_found -> None in + let bindings = List.map find_kopt kopts in let matches_refinement (mapping,_,_) = List.for_all2 (fun v (_,w) -> @@ -624,12 +615,12 @@ let apply_pat_choices choices = e_assert = rewrite_assert; e_case = rewrite_case } -let split_defs all_errors splits defs = +let split_defs all_errors splits env defs = let no_errors_happened = ref true in let error_opt = if all_errors then Some no_errors_happened else None in let split_constructors (Defs defs) = let sc_type_union q (Tu_aux (Tu_ty_id (ty, id), l)) = - match split_src_type error_opt id ty q with + match split_src_type error_opt env id ty q with | None -> ([],[Tu_aux (Tu_ty_id (ty,id),l)]) | Some variants -> ([(id,variants)], @@ -908,12 +899,14 @@ let split_defs all_errors splits defs = begin match List.find (fun (id',_) -> Id.compare id id' = 0) refinements with | (_,variants) -> +(* TODO: what changes to the pattern and what substitutions do we need in general? let kid,kid_annot = match args with | [P_aux (P_var (_, TP_aux (TP_var kid, _)),ann)] -> kid,ann | _ -> raise (Reporting.err_general l - "Pattern match not currently supported by monomorphisation") + ("Pattern match not currently supported by monomorphisation: " + ^ string_of_pat pat)) in let map_inst (insts,id',_) = let insts = @@ -931,6 +924,11 @@ let split_defs all_errors splits defs = P_aux (P_app (id',[P_aux (P_id (id_of_kid kid),kid_annot)]),(Generated l,tannot)), kbindings_from_list insts in +*) + let map_inst (insts,id',_) = + P_aux (P_app (id',args),(Generated l,tannot)), + KBindings.empty + in ConstrSplit (List.map map_inst variants) | exception Not_found -> NoSplit end @@ -1018,9 +1016,9 @@ let split_defs all_errors splits defs = FE_aux (FE_Fexp (id,map_exp e),annot) and map_pexp = function | Pat_aux (Pat_exp (p,e),l) -> - let nosplit = [Pat_aux (Pat_exp (p,map_exp e),l)] in + let nosplit = lazy [Pat_aux (Pat_exp (p,map_exp e),l)] in (match map_pat p with - | NoSplit -> nosplit + | NoSplit -> Lazy.force nosplit | VarSplit patsubsts -> if check_split_size patsubsts (pat_loc p) then List.map (fun (pat',substs,pchoices,ksubsts) -> @@ -1031,7 +1029,7 @@ let split_defs all_errors splits defs = let exp' = stop_at_false_assertions exp' in Pat_aux (Pat_exp (pat', map_exp exp'),l)) patsubsts - else nosplit + else Lazy.force nosplit | ConstrSplit patnsubsts -> List.map (fun (pat',nsubst) -> let pat' = Spec_analysis.nexp_subst_pat nsubst pat' in @@ -1039,9 +1037,9 @@ let split_defs all_errors splits defs = Pat_aux (Pat_exp (pat', map_exp exp'),l) ) patnsubsts) | Pat_aux (Pat_when (p,e1,e2),l) -> - let nosplit = [Pat_aux (Pat_when (p,map_exp e1,map_exp e2),l)] in + let nosplit = lazy [Pat_aux (Pat_when (p,map_exp e1,map_exp e2),l)] in (match map_pat p with - | NoSplit -> nosplit + | NoSplit -> Lazy.force nosplit | VarSplit patsubsts -> if check_split_size patsubsts (pat_loc p) then List.map (fun (pat',substs,pchoices,ksubsts) -> @@ -1055,7 +1053,7 @@ let split_defs all_errors splits defs = let exp2' = stop_at_false_assertions exp2' in Pat_aux (Pat_when (pat', map_exp exp1', map_exp exp2'),l)) patsubsts - else nosplit + else Lazy.force nosplit | ConstrSplit patnsubsts -> List.map (fun (pat',nsubst) -> let pat' = Spec_analysis.nexp_subst_pat nsubst pat' in @@ -2222,30 +2220,34 @@ let rec analyse_exp fn_id env assigns (E_aux (e,(l,annot)) as exp) = (List.fold_left (fun tenv kopt -> Env.add_typ_var l kopt tenv) tenv kopts), typ in - if is_bitvector_typ typ then - let size,_,_ = vector_typ_args_of typ in - let Nexp_aux (size,_) as size_nexp = simplify_size_nexp env tenv size in - let is_tyvar_parameter v = - List.exists (fun k -> Kid.compare k v == 0) env.top_kids - in - match size with - | Nexp_constant _ -> r - | Nexp_var v when is_tyvar_parameter v -> - { r with kid_in_caller = CallerKidSet.add (fn_id,v) r.kid_in_caller } - | _ -> - match deps_of_nexp l env.kid_deps [] size_nexp with - | Have (args,extras) -> - { r with - split = ArgSplits.merge merge_detail r.split args; - extra_splits = merge_extras r.extra_splits extras - } - | Unknown (l,msg) -> - { r with - failures = - Failures.add l (StringSet.singleton ("Unable to monomorphise " ^ string_of_nexp size_nexp ^ ": " ^ msg)) - r.failures } - else - r + let rec check_typ typ = + if is_bitvector_typ typ then + let size,_,_ = vector_typ_args_of typ in + let Nexp_aux (size,_) as size_nexp = simplify_size_nexp env tenv size in + let is_tyvar_parameter v = + List.exists (fun k -> Kid.compare k v == 0) env.top_kids + in + match size with + | Nexp_constant _ -> r + | Nexp_var v when is_tyvar_parameter v -> + { r with kid_in_caller = CallerKidSet.add (fn_id,v) r.kid_in_caller } + | _ -> + match deps_of_nexp l env.kid_deps [] size_nexp with + | Have (args,extras) -> + { r with + split = ArgSplits.merge merge_detail r.split args; + extra_splits = merge_extras r.extra_splits extras + } + | Unknown (l,msg) -> + { r with + failures = + Failures.add l (StringSet.singleton ("Unable to monomorphise " ^ string_of_nexp size_nexp ^ ": " ^ msg)) + r.failures } + else match typ with + | Typ_aux (Typ_tup typs,_) -> + List.fold_left (fun r ty -> merge r (check_typ ty)) r typs + | _ -> r + in check_typ typ in (deps, assigns, r) @@ -3665,7 +3667,7 @@ let monomorphise opts splits defs = then () else raise (Reporting.err_general Unknown "Unable to monomorphise program") in - let ok_split, defs = split_defs opts.all_split_errors splits defs in + let ok_split, defs = split_defs opts.all_split_errors splits env defs in let () = if (ok_analysis && ok_extras && ok_split) || opts.continue_anyway then () else raise (Reporting.err_general Unknown "Unable to monomorphise program") -- cgit v1.2.3 From 911153ffefdfb090557c6dfcc5a5143419c34f56 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Thu, 25 Apr 2019 17:13:29 +0100 Subject: More read/write function updates --- src/gen_lib/sail2_state_monad.lem | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/gen_lib/sail2_state_monad.lem b/src/gen_lib/sail2_state_monad.lem index 3042700c..8ea919f9 100644 --- a/src/gen_lib/sail2_state_monad.lem +++ b/src/gen_lib/sail2_state_monad.lem @@ -147,8 +147,8 @@ let read_memtS rk a sz = maybe_failS "bits_of_mem_bytes" (of_bits (bits_of_mem_bytes bytes)) >>$= (fun mem_val -> returnS (mem_val, tag)))) -val read_memS : forall 'regs 'e 'a 'b. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monadS 'regs 'b 'e -let read_memS rk a sz = +val read_memS : forall 'regs 'e 'a 'b 'addrsize. Bitvector 'a, Bitvector 'b => read_kind -> 'addrsize -> 'a -> integer -> monadS 'regs 'b 'e +let read_memS rk addr_size a sz = read_memtS rk a sz >>$= (fun (bytes, _) -> returnS bytes) @@ -186,9 +186,9 @@ let write_memtS wk addr sz v t = | _ -> failS "write_mem" end -val write_memS : forall 'regs 'e 'a 'b. Bitvector 'a, Bitvector 'b => - write_kind -> 'a -> integer -> 'b -> monadS 'regs bool 'e -let write_memS wk addr sz v = write_memtS wk addr sz v B0 +val write_memS : forall 'regs 'e 'a 'b 'addrsize. Bitvector 'a, Bitvector 'b => + write_kind -> 'addrsize -> 'a -> integer -> 'b -> monadS 'regs bool 'e +let write_memS wk addr_size addr sz v = write_memtS wk addr sz v B0 val read_regS : forall 'regs 'rv 'a 'e. register_ref 'regs 'rv 'a -> monadS 'regs 'a 'e let read_regS reg = readS (fun s -> reg.read_from s.regstate) -- cgit v1.2.3 From 8ce42bfda56863c2caac91155b3e92a7b722862a Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Thu, 25 Apr 2019 17:13:44 +0100 Subject: Fill in missing map_..._annot case --- src/ast_util.ml | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index b0a11c70..33af1be7 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -691,12 +691,16 @@ and map_def_annot f = function | DEF_default ds -> DEF_default ds | DEF_scattered sd -> DEF_scattered (map_scattered_annot f sd) | DEF_measure (id, pat, exp) -> DEF_measure (id, map_pat_annot f pat, map_exp_annot f exp) + | DEF_loop_measures (id, measures) -> DEF_loop_measures (id, List.map (map_loop_measure_annot f) measures) | DEF_reg_dec ds -> DEF_reg_dec (map_decspec_annot f ds) | DEF_internal_mutrec fds -> DEF_internal_mutrec (List.map (map_fundef_annot f) fds) | DEF_pragma (name, arg, l) -> DEF_pragma (name, arg, l) and map_defs_annot f = function | Defs defs -> Defs (List.map (map_def_annot f) defs) +and map_loop_measure_annot f = function + | Loop (loop, exp) -> Loop (loop, map_exp_annot f exp) + let id_loc = function | Id_aux (_, l) -> l -- cgit v1.2.3 From 383bf94704813ad3f417b6eaf59d329388ff5af6 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Fri, 26 Apr 2019 12:17:04 +0100 Subject: More constructor monomorphisation support - handle multiple bitvector length variables - more fine-grained unnecessary cast insertion checks - add tuple matching support to constant propagation (for the test) --- src/constant_propagation.ml | 160 +++++++++++++++++++++----------------------- src/monomorphise.ml | 16 ++--- 2 files changed, 83 insertions(+), 93 deletions(-) (limited to 'src') diff --git a/src/constant_propagation.ml b/src/constant_propagation.ml index 51d079e9..608d25e1 100644 --- a/src/constant_propagation.ml +++ b/src/constant_propagation.ml @@ -110,7 +110,7 @@ let rec is_value (E_aux (e,(l,annot))) = match e with | E_id id -> is_constructor id | E_lit _ -> true - | E_tuple es -> List.for_all is_value es + | E_tuple es | E_vector es -> List.for_all is_value es | E_record fes -> List.for_all (fun (FE_aux (FE_Fexp (_, e), _)) -> is_value e) fes | E_app (id,es) -> is_constructor id && List.for_all is_value es @@ -655,9 +655,22 @@ let const_props defs ref_vars = | _ -> exp and can_match_with_env env (E_aux (e,(l,annot)) as exp0) cases (substs,ksubsts) assigns = - let rec check_exp_pat (E_aux (e,(l,annot))) (P_aux (p,(l',_))) = - match e with - | E_id id -> + let rec check_exp_pat (E_aux (e,(l,annot)) as exp) (P_aux (p,(l',_)) as pat) = + match e, p with + | _, P_wild -> DoesMatch ([],[]) + | _, P_typ (_,p') -> check_exp_pat exp p' + | _, P_id id' when pat_id_is_variable env id' -> DoesMatch ([id',exp],[]) + | E_tuple es, P_tup ps -> + let rec check = function + | DoesNotMatch -> fun _ -> DoesNotMatch + | GiveUp -> fun _ -> GiveUp + | DoesMatch (s,ns) -> + fun (e,p) -> + match check_exp_pat e p with + | DoesMatch (s',ns') -> DoesMatch (s@s', ns@ns') + | x -> x + in List.fold_left check (DoesMatch ([],[])) (List.combine es ps) + | E_id id, _ -> (match Env.lookup_id id env with | Enum _ -> begin match p with @@ -669,95 +682,76 @@ let const_props defs ref_vars = "Unexpected kind of pattern for enumeration"; GiveUp) end | _ -> GiveUp) - | E_lit (L_aux (lit_e, lit_l)) -> begin - match p with - | P_lit (L_aux (lit_p, _)) -> - if lit_match (lit_e,lit_p) then DoesMatch ([],[]) else DoesNotMatch - | P_var (P_aux (P_id id,p_id_annot), TP_aux (TP_var kid, _)) -> - begin - match lit_e with - | L_num i -> - DoesMatch ([id, E_aux (e,(l,annot))], - [kid,Nexp_aux (Nexp_constant i,Unknown)]) - (* For undefined we fix the type-level size (because there's no good - way to construct an undefined size), but leave the term as undefined - to make the meaning clear. *) - | L_undef -> - let nexp = fabricate_nexp l annot in - let typ = subst_kids_typ (KBindings.singleton kid nexp) (typ_of_annot p_id_annot) in - DoesMatch ([id, E_aux (E_cast (typ,E_aux (e,(l,empty_tannot))),(l,empty_tannot))], - [kid,nexp]) - | _ -> - (Reporting.print_err lit_l "Monomorphisation" - "Unexpected kind of literal for var match"; GiveUp) - end - | _ -> - (Reporting.print_err l' "Monomorphisation" - "Unexpected kind of pattern for literal"; GiveUp) - end - | E_vector es when List.for_all (function (E_aux (E_lit _,_)) -> true | _ -> false) es -> begin - match p with - | P_vector ps -> - let matches = List.map2 (fun e p -> - match e, p with - | E_aux (E_lit (L_aux (lit,_)),_), P_aux (P_lit (L_aux (lit',_)),_) -> - if lit_match (lit,lit') then DoesMatch ([],[]) else DoesNotMatch - | E_aux (E_lit l,_), P_aux (P_id var,_) when pat_id_is_variable env var -> - DoesMatch ([var, e],[]) - | _ -> GiveUp) es ps in - let final = List.fold_left (fun acc m -> match acc, m with - | _, GiveUp -> GiveUp - | GiveUp, _ -> GiveUp - | DoesMatch (sub,ksub), DoesMatch(sub',ksub') -> DoesMatch(sub@sub',ksub@ksub') - | _ -> DoesNotMatch) (DoesMatch ([],[])) matches in - (match final with - | GiveUp -> - (Reporting.print_err l "Monomorphisation" - "Unexpected kind of pattern for vector literal"; GiveUp) - | _ -> final) - | _ -> + | E_lit (L_aux (lit_e, lit_l)), P_lit (L_aux (lit_p, _)) -> + if lit_match (lit_e,lit_p) then DoesMatch ([],[]) else DoesNotMatch + | E_lit (L_aux (lit_e, lit_l)), + P_var (P_aux (P_id id,p_id_annot), TP_aux (TP_var kid, _)) -> + begin + match lit_e with + | L_num i -> + DoesMatch ([id, E_aux (e,(l,annot))], + [kid,Nexp_aux (Nexp_constant i,Unknown)]) + (* For undefined we fix the type-level size (because there's no good + way to construct an undefined size), but leave the term as undefined + to make the meaning clear. *) + | L_undef -> + let nexp = fabricate_nexp l annot in + let typ = subst_kids_typ (KBindings.singleton kid nexp) (typ_of_annot p_id_annot) in + DoesMatch ([id, E_aux (E_cast (typ,E_aux (e,(l,empty_tannot))),(l,empty_tannot))], + [kid,nexp]) + | _ -> + (Reporting.print_err lit_l "Monomorphisation" + "Unexpected kind of literal for var match"; GiveUp) + end + | E_lit _, _ -> + (Reporting.print_err l' "Monomorphisation" + "Unexpected kind of pattern for literal"; GiveUp) + | E_vector es, P_vector ps + when List.for_all (function (E_aux (E_lit _,_)) -> true | _ -> false) es -> + let matches = List.map2 (fun e p -> + match e, p with + | E_aux (E_lit (L_aux (lit,_)),_), P_aux (P_lit (L_aux (lit',_)),_) -> + if lit_match (lit,lit') then DoesMatch ([],[]) else DoesNotMatch + | E_aux (E_lit l,_), P_aux (P_id var,_) when pat_id_is_variable env var -> + DoesMatch ([var, e],[]) + | _ -> GiveUp) es ps in + let final = List.fold_left (fun acc m -> match acc, m with + | _, GiveUp -> GiveUp + | GiveUp, _ -> GiveUp + | DoesMatch (sub,ksub), DoesMatch(sub',ksub') -> DoesMatch(sub@sub',ksub@ksub') + | _ -> DoesNotMatch) (DoesMatch ([],[])) matches in + (match final with + | GiveUp -> (Reporting.print_err l "Monomorphisation" "Unexpected kind of pattern for vector literal"; GiveUp) - end - | E_cast (undef_typ, (E_aux (E_lit (L_aux (L_undef, lit_l)),_) as e_undef)) -> begin - match p with - | P_lit (L_aux (lit_p, _)) -> DoesNotMatch - | P_var (P_aux (P_id id,p_id_annot), TP_aux (TP_var kid, _)) -> - (* For undefined we fix the type-level size (because there's no good - way to construct an undefined size), but leave the term as undefined - to make the meaning clear. *) - let nexp = fabricate_nexp l annot in - let kids = equal_kids (env_of_annot p_id_annot) kid in - let ksubst = KidSet.fold (fun k b -> KBindings.add k nexp b) kids KBindings.empty in - let typ = subst_kids_typ ksubst (typ_of_annot p_id_annot) in - DoesMatch ([id, E_aux (E_cast (typ,e_undef),(l,empty_tannot))], - KBindings.bindings ksubst) - | _ -> + | _ -> final) + | E_vector _, _ -> + (Reporting.print_err l "Monomorphisation" + "Unexpected kind of pattern for vector literal"; GiveUp) + | E_cast (undef_typ, (E_aux (E_lit (L_aux (L_undef, lit_l)),_) as e_undef)), + P_lit (L_aux (lit_p, _)) + -> DoesNotMatch + | E_cast (undef_typ, (E_aux (E_lit (L_aux (L_undef, lit_l)),_) as e_undef)), + P_var (P_aux (P_id id,p_id_annot), TP_aux (TP_var kid, _)) -> + (* For undefined we fix the type-level size (because there's no good + way to construct an undefined size), but leave the term as undefined + to make the meaning clear. *) + let nexp = fabricate_nexp l annot in + let kids = equal_kids (env_of_annot p_id_annot) kid in + let ksubst = KidSet.fold (fun k b -> KBindings.add k nexp b) kids KBindings.empty in + let typ = subst_kids_typ ksubst (typ_of_annot p_id_annot) in + DoesMatch ([id, E_aux (E_cast (typ,e_undef),(l,empty_tannot))], + KBindings.bindings ksubst) + | E_cast (undef_typ, (E_aux (E_lit (L_aux (L_undef, lit_l)),_) as e_undef)), _ -> (Reporting.print_err l' "Monomorphisation" "Unexpected kind of pattern for literal"; GiveUp) - end - | E_record _ | E_cast (_, E_aux (E_record _, _)) -> DoesNotMatch + | E_record _,_ | E_cast (_, E_aux (E_record _, _)),_ -> DoesNotMatch | _ -> GiveUp in let check_pat = check_exp_pat exp0 in let rec findpat_generic description assigns = function | [] -> (Reporting.print_err l "Monomorphisation" ("Failed to find a case for " ^ description); None) - | [Pat_aux (Pat_exp (P_aux (P_wild,_),exp),_)] -> Some (exp,[],[]) - | (Pat_aux (Pat_exp (P_aux (P_typ (_,p),_),exp),ann))::tl -> - findpat_generic description assigns ((Pat_aux (Pat_exp (p,exp),ann))::tl) - | (Pat_aux (Pat_exp (P_aux (P_id id',_),exp),_))::tlx - when pat_id_is_variable env id' -> - Some (exp, [(id', exp0)], []) - | (Pat_aux (Pat_when (P_aux (P_id id',_),guard,exp),_))::tl - when pat_id_is_variable env id' -> begin - let substs = Bindings.add id' exp0 substs, ksubsts in - let (E_aux (guard,_)),assigns = const_prop_exp substs assigns guard in - match guard with - | E_lit (L_aux (L_true,_)) -> Some (exp,[(id',exp0)],[]) - | E_lit (L_aux (L_false,_)) -> findpat_generic description assigns tl - | _ -> None - end | (Pat_aux (Pat_when (p,guard,exp),_))::tl -> begin match check_pat p with | DoesNotMatch -> findpat_generic description assigns tl diff --git a/src/monomorphise.ml b/src/monomorphise.ml index 03527ef3..0c63e020 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -165,13 +165,13 @@ let rec split_insts = function | (k,None)::t -> let l1,l2 = split_insts t in l1,k::l2 | (k,Some v)::t -> let l1,l2 = split_insts t in (k,v)::l1,l2 -let apply_kid_insts kid_insts t = +let apply_kid_insts kid_insts nc t = let kid_insts, kids' = split_insts kid_insts in let kid_insts = List.map (fun (v,i) -> (kopt_kid v,Nexp_aux (Nexp_constant i,Generated Unknown))) kid_insts in let subst = kbindings_from_list kid_insts in - kids', subst_kids_typ subst t + kids', subst_kids_nc subst nc, subst_kids_typ subst t let rec inst_src_type insts (Typ_aux (ty,l) as typ) = match ty with @@ -196,11 +196,10 @@ let rec inst_src_type insts (Typ_aux (ty,l) as typ) = in insts, Typ_aux (Typ_app (id,ts),l) | Typ_exist (kopts, nc, t) -> begin let kid_insts, insts' = peel (kopts,insts) in - let kopts', t' = apply_kid_insts kid_insts t in - (* TODO: subst in nc *) + let kopts', nc', t' = apply_kid_insts kid_insts nc t in match kopts' with | [] -> insts', t' - | _ -> insts', Typ_aux (Typ_exist (kopts', nc, t'), l) + | _ -> insts', Typ_aux (Typ_exist (kopts', nc', t'), l) end | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" and inst_src_typ_arg insts (A_aux (ta,l) as tyarg) = @@ -299,7 +298,7 @@ let split_src_type all_errors env id ty (TypQ_aux (q,ql)) = let (insts,nc') = List.fold_right find_insts kopts ([],nc) in let insts = cross'' insts in let ty_and_inst (inst0,ty) inst = - let kopts, ty = apply_kid_insts inst ty in + let kopts, nc', ty = apply_kid_insts inst nc' ty in let ty = (* Typ_exist is not allowed an empty list of kids *) match kopts with @@ -312,7 +311,6 @@ let split_src_type all_errors env id ty (TypQ_aux (q,ql)) = (free,tys) | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" in - (* Only single-variable prenex-form for now *) let size_nvars_ty (Typ_aux (ty,l) as typ) = match ty with | Typ_exist (kids,_,t) -> @@ -323,9 +321,6 @@ let split_src_type all_errors env id ty (TypQ_aux (q,ql)) = | tys -> if contains_exist t then cannot l "Only prenex types in unions are supported by monomorphisation" [] - else if List.length kids > 1 then - cannot l - "Only single-variable existential types in unions are currently supported by monomorphisation" [] else tys end | _ -> [] @@ -3212,6 +3207,7 @@ let make_bitvector_cast_exp cast_name cast_env quant_kids typ target_typ exp = in (* Push the cast down, including through constructors *) let rec aux exp (typ, target_typ) = + if alpha_equivalent cast_env typ target_typ then exp else let exp_env = env_of exp in match exp with | E_aux (E_let (lb,exp'),ann) -> -- cgit v1.2.3 From 094c8e254abde44d45097aca7a36203704fe2ef4 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Fri, 26 Apr 2019 17:20:20 +0100 Subject: Fix some broken interpreter tests --- src/value.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/value.ml b/src/value.ml index 279d3aba..45767d50 100644 --- a/src/value.ml +++ b/src/value.ml @@ -375,7 +375,7 @@ let value_add_vec_int = function let value_sub_vec_int = function | [v1; v2] -> mk_vector (Sail_lib.sub_vec_int (coerce_bv v1, coerce_int v2)) - | _ -> failwith "value add_vec_int" + | _ -> failwith "value sub_vec_int" let value_add_vec = function | [v1; v2] -> mk_vector (Sail_lib.add_vec (coerce_bv v1, coerce_bv v2)) -- cgit v1.2.3